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 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 recorded client output and
31 -- makes sure it matches up with an expected response.
32 replaySession :: FilePath -- ^ The recorded session directory.
34 replaySession sessionDir = do
36 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
39 let unswappedEvents = map (fromJust . decode) entries
41 events <- swapFiles sessionDir unswappedEvents
43 let clientEvents = filter isClientMsg events
44 serverEvents = filter isServerMsg events
45 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
46 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
47 requestMap = getRequestMap clientMsgs
50 reqSema <- newEmptyMVar
51 rspSema <- newEmptyMVar
52 passVar <- newEmptyMVar :: IO (MVar Bool)
54 forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $
55 sendMessages clientMsgs reqSema rspSema
60 isClientMsg (FromClient _ _) = True
63 isServerMsg (FromServer _ _) = True
66 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
67 sendMessages [] _ _ = return ()
68 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
70 ReqInitialize m -> request m
71 ReqShutdown m -> request m
72 ReqHover m -> request m
73 ReqCompletion m -> request m
74 ReqCompletionItemResolve m -> request m
75 ReqSignatureHelp m -> request m
76 ReqDefinition m -> request m
77 ReqFindReferences m -> request m
78 ReqDocumentHighlights m -> request m
79 ReqDocumentSymbols m -> request m
80 ReqWorkspaceSymbols m -> request m
81 ReqCodeAction m -> request m
82 ReqCodeLens m -> request m
83 ReqCodeLensResolve m -> request m
84 ReqDocumentFormatting m -> request m
85 ReqDocumentRangeFormatting m -> request m
86 ReqDocumentOnTypeFormatting m -> request m
87 ReqRename m -> request m
88 ReqExecuteCommand m -> request m
89 ReqDocumentLink m -> request m
90 ReqDocumentLinkResolve m -> request m
91 ReqWillSaveWaitUntil m -> request m
92 RspApplyWorkspaceEdit m -> response m
93 RspFromClient m -> response m
94 NotInitialized m -> notification m
95 NotExit m -> notification m
96 NotCancelRequestFromClient m -> notification m
97 NotDidChangeConfiguration m -> notification m
98 NotDidOpenTextDocument m -> notification m
99 NotDidChangeTextDocument m -> notification m
100 NotDidCloseTextDocument m -> notification m
101 NotWillSaveTextDocument m -> notification m
102 NotDidSaveTextDocument m -> notification m
103 NotDidChangeWatchedFiles m -> notification m
104 UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m
106 -- TODO: May need to prevent premature exit notification being sent
107 notification msg@(NotificationMessage _ Exit _) = do
108 liftIO $ putStrLn "Will send exit notification soon"
109 liftIO $ threadDelay 10000000
110 sendNotification' msg
112 liftIO $ error "Done"
114 notification msg@(NotificationMessage _ m _) = do
115 sendNotification' msg
117 liftIO $ putStrLn $ "Sent a notification " ++ show m
119 sendMessages remainingMsgs reqSema rspSema
121 request msg@(RequestMessage _ id m _) = do
123 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
125 rsp <- liftIO $ takeMVar rspSema
126 when (responseId id /= rsp) $
127 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
129 sendMessages remainingMsgs reqSema rspSema
131 response msg@(ResponseMessage _ id _ _) = do
132 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
133 reqId <- liftIO $ takeMVar reqSema
134 if responseId reqId /= id
135 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
138 liftIO $ putStrLn $ "Sent response to request id " ++ show id
140 sendMessages remainingMsgs reqSema rspSema
143 isNotification :: FromServerMessage -> Bool
144 isNotification (NotPublishDiagnostics _) = True
145 isNotification (NotLogMessage _) = True
146 isNotification (NotShowMessage _) = True
147 isNotification (NotCancelRequestFromServer _) = True
148 isNotification _ = False
150 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
151 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
152 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
153 msgBytes <- liftIO $ getNextMessage serverOut
154 let msg = decodeFromServerMsg reqMap msgBytes
157 ReqRegisterCapability m -> request m
158 ReqApplyWorkspaceEdit m -> request m
159 ReqShowMessage m -> request m
160 ReqUnregisterCapability m -> request m
161 RspInitialize m -> response m
162 RspShutdown m -> response m
163 RspHover m -> response m
164 RspCompletion m -> response m
165 RspCompletionItemResolve m -> response m
166 RspSignatureHelp m -> response m
167 RspDefinition m -> response m
168 RspFindReferences m -> response m
169 RspDocumentHighlights m -> response m
170 RspDocumentSymbols m -> response m
171 RspWorkspaceSymbols m -> response m
172 RspCodeAction m -> response m
173 RspCodeLens m -> response m
174 RspCodeLensResolve m -> response m
175 RspDocumentFormatting m -> response m
176 RspDocumentRangeFormatting m -> response m
177 RspDocumentOnTypeFormatting m -> response m
178 RspRename m -> response m
179 RspExecuteCommand m -> response m
180 RspError m -> response m
181 RspDocumentLink m -> response m
182 RspDocumentLinkResolve m -> response m
183 RspWillSaveWaitUntil m -> response m
184 NotPublishDiagnostics m -> notification m
185 NotLogMessage m -> notification m
186 NotShowMessage m -> notification m
187 NotTelemetry m -> notification m
188 NotCancelRequestFromServer m -> notification m
191 then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
192 else if inRightOrder msg expectedMsgs
193 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
195 putStrLn "Out of order"
198 putStrLn "Expected one of:"
199 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
200 print $ head $ dropWhile (not . isNotification) expectedMsgs
201 putMVar passVar False
204 response :: Show a => ResponseMessage a -> Session ()
206 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
208 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
210 request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session ()
214 $ "Got request for id "
217 ++ show (req ^. method)
219 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
221 notification :: Show a => NotificationMessage ServerMethod a -> Session ()
222 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
226 -- TODO: QuickCheck tests?
227 -- | Checks wether or not the message appears in the right order
228 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
229 -- given N2, notification order doesn't matter.
230 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
232 -- @ N1 N3 N4 N5 REQ2 RES1 @
234 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
235 -- Order of requests and responses matter
236 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
238 inRightOrder _ [] = error "Why is this empty"
240 inRightOrder received (expected : msgs)
241 | received == expected = True
242 | isNotification expected = inRightOrder received msgs
245 -- | Ignore logging notifications since they vary from session to session
246 shouldSkip :: FromServerMessage -> Bool
247 shouldSkip (NotLogMessage _) = True
248 shouldSkip (NotShowMessage _) = True
249 shouldSkip (ReqShowMessage _) = True