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   )
   9 where
  10
  11 import           Control.Concurrent
  12 import           Control.Monad.Trans.Class
  13 import           Control.Monad.Trans.Reader
  14 import qualified Data.ByteString.Lazy.Char8    as B
  15 import           Data.List
  16 import           Language.Haskell.LSP.Capture
  17 import           Language.Haskell.LSP.Messages
  18 import qualified Language.Haskell.LSP.Types    as LSP
  19 import           Data.Aeson
  20 import           Data.Maybe
  21 import           Control.Lens
  22 import           Control.Monad
  23 import           System.IO
  24 import           System.Directory
  25 import           System.Process
  26 import           Language.Haskell.LSP.Test.Files
  27 import           Language.Haskell.LSP.Test.Parsing
  28
  29 -- | Replays a recorded client output and
  30 -- makes sure it matches up with an expected response.
  31 replay
  32   :: FilePath -- ^ The recorded session file.
  33   -> FilePath -- ^ The root directory of the project
  34   -> IO Bool
  35 replay sessionFp curRootDir = do
  36
  37   -- need to keep hold of current directory since haskell-lsp changes it
  38   prevDir <- getCurrentDirectory
  39
  40   (Just serverIn, Just serverOut, _, serverProc) <- createProcess
  41     (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in  = CreatePipe
  42                                                  , std_out = CreatePipe
  43                                                  }
  44
  45   hSetBuffering serverIn  NoBuffering
  46   hSetBuffering serverOut NoBuffering
  47
  48   -- whether to send the next request
  49   reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
  50   -- whether to send the next response
  51   rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
  52   let semas = (reqSema, rspSema)
  53
  54   didPass <- newEmptyMVar
  55
  56   entries <- B.lines <$> B.readFile sessionFp
  57
  58   -- decode session
  59   let unswappedEvents = map (fromJust . decode) entries
  60
  61   events <- swapFiles curRootDir unswappedEvents
  62
  63   let clientEvents =
  64         map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
  65       serverEvents =
  66         map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
  67       requestMap = getRequestMap clientEvents
  68
  69   -- listen to server
  70   forkIO $ runReaderT (listenServer serverEvents serverOut requestMap semas)
  71                       didPass
  72
  73   forM_ clientEvents (processClient serverIn rspSema reqSema)
  74
  75   result <- takeMVar didPass
  76   terminateProcess serverProc
  77
  78   -- restore directory
  79   setCurrentDirectory prevDir
  80
  81   return result
  82  where
  83   isClientMsg (FromClient _ _) = True
  84   isClientMsg _                = False
  85
  86   isServerMsg (FromServer _ _) = True
  87   isServerMsg _                = False
  88
  89 processClient
  90   :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO ()
  91 processClient serverH rspSema reqSema msg = case msg 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     putStrLn "Will send exit notification soon"
 132     threadDelay 10000000
 133     B.hPut serverH $ addHeader (encode msg)
 134   notification msg@(LSP.NotificationMessage _ m _) = do
 135     B.hPut serverH $ addHeader (encode msg)
 136
 137     putStrLn $ "Sent a notification " ++ show m
 138
 139   request msg@(LSP.RequestMessage _ id m _) = do
 140
 141     when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 142
 143     B.hPut serverH $ addHeader (encode msg)
 144     putStrLn
 145       $  "Sent a request id "
 146       ++ show id
 147       ++ ": "
 148       ++ show m
 149       ++ "\nWaiting for a response"
 150
 151     rspId <- takeMVar reqSema
 152     when (LSP.responseId id /= rspId)
 153       $  error
 154       $  "Expected id "
 155       ++ show id
 156       ++ ", got "
 157       ++ show rspId
 158
 159   response msg@(LSP.ResponseMessage _ id _ _) = do
 160     putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 161     reqId <- takeMVar rspSema
 162     if LSP.responseId reqId /= id
 163       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 164       else do
 165         B.hPut serverH $ addHeader (encode msg)
 166         putStrLn $ "Sent response to request id " ++ show id
 167
 168 -- | The internal monad for tests that can fail or pass,
 169 -- ending execution early.
 170 type Session = ReaderT (MVar Bool) IO
 171
 172 -- TODO: Make return type polymoprhic more like error
 173 failSession :: String -> Session ()
 174 failSession reason = do
 175   lift $ putStrLn reason
 176   passVar <- ask
 177   lift $ putMVar passVar False
 178
 179 passSession :: Session ()
 180 passSession = do
 181   passVar <- ask
 182   lift $ putMVar passVar True
 183
 184 -- | Listens to the server output, makes sure it matches the record and
 185 -- signals any semaphores
 186 listenServer
 187   :: [FromServerMessage]
 188   -> Handle
 189   -> RequestMap
 190   -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
 191   -> Session ()
 192 listenServer []           _ _      _                        = passSession
 193 listenServer expectedMsgs h reqMap semas@(reqSema, rspSema) = do
 194   msgBytes <- lift $ getNextMessage h
 195
 196   let actualMsg = decodeFromServerMsg reqMap msgBytes
 197
 198   lift $ print actualMsg
 199
 200   newExpectedMsgs <- case actualMsg of
 201     ReqRegisterCapability       m -> request actualMsg m
 202     ReqApplyWorkspaceEdit       m -> request actualMsg m
 203     ReqShowMessage              m -> request actualMsg m
 204     ReqUnregisterCapability     m -> request actualMsg m
 205     RspInitialize               m -> response actualMsg m
 206     RspShutdown                 m -> response actualMsg m
 207     RspHover                    m -> response actualMsg m
 208     RspCompletion               m -> response actualMsg m
 209     RspCompletionItemResolve    m -> response actualMsg m
 210     RspSignatureHelp            m -> response actualMsg m
 211     RspDefinition               m -> response actualMsg m
 212     RspFindReferences           m -> response actualMsg m
 213     RspDocumentHighlights       m -> response actualMsg m
 214     RspDocumentSymbols          m -> response actualMsg m
 215     RspWorkspaceSymbols         m -> response actualMsg m
 216     RspCodeAction               m -> response actualMsg m
 217     RspCodeLens                 m -> response actualMsg m
 218     RspCodeLensResolve          m -> response actualMsg m
 219     RspDocumentFormatting       m -> response actualMsg m
 220     RspDocumentRangeFormatting  m -> response actualMsg m
 221     RspDocumentOnTypeFormatting m -> response actualMsg m
 222     RspRename                   m -> response actualMsg m
 223     RspExecuteCommand           m -> response actualMsg m
 224     RspError                    m -> response actualMsg m
 225     RspDocumentLink             m -> response actualMsg m
 226     RspDocumentLinkResolve      m -> response actualMsg m
 227     RspWillSaveWaitUntil        m -> response actualMsg m
 228     NotPublishDiagnostics       m -> notification actualMsg m
 229     NotLogMessage               m -> notification actualMsg m
 230     NotShowMessage              m -> notification actualMsg m
 231     NotTelemetry                m -> notification actualMsg m
 232     NotCancelRequestFromServer  m -> notification actualMsg m
 233
 234   listenServer newExpectedMsgs h reqMap semas
 235  where
 236   response
 237     :: Show a
 238     => FromServerMessage
 239     -> LSP.ResponseMessage a
 240     -> Session [FromServerMessage]
 241   response msg res = do
 242     lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
 243
 244     lift $ print res
 245
 246     checkOrder msg
 247
 248     lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
 249
 250     markReceived msg
 251
 252   request
 253     :: (Show a, Show b)
 254     => FromServerMessage
 255     -> LSP.RequestMessage LSP.ServerMethod a b
 256     -> Session [FromServerMessage]
 257   request msg req = do
 258     lift
 259       $  putStrLn
 260       $  "Got request for id "
 261       ++ show (req ^. LSP.id)
 262       ++ " "
 263       ++ show (req ^. LSP.method)
 264
 265     lift $ print req
 266
 267     checkOrder msg
 268
 269     lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 270
 271     markReceived msg
 272
 273   notification
 274     :: Show a
 275     => FromServerMessage
 276     -> LSP.NotificationMessage LSP.ServerMethod a
 277     -> Session [FromServerMessage]
 278   notification msg n = do
 279     lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
 280     lift $ print n
 281
 282     lift
 283       $  putStrLn
 284       $  show (length (filter isNotification expectedMsgs) - 1)
 285       ++ " notifications remaining"
 286
 287     if n ^. LSP.method == LSP.WindowLogMessage
 288       then return expectedMsgs
 289       else markReceived msg
 290
 291   checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
 292     (  "Out of order\nExpected\n"
 293     ++ show firstExpected
 294     ++ "\nGot\n"
 295     ++ show msg
 296     ++ "\n"
 297     )
 298
 299   markReceived :: FromServerMessage -> Session [FromServerMessage]
 300   markReceived msg =
 301     let new = delete msg expectedMsgs
 302     in  if new == expectedMsgs
 303           then failSession ("Unexpected message: " ++ show msg) >> return new
 304           else return new
 305
 306   firstExpected = head $ filter (not . isNotification) expectedMsgs
 307
 308 isNotification :: FromServerMessage -> Bool
 309 isNotification (NotPublishDiagnostics      _) = True
 310 isNotification (NotLogMessage              _) = True
 311 isNotification (NotShowMessage             _) = True
 312 isNotification (NotCancelRequestFromServer _) = True
 313 isNotification _                              = False
 314
 315 -- TODO: QuickCheck tests?
 316 -- | Checks wether or not the message appears in the right order
 317 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 318 -- given N2, notification order doesn't matter.
 319 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 320 -- given REQ1
 321 -- @ N1 N3 N4 N5 REQ2 RES1 @
 322 -- given RES1
 323 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 324 -- Order of requests and responses matter
 325 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 326
 327 inRightOrder _ [] = error "Why is this empty"
 328 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
 329
 330 inRightOrder received (expected : msgs)
 331   | received == expected    = True
 332   | isNotification expected = inRightOrder received msgs
 333   | otherwise               = False