src/Language/Haskell/LSP/Test/Recorded.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 -- | A testing tool for replaying recorded client logs back to a server,
   5 -- and validating that the server output matches up with another log.
   6 module Language.Haskell.LSP.Test.Recorded
   7   ( replay,
   8     sendNextRequest
   9   )
  10 where
  11
  12 import           Control.Concurrent
  13 import           Control.Monad.Trans.Class
  14 import           Control.Monad.Trans.Reader
  15 import           Control.Monad.Trans.State
  16 import           Control.Monad.IO.Class
  17 import qualified Data.ByteString.Lazy.Char8    as B
  18 import           Language.Haskell.LSP.Capture
  19 import           Language.Haskell.LSP.Messages
  20 import qualified Language.Haskell.LSP.Types    as LSP
  21 import           Data.Aeson
  22 import           Data.Maybe
  23 import           Control.Lens
  24 import           Control.Monad
  25 import           System.IO
  26 import           System.Directory
  27 import           System.FilePath
  28 import           System.Process
  29 import           Language.Haskell.LSP.Test.Files
  30 import           Language.Haskell.LSP.Test.Parsing
  31
  32 data SessionContext = SessionContext
  33   {
  34     reqSema :: MVar LSP.LspId,
  35     rspSema :: MVar LSP.LspIdRsp,
  36     serverIn :: Handle
  37   }
  38 type Session = StateT [FromClientMessage] (ReaderT SessionContext IO)
  39
  40 -- | Replays a recorded client output and
  41 -- makes sure it matches up with an expected response.
  42 replay :: FilePath -- ^ The recorded session directory.
  43        -> Session a
  44        -> IO ()
  45 replay sessionDir session = do
  46
  47   let sessionFp = sessionDir </> "session.log"
  48
  49   -- need to keep hold of current directory since haskell-lsp changes it
  50   prevRootDir <- getCurrentDirectory
  51
  52   (Just serverIn, Just serverOut, _, serverProc) <- createProcess
  53     (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in  = CreatePipe
  54                                                  , std_out = CreatePipe
  55                                                  }
  56
  57   hSetBuffering serverIn  NoBuffering
  58   hSetBuffering serverOut NoBuffering
  59
  60   -- whether to send the next request
  61   reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
  62   -- whether to send the next response
  63   rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
  64   let semas = (reqSema, rspSema)
  65
  66   entries <- B.lines <$> B.readFile sessionFp
  67
  68   -- decode session
  69   let unswappedEvents = map (fromJust . decode) entries
  70
  71   events <- swapFiles sessionDir unswappedEvents
  72
  73   let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
  74       requestMap = getRequestMap clientEvents
  75
  76   -- listen to server
  77   forkIO $ listenServer serverOut requestMap semas
  78
  79   runReaderT (runStateT session clientEvents) (SessionContext rspSema reqSema serverIn)
  80
  81   terminateProcess serverProc
  82
  83   -- restore directory
  84   setCurrentDirectory prevRootDir
  85
  86   where
  87     isClientMsg (FromClient _ _) = True
  88     isClientMsg _                = False
  89
  90     isServerMsg (FromServer _ _) = True
  91     isServerMsg _                = False
  92
  93 sendNextRequest :: Session ()
  94 sendNextRequest = do
  95   (nextMsg:remainingMsgs) <- get
  96   put remainingMsgs
  97   case nextMsg of
  98     ReqInitialize               m -> request m
  99     ReqShutdown                 m -> request m
 100     ReqHover                    m -> request m
 101     ReqCompletion               m -> request m
 102     ReqCompletionItemResolve    m -> request m
 103     ReqSignatureHelp            m -> request m
 104     ReqDefinition               m -> request m
 105     ReqFindReferences           m -> request m
 106     ReqDocumentHighlights       m -> request m
 107     ReqDocumentSymbols          m -> request m
 108     ReqWorkspaceSymbols         m -> request m
 109     ReqCodeAction               m -> request m
 110     ReqCodeLens                 m -> request m
 111     ReqCodeLensResolve          m -> request m
 112     ReqDocumentFormatting       m -> request m
 113     ReqDocumentRangeFormatting  m -> request m
 114     ReqDocumentOnTypeFormatting m -> request m
 115     ReqRename                   m -> request m
 116     ReqExecuteCommand           m -> request m
 117     ReqDocumentLink             m -> request m
 118     ReqDocumentLinkResolve      m -> request m
 119     ReqWillSaveWaitUntil        m -> request m
 120     RspApplyWorkspaceEdit       m -> response m
 121     RspFromClient               m -> response m
 122     NotInitialized              m -> notification m
 123     NotExit                     m -> notification m
 124     NotCancelRequestFromClient  m -> notification m
 125     NotDidChangeConfiguration   m -> notification m
 126     NotDidOpenTextDocument      m -> notification m
 127     NotDidChangeTextDocument    m -> notification m
 128     NotDidCloseTextDocument     m -> notification m
 129     NotWillSaveTextDocument     m -> notification m
 130     NotDidSaveTextDocument      m -> notification m
 131     NotDidChangeWatchedFiles    m -> notification m
 132     UnknownFromClientMessage m ->
 133       error $ "Unknown message was recorded from the client" ++ show m
 134  where
 135   -- TODO: May need to prevent premature exit notification being sent
 136   notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 137     context <- lift ask
 138
 139     liftIO $ do
 140       putStrLn "Will send exit notification soon"
 141       threadDelay 10000000
 142       B.hPut (serverIn context) $ addHeader (encode msg)
 143
 144   notification msg@(LSP.NotificationMessage _ m _) = do
 145     context <- lift ask
 146
 147     liftIO $ B.hPut (serverIn context) $ addHeader (encode msg)
 148
 149     liftIO $ putStrLn $ "Sent a notification " ++ show m
 150
 151     sendNextRequest
 152
 153   request msg@(LSP.RequestMessage _ id m _) = do
 154     context <- lift ask
 155
 156     liftIO $ do
 157       when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 158
 159       B.hPut (serverIn context) $ addHeader (encode msg)
 160       putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 161
 162       rspId <- takeMVar (rspSema context)
 163       when (LSP.responseId id /= rspId) $
 164         error $ "Expected id " ++ show id ++ ", got " ++ show rspId
 165
 166   response msg@(LSP.ResponseMessage _ id _ _) = do
 167     context <- lift ask
 168
 169     liftIO $ do
 170       putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 171       reqId <- takeMVar (reqSema context)
 172       if LSP.responseId reqId /= id
 173         then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 174         else do
 175           B.hPut (serverIn context) $ addHeader (encode msg)
 176           putStrLn $ "Sent response to request id " ++ show id
 177
 178     sendNextRequest
 179
 180
 181 -- | Listens to the server output, makes sure it matches the record and
 182 -- signals any semaphores
 183 listenServer :: Handle -> RequestMap -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO ()
 184 listenServer h reqMap semas@(reqSema, rspSema) = do
 185   msgBytes <- getNextMessage h
 186
 187   let msg = decodeFromServerMsg reqMap msgBytes
 188
 189   print msg
 190
 191   case msg of
 192     ReqRegisterCapability       m -> request m
 193     ReqApplyWorkspaceEdit       m -> request m
 194     ReqShowMessage              m -> request m
 195     ReqUnregisterCapability     m -> request m
 196     RspInitialize               m -> response m
 197     RspShutdown                 m -> response m
 198     RspHover                    m -> response m
 199     RspCompletion               m -> response m
 200     RspCompletionItemResolve    m -> response m
 201     RspSignatureHelp            m -> response m
 202     RspDefinition               m -> response m
 203     RspFindReferences           m -> response m
 204     RspDocumentHighlights       m -> response m
 205     RspDocumentSymbols          m -> response m
 206     RspWorkspaceSymbols         m -> response m
 207     RspCodeAction               m -> response m
 208     RspCodeLens                 m -> response m
 209     RspCodeLensResolve          m -> response m
 210     RspDocumentFormatting       m -> response m
 211     RspDocumentRangeFormatting  m -> response m
 212     RspDocumentOnTypeFormatting m -> response m
 213     RspRename                   m -> response m
 214     RspExecuteCommand           m -> response m
 215     RspError                    m -> response m
 216     RspDocumentLink             m -> response m
 217     RspDocumentLinkResolve      m -> response m
 218     RspWillSaveWaitUntil        m -> response m
 219     NotPublishDiagnostics       m -> notification m
 220     NotLogMessage               m -> notification m
 221     NotShowMessage              m -> notification m
 222     NotTelemetry                m -> notification m
 223     NotCancelRequestFromServer  m -> notification m
 224
 225   listenServer h reqMap semas
 226
 227   where
 228   response :: Show a => LSP.ResponseMessage a -> IO ()
 229   response res = do
 230     putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 231
 232     print res
 233
 234     putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
 235
 236   request :: Show a => LSP.RequestMessage LSP.ServerMethod a b -> IO ()
 237   request req = do
 238     putStrLn
 239       $  "Got request for id "
 240       ++ show (req ^. LSP.id)
 241       ++ " "
 242       ++ show (req ^. LSP.method)
 243
 244     print req
 245
 246     putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 247
 248   notification :: Show a => LSP.NotificationMessage LSP.ServerMethod a -> IO ()
 249   notification n = do
 250     putStrLn $ "Got notification " ++ show (n ^. LSP.method)
 251     print n
 252
 253   --   lift
 254   --     $  putStrLn
 255   --     $  show (length (filter isNotification expectedMsgs) - 1)
 256   --     ++ " notifications remaining"
 257
 258   -- checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
 259   --   (  "Out of order\nExpected\n"
 260   --   ++ show firstExpected
 261   --   ++ "\nGot\n"
 262   --   ++ show msg
 263   --   ++ "\n"
 264   --   )
 265
 266   -- markReceived :: FromServerMessage -> Session [FromServerMessage]
 267   -- markReceived msg =
 268   --   let new = delete msg expectedMsgs
 269   --   in  if new == expectedMsgs
 270   --         then failSession ("Unexpected message: " ++ show msg) >> return new
 271   --         else return new
 272
 273   -- firstExpected = head $ filter (not . isNotification) expectedMsgs
 274
 275 isNotification :: FromServerMessage -> Bool
 276 isNotification (NotPublishDiagnostics      _) = True
 277 isNotification (NotLogMessage              _) = True
 278 isNotification (NotShowMessage             _) = True
 279 isNotification (NotCancelRequestFromServer _) = True
 280 isNotification _                              = False
 281
 282 -- TODO: QuickCheck tests?
 283 -- | Checks wether or not the message appears in the right order
 284 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 285 -- given N2, notification order doesn't matter.
 286 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 287 -- given REQ1
 288 -- @ N1 N3 N4 N5 REQ2 RES1 @
 289 -- given RES1
 290 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 291 -- Order of requests and responses matter
 292 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 293
 294 inRightOrder _ [] = error "Why is this empty"
 295 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 296
 297 inRightOrder received (expected : msgs)
 298   | received == expected    = True
 299   | isNotification expected = inRightOrder received msgs
 300   | otherwise               = False
 301
 302 -- | The internal monad for tests that can fail or pass,
 303 -- ending execution early.
 304 -- type Session = ReaderT (MVar Bool) IO
 305
 306 -- -- TODO: Make return type polymoprhic more like error
 307 -- failSession :: String -> Session ()
 308 -- failSession reason = do
 309 --   lift $ putStrLn reason
 310 --   passVar <- ask
 311 --   lift $ putMVar passVar False
 312
 313 -- passSession :: Session ()
 314 -- passSession = do
 315 --   passVar <- ask
 316 --   lift $ putMVar passVar True