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
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)
24 import System.FilePath
25 import Language.Haskell.LSP.Test
26 import Language.Haskell.LSP.Test.Files
27 import Language.Haskell.LSP.Test.Parsing
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.
36 replaySession sessionDir = do
38 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
41 let unswappedEvents = map (fromJust . decode) entries
43 events <- swapFiles sessionDir unswappedEvents
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
52 reqSema <- newEmptyMVar
53 rspSema <- newEmptyMVar
54 passVar <- newEmptyMVar :: IO (MVar Bool)
56 forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $
57 sendMessages clientMsgs reqSema rspSema
62 isClientMsg (FromClient _ _) = True
65 isServerMsg (FromServer _ _) = True
68 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
69 sendMessages [] _ _ = return ()
70 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
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
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
114 liftIO $ error "Done"
116 notification msg@(NotificationMessage _ m _) = do
117 sendNotification' msg
119 liftIO $ putStrLn $ "Sent a notification " ++ show m
121 sendMessages remainingMsgs reqSema rspSema
123 request msg@(RequestMessage _ id m _) = do
125 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
127 rsp <- liftIO $ takeMVar rspSema
128 when (responseId id /= rsp) $
129 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
131 sendMessages remainingMsgs reqSema rspSema
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
140 liftIO $ putStrLn $ "Sent response to request id " ++ show id
142 sendMessages remainingMsgs reqSema rspSema
145 isNotification :: FromServerMessage -> Bool
146 isNotification (NotPublishDiagnostics _) = True
147 isNotification (NotLogMessage _) = True
148 isNotification (NotShowMessage _) = True
149 isNotification (NotCancelRequestFromServer _) = True
150 isNotification _ = False
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
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
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
197 putStrLn "Out of order"
200 putStrLn "Expected one of:"
201 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
202 print $ head $ dropWhile (not . isNotification) expectedMsgs
203 putMVar passVar False
206 response :: Show a => ResponseMessage a -> Session ()
208 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
210 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
212 request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session ()
216 $ "Got request for id "
219 ++ show (req ^. method)
221 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
223 notification :: Show a => NotificationMessage ServerMethod a -> Session ()
224 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
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 @
234 -- @ N1 N3 N4 N5 REQ2 RES1 @
236 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
237 -- Order of requests and responses matter
238 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
240 inRightOrder _ [] = error "Why is this empty"
242 inRightOrder received (expected : msgs)
243 | received == expected = True
244 | isNotification expected = inRightOrder received msgs
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