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
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
16 import Language.Haskell.LSP.Capture
17 import Language.Haskell.LSP.Messages
18 import qualified Language.Haskell.LSP.Types as LSP
24 import System.Directory
26 import Language.Haskell.LSP.Test.Files
27 import Language.Haskell.LSP.Test.Parsing
29 -- | Replays a recorded client output and
30 -- makes sure it matches up with an expected response.
32 :: FilePath -- ^ The recorded session file.
33 -> FilePath -- ^ The root directory of the project
35 replay sessionFp curRootDir = do
37 -- need to keep hold of current directory since haskell-lsp changes it
38 prevDir <- getCurrentDirectory
40 (Just serverIn, Just serverOut, _, serverProc) <- createProcess
41 (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe
42 , std_out = CreatePipe
45 hSetBuffering serverIn NoBuffering
46 hSetBuffering serverOut NoBuffering
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)
54 didPass <- newEmptyMVar
56 entries <- B.lines <$> B.readFile sessionFp
59 let unswappedEvents = map (fromJust . decode) entries
61 events <- swapFiles curRootDir unswappedEvents
64 map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
66 map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
67 requestMap = getRequestMap clientEvents
70 forkIO $ runReaderT (listenServer serverEvents serverOut requestMap semas)
73 forM_ clientEvents (processClient serverIn rspSema reqSema)
75 result <- takeMVar didPass
76 terminateProcess serverProc
79 setCurrentDirectory prevDir
83 isClientMsg (FromClient _ _) = True
86 isServerMsg (FromServer _ _) = True
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
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"
133 B.hPut serverH $ addHeader (encode msg)
134 notification msg@(LSP.NotificationMessage _ m _) = do
135 B.hPut serverH $ addHeader (encode msg)
137 putStrLn $ "Sent a notification " ++ show m
139 request msg@(LSP.RequestMessage _ id m _) = do
141 when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
143 B.hPut serverH $ addHeader (encode msg)
145 $ "Sent a request id "
149 ++ "\nWaiting for a response"
151 rspId <- takeMVar reqSema
152 when (LSP.responseId id /= rspId)
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
165 B.hPut serverH $ addHeader (encode msg)
166 putStrLn $ "Sent response to request id " ++ show id
168 -- | The internal monad for tests that can fail or pass,
169 -- ending execution early.
170 type Session = ReaderT (MVar Bool) IO
172 -- TODO: Make return type polymoprhic more like error
173 failSession :: String -> Session ()
174 failSession reason = do
175 lift $ putStrLn reason
177 lift $ putMVar passVar False
179 passSession :: Session ()
182 lift $ putMVar passVar True
184 -- | Listens to the server output, makes sure it matches the record and
185 -- signals any semaphores
187 :: [FromServerMessage]
190 -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
192 listenServer [] _ _ _ = passSession
193 listenServer expectedMsgs h reqMap semas@(reqSema, rspSema) = do
194 msgBytes <- lift $ getNextMessage h
196 let actualMsg = decodeFromServerMsg reqMap msgBytes
198 lift $ print actualMsg
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
234 listenServer newExpectedMsgs h reqMap semas
239 -> LSP.ResponseMessage a
240 -> Session [FromServerMessage]
241 response msg res = do
242 lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
248 lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
255 -> LSP.RequestMessage LSP.ServerMethod a b
256 -> Session [FromServerMessage]
260 $ "Got request for id "
261 ++ show (req ^. LSP.id)
263 ++ show (req ^. LSP.method)
269 lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
276 -> LSP.NotificationMessage LSP.ServerMethod a
277 -> Session [FromServerMessage]
278 notification msg n = do
279 lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
284 $ show (length (filter isNotification expectedMsgs) - 1)
285 ++ " notifications remaining"
287 if n ^. LSP.method == LSP.WindowLogMessage
288 then return expectedMsgs
289 else markReceived msg
291 checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
292 ( "Out of order\nExpected\n"
293 ++ show firstExpected
299 markReceived :: FromServerMessage -> Session [FromServerMessage]
301 let new = delete msg expectedMsgs
302 in if new == expectedMsgs
303 then failSession ("Unexpected message: " ++ show msg) >> return new
306 firstExpected = head $ filter (not . isNotification) expectedMsgs
308 isNotification :: FromServerMessage -> Bool
309 isNotification (NotPublishDiagnostics _) = True
310 isNotification (NotLogMessage _) = True
311 isNotification (NotShowMessage _) = True
312 isNotification (NotCancelRequestFromServer _) = True
313 isNotification _ = False
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 @
321 -- @ N1 N3 N4 N5 REQ2 RES1 @
323 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
324 -- Order of requests and responses matter
325 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
327 inRightOrder _ [] = error "Why is this empty"
328 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
330 inRightOrder received (expected : msgs)
331 | received == expected = True
332 | isNotification expected = inRightOrder received msgs