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 FromServerMessage,
  35     rspSema :: MVar LSP.LspId,
  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   (Just serverIn, Just serverOut, _, serverProc) <- createProcess
  50     (proc "hie" ["--lsp", "-d", "-l", "/tmp/test-hie.log"]) { std_in  = CreatePipe
  51                                                  , std_out = CreatePipe
  52                                                  }
  53
  54   hSetBuffering serverIn  NoBuffering
  55   hSetBuffering serverOut NoBuffering
  56
  57   -- whether to send the next request
  58   reqSema <- newEmptyMVar
  59   -- whether to send the next response
  60   rspSema <- newEmptyMVar
  61
  62   entries <- B.lines <$> B.readFile sessionFp
  63
  64   -- decode session
  65   let unswappedEvents = map (fromJust . decode) entries
  66
  67   events <- swapFiles sessionDir unswappedEvents
  68
  69   let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
  70       requestMap = getRequestMap clientEvents
  71       context = (SessionContext rspSema reqSema serverIn)
  72
  73   -- listen to server
  74   forkIO $ listenServer serverOut requestMap context
  75
  76   runReaderT (runStateT session clientEvents) context
  77
  78   terminateProcess serverProc
  79
  80   where
  81     isClientMsg (FromClient _ _) = True
  82     isClientMsg _                = False
  83
  84     isServerMsg (FromServer _ _) = True
  85     isServerMsg _                = False
  86
  87 sendNextRequest :: Session FromServerMessage
  88 sendNextRequest = do
  89   (nextMsg:remainingMsgs) <- get
  90   put remainingMsgs
  91   case nextMsg of
  92     ReqInitialize               m -> request m
  93     ReqShutdown                 m -> request m
  94     ReqHover                    m -> request m
  95     ReqCompletion               m -> request m
  96     ReqCompletionItemResolve    m -> request m
  97     ReqSignatureHelp            m -> request m
  98     ReqDefinition               m -> request m
  99     ReqFindReferences           m -> request m
 100     ReqDocumentHighlights       m -> request m
 101     ReqDocumentSymbols          m -> request m
 102     ReqWorkspaceSymbols         m -> request m
 103     ReqCodeAction               m -> request m
 104     ReqCodeLens                 m -> request m
 105     ReqCodeLensResolve          m -> request m
 106     ReqDocumentFormatting       m -> request m
 107     ReqDocumentRangeFormatting  m -> request m
 108     ReqDocumentOnTypeFormatting m -> request m
 109     ReqRename                   m -> request m
 110     ReqExecuteCommand           m -> request m
 111     ReqDocumentLink             m -> request m
 112     ReqDocumentLinkResolve      m -> request m
 113     ReqWillSaveWaitUntil        m -> request m
 114     RspApplyWorkspaceEdit       m -> response m
 115     RspFromClient               m -> response m
 116     NotInitialized              m -> notification m
 117     NotExit                     m -> notification m
 118     NotCancelRequestFromClient  m -> notification m
 119     NotDidChangeConfiguration   m -> notification m
 120     NotDidOpenTextDocument      m -> notification m
 121     NotDidChangeTextDocument    m -> notification m
 122     NotDidCloseTextDocument     m -> notification m
 123     NotWillSaveTextDocument     m -> notification m
 124     NotDidSaveTextDocument      m -> notification m
 125     NotDidChangeWatchedFiles    m -> notification m
 126     UnknownFromClientMessage m ->
 127       error $ "Unknown message was recorded from the client" ++ show m
 128  where
 129   -- TODO: May need to prevent premature exit notification being sent
 130   notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
 131     context <- lift ask
 132
 133     liftIO $ do
 134       putStrLn "Will send exit notification soon"
 135       threadDelay 10000000
 136       B.hPut (serverIn context) $ addHeader (encode msg)
 137
 138     error "Done"
 139
 140   notification msg@(LSP.NotificationMessage _ m _) = do
 141     context <- lift ask
 142
 143     liftIO $ B.hPut (serverIn context) $ addHeader (encode msg)
 144
 145     liftIO $ putStrLn $ "Sent a notification " ++ show m
 146
 147     sendNextRequest
 148
 149   request msg@(LSP.RequestMessage _ id m _) = do
 150     context <- lift ask
 151
 152     liftIO $ do
 153
 154       print $ addHeader $ encode msg
 155
 156       B.hPut (serverIn context) $ addHeader (encode msg)
 157       putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 158
 159       rsp <- takeMVar (reqSema context)
 160       -- when (LSP.responseId id /= rsp ^. LSP.id) $
 161       --   error $ "Expected id " ++ show id ++ ", got " ++ show (rsp ^. LSP.id)
 162
 163       return rsp
 164
 165   response msg@(LSP.ResponseMessage _ id _ _) = do
 166     context <- lift ask
 167
 168     liftIO $ do
 169       putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 170       reqId <- takeMVar (rspSema context)
 171       if LSP.responseId reqId /= id
 172         then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 173         else do
 174           B.hPut (serverIn context) $ addHeader (encode msg)
 175           putStrLn $ "Sent response to request id " ++ show id
 176
 177     sendNextRequest
 178
 179
 180 -- | Listens to the server output, makes sure it matches the record and
 181 -- signals any semaphores
 182 listenServer :: Handle -> RequestMap -> SessionContext -> IO ()
 183 listenServer h reqMap context = do
 184
 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 msg
 197     RspShutdown                 m -> response m msg
 198     RspHover                    m -> response m msg
 199     RspCompletion               m -> response m msg
 200     RspCompletionItemResolve    m -> response m msg
 201     RspSignatureHelp            m -> response m msg
 202     RspDefinition               m -> response m msg
 203     RspFindReferences           m -> response m msg
 204     RspDocumentHighlights       m -> response m msg
 205     RspDocumentSymbols          m -> response m msg
 206     RspWorkspaceSymbols         m -> response m msg
 207     RspCodeAction               m -> response m msg
 208     RspCodeLens                 m -> response m msg
 209     RspCodeLensResolve          m -> response m msg
 210     RspDocumentFormatting       m -> response m msg
 211     RspDocumentRangeFormatting  m -> response m msg
 212     RspDocumentOnTypeFormatting m -> response m msg
 213     RspRename                   m -> response m msg
 214     RspExecuteCommand           m -> response m msg
 215     RspError                    m -> response m msg
 216     RspDocumentLink             m -> response m msg
 217     RspDocumentLinkResolve      m -> response m msg
 218     RspWillSaveWaitUntil        m -> response m msg
 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 context
 226
 227   where
 228   response :: Show a => LSP.ResponseMessage a -> FromServerMessage -> IO ()
 229   response res wrappedMsg = do
 230     putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 231
 232     putMVar (reqSema context) wrappedMsg -- send back the response for the request we're waiting on
 233
 234   request :: Show a => LSP.RequestMessage LSP.ServerMethod a b -> IO ()
 235   request req = do
 236     putStrLn
 237       $  "Got request for id "
 238       ++ show (req ^. LSP.id)
 239       ++ " "
 240       ++ show (req ^. LSP.method)
 241
 242     putMVar (rspSema context) (req ^. LSP.id) -- unblock the handler waiting for a response
 243
 244   notification :: Show a => LSP.NotificationMessage LSP.ServerMethod a -> IO ()
 245   notification n = putStrLn $ "Got notification " ++ show (n ^. LSP.method)
 246
 247   --   lift
 248   --     $  putStrLn
 249   --     $  show (length (filter isNotification expectedMsgs) - 1)
 250   --     ++ " notifications remaining"
 251
 252   -- checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
 253   --   (  "Out of order\nExpected\n"
 254   --   ++ show firstExpected
 255   --   ++ "\nGot\n"
 256   --   ++ show msg
 257   --   ++ "\n"
 258   --   )
 259
 260   -- markReceived :: FromServerMessage -> Session [FromServerMessage]
 261   -- markReceived msg =
 262   --   let new = delete msg expectedMsgs
 263   --   in  if new == expectedMsgs
 264   --         then failSession ("Unexpected message: " ++ show msg) >> return new
 265   --         else return new
 266
 267   -- firstExpected = head $ filter (not . isNotification) expectedMsgs
 268
 269 isNotification :: FromServerMessage -> Bool
 270 isNotification (NotPublishDiagnostics      _) = True
 271 isNotification (NotLogMessage              _) = True
 272 isNotification (NotShowMessage             _) = True
 273 isNotification (NotCancelRequestFromServer _) = True
 274 isNotification _                              = False
 275
 276 -- TODO: QuickCheck tests?
 277 -- | Checks wether or not the message appears in the right order
 278 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 279 -- given N2, notification order doesn't matter.
 280 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 281 -- given REQ1
 282 -- @ N1 N3 N4 N5 REQ2 RES1 @
 283 -- given RES1
 284 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 285 -- Order of requests and responses matter
 286 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 287
 288 inRightOrder _ [] = error "Why is this empty"
 289 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 290
 291 inRightOrder received (expected : msgs)
 292   | received == expected    = True
 293   | isNotification expected = inRightOrder received msgs
 294   | otherwise               = False
 295
 296 -- | The internal monad for tests that can fail or pass,
 297 -- ending execution early.
 298 -- type Session = ReaderT (MVar Bool) IO
 299
 300 -- -- TODO: Make return type polymoprhic more like error
 301 -- failSession :: String -> Session ()
 302 -- failSession reason = do
 303 --   lift $ putStrLn reason
 304 --   passVar <- ask
 305 --   lift $ putMVar passVar False
 306
 307 -- passSession :: Session ()
 308 -- passSession = do
 309 --   passVar <- ask
 310 --   lift $ putMVar passVar True