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

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 -- | A testing tool for replaying captured client logs back to a server,
   5 -- and validating that the server output matches up with another log.
   6 module Language.Haskell.LSP.Test.Replay
   7   ( replaySession
   8   )
   9 where
  10
  11 import           Prelude hiding (id)
  12 import           Control.Concurrent
  13 import           Control.Monad.IO.Class
  14 import qualified Data.ByteString.Lazy.Char8    as B
  15 import           Language.Haskell.LSP.Capture
  16 import           Language.Haskell.LSP.Messages
  17 import           Language.Haskell.LSP.Types hiding (error)
  18 import           Data.Aeson
  19 import           Data.List
  20 import           Data.Maybe
  21 import           Control.Lens
  22 import           Control.Monad
  23 import           System.IO
  24 import           System.FilePath
  25 import           Language.Haskell.LSP.Test
  26 import           Language.Haskell.LSP.Test.Files
  27 import           Language.Haskell.LSP.Test.Parsing
  28
  29
  30 -- | Replays a captured client output and
  31 -- makes sure it matches up with an expected response.
  32 -- The session directory should have a captured session file in it
  33 -- named "session.log".
  34 replaySession :: FilePath -- ^ The recorded session directory.
  35               -> IO Bool
  36 replaySession sessionDir = do
  37
  38   entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
  39
  40   -- decode session
  41   let unswappedEvents = map (fromJust . decode) entries
  42
  43   events <- swapFiles sessionDir unswappedEvents
  44
  45   let clientEvents = filter isClientMsg events
  46       serverEvents = filter isServerMsg events
  47       clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
  48       serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
  49       requestMap = getRequestMap clientMsgs
  50
  51
  52   reqSema <- newEmptyMVar
  53   rspSema <- newEmptyMVar
  54   passVar <- newEmptyMVar :: IO (MVar Bool)
  55
  56   forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $
  57     sendMessages clientMsgs reqSema rspSema
  58
  59   takeMVar passVar
  60
  61   where
  62     isClientMsg (FromClient _ _) = True
  63     isClientMsg _                = False
  64
  65     isServerMsg (FromServer _ _) = True
  66     isServerMsg _                = False
  67
  68 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
  69 sendMessages [] _ _ = return ()
  70 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
  71   case nextMsg of
  72     ReqInitialize               m -> request m
  73     ReqShutdown                 m -> request m
  74     ReqHover                    m -> request m
  75     ReqCompletion               m -> request m
  76     ReqCompletionItemResolve    m -> request m
  77     ReqSignatureHelp            m -> request m
  78     ReqDefinition               m -> request m
  79     ReqFindReferences           m -> request m
  80     ReqDocumentHighlights       m -> request m
  81     ReqDocumentSymbols          m -> request m
  82     ReqWorkspaceSymbols         m -> request m
  83     ReqCodeAction               m -> request m
  84     ReqCodeLens                 m -> request m
  85     ReqCodeLensResolve          m -> request m
  86     ReqDocumentFormatting       m -> request m
  87     ReqDocumentRangeFormatting  m -> request m
  88     ReqDocumentOnTypeFormatting m -> request m
  89     ReqRename                   m -> request m
  90     ReqExecuteCommand           m -> request m
  91     ReqDocumentLink             m -> request m
  92     ReqDocumentLinkResolve      m -> request m
  93     ReqWillSaveWaitUntil        m -> request m
  94     RspApplyWorkspaceEdit       m -> response m
  95     RspFromClient               m -> response m
  96     NotInitialized              m -> notification m
  97     NotExit                     m -> notification m
  98     NotCancelRequestFromClient  m -> notification m
  99     NotDidChangeConfiguration   m -> notification m
 100     NotDidOpenTextDocument      m -> notification m
 101     NotDidChangeTextDocument    m -> notification m
 102     NotDidCloseTextDocument     m -> notification m
 103     NotWillSaveTextDocument     m -> notification m
 104     NotDidSaveTextDocument      m -> notification m
 105     NotDidChangeWatchedFiles    m -> notification m
 106     UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m
 107  where
 108   -- TODO: May need to prevent premature exit notification being sent
 109   notification msg@(NotificationMessage _ Exit _) = do
 110     liftIO $ putStrLn "Will send exit notification soon"
 111     liftIO $ threadDelay 10000000
 112     sendNotification' msg
 113
 114     liftIO $ error "Done"
 115
 116   notification msg@(NotificationMessage _ m _) = do
 117     sendNotification' msg
 118
 119     liftIO $ putStrLn $ "Sent a notification " ++ show m
 120
 121     sendMessages remainingMsgs reqSema rspSema
 122
 123   request msg@(RequestMessage _ id m _) = do
 124     sendRequest' msg
 125     liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
 126
 127     rsp <- liftIO $ takeMVar rspSema
 128     when (responseId id /= rsp) $
 129       error $ "Expected id " ++ show id ++ ", got " ++ show rsp
 130
 131     sendMessages remainingMsgs reqSema rspSema
 132
 133   response msg@(ResponseMessage _ id _ _) = do
 134     liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
 135     reqId <- liftIO $ takeMVar reqSema
 136     if responseId reqId /= id
 137       then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
 138       else do
 139         sendResponse' msg
 140         liftIO $ putStrLn $ "Sent response to request id " ++ show id
 141
 142     sendMessages remainingMsgs reqSema rspSema
 143
 144
 145 isNotification :: FromServerMessage -> Bool
 146 isNotification (NotPublishDiagnostics      _) = True
 147 isNotification (NotLogMessage              _) = True
 148 isNotification (NotShowMessage             _) = True
 149 isNotification (NotCancelRequestFromServer _) = True
 150 isNotification _                              = False
 151
 152 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
 153 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
 154 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut  = do
 155   msgBytes <- liftIO $ getNextMessage serverOut
 156   let msg = decodeFromServerMsg reqMap msgBytes
 157
 158   case msg of
 159     ReqRegisterCapability       m -> request m
 160     ReqApplyWorkspaceEdit       m -> request m
 161     ReqShowMessage              m -> request m
 162     ReqUnregisterCapability     m -> request m
 163     RspInitialize               m -> response m
 164     RspShutdown                 m -> response m
 165     RspHover                    m -> response m
 166     RspCompletion               m -> response m
 167     RspCompletionItemResolve    m -> response m
 168     RspSignatureHelp            m -> response m
 169     RspDefinition               m -> response m
 170     RspFindReferences           m -> response m
 171     RspDocumentHighlights       m -> response m
 172     RspDocumentSymbols          m -> response m
 173     RspWorkspaceSymbols         m -> response m
 174     RspCodeAction               m -> response m
 175     RspCodeLens                 m -> response m
 176     RspCodeLensResolve          m -> response m
 177     RspDocumentFormatting       m -> response m
 178     RspDocumentRangeFormatting  m -> response m
 179     RspDocumentOnTypeFormatting m -> response m
 180     RspRename                   m -> response m
 181     RspExecuteCommand           m -> response m
 182     RspError                    m -> response m
 183     RspDocumentLink             m -> response m
 184     RspDocumentLinkResolve      m -> response m
 185     RspWillSaveWaitUntil        m -> response m
 186     NotPublishDiagnostics       m -> notification m
 187     NotLogMessage               m -> notification m
 188     NotShowMessage              m -> notification m
 189     NotTelemetry                m -> notification m
 190     NotCancelRequestFromServer  m -> notification m
 191
 192   if shouldSkip msg
 193     then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
 194     else if inRightOrder msg expectedMsgs
 195       then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
 196       else liftIO $ do
 197         putStrLn "Out of order"
 198         putStrLn "Got:"
 199         print msg
 200         putStrLn "Expected one of:"
 201         mapM_ print $ takeWhile (not . isNotification) expectedMsgs
 202         print $ head $ dropWhile (not . isNotification) expectedMsgs
 203         putMVar passVar False
 204
 205   where
 206   response :: Show a => ResponseMessage a -> Session ()
 207   response res = do
 208     liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
 209
 210     liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
 211
 212   request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session ()
 213   request req = do
 214     liftIO
 215       $  putStrLn
 216       $  "Got request for id "
 217       ++ show (req ^. id)
 218       ++ " "
 219       ++ show (req ^. method)
 220
 221     liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
 222
 223   notification :: Show a => NotificationMessage ServerMethod a -> Session ()
 224   notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
 225
 226
 227
 228 -- TODO: QuickCheck tests?
 229 -- | Checks wether or not the message appears in the right order
 230 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
 231 -- given N2, notification order doesn't matter.
 232 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
 233 -- given REQ1
 234 -- @ N1 N3 N4 N5 REQ2 RES1 @
 235 -- given RES1
 236 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
 237 -- Order of requests and responses matter
 238 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
 239
 240 inRightOrder _ [] = error "Why is this empty"
 241
 242 inRightOrder received (expected : msgs)
 243   | received == expected    = True
 244   | isNotification expected = inRightOrder received msgs
 245   | otherwise               = False
 246
 247 -- | Ignore logging notifications since they vary from session to session
 248 shouldSkip :: FromServerMessage -> Bool
 249 shouldSkip (NotLogMessage  _) = True
 250 shouldSkip (NotShowMessage _) = True
 251 shouldSkip (ReqShowMessage _) = True
 252 shouldSkip _                  = False