1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 -- | A testing tool for replaying recorded client logs back to a server,
4 -- and validating that the server output matches up with another log.
5 module Language.Haskell.LSP.Test.Recorded
10 import Control.Concurrent
11 import Control.Monad.Trans.Class
12 import Control.Monad.Trans.Reader
14 import Language.Haskell.LSP.Control as Control
15 import qualified Data.ByteString.Lazy.Char8 as B
16 import Language.Haskell.LSP.Core
17 import qualified Language.Haskell.LSP.Types as LSP
23 import System.Directory
25 import Language.Haskell.LSP.Test.Files
26 import Language.Haskell.LSP.Test.Parsing
28 -- | Replays a recorded client output and
29 -- makes sure it matches up with an expected response.
31 :: FilePath -- ^ The client output to replay to the server.
32 -> FilePath -- ^ The expected response from the server.
33 -> FilePath -- ^ The root directory of the project
35 replay cfp sfp 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 , std_out = CreatePipe }
43 hSetBuffering serverIn NoBuffering
44 hSetBuffering serverOut NoBuffering
46 -- whether to send the next request
47 reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
48 -- whether to send the next response
49 rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
50 let semas = (reqSema, rspSema)
52 didPass <- newEmptyMVar
54 -- the recorded client input to the server
55 clientRecIn <- openFile cfp ReadMode
56 serverRecIn <- openFile sfp ReadMode
57 null <- openFile "/dev/null" WriteMode
60 unswappedClientMsgs <- getAllMessages clientRecIn
62 let recRootDir = rootDir unswappedClientMsgs
64 (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs
66 tmpDir <- getTemporaryDirectory
67 (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
68 mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
69 hSeek mappedClientRecIn AbsoluteSeek 0
71 (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn
74 forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
76 -- start client replay
78 Control.runWithHandles mappedClientRecIn
80 (const $ Right (), const $ return Nothing)
81 (handlers serverIn semas)
86 -- todo: we shouldn't do this, we should check all notifications were delivered first
89 result <- takeMVar didPass
90 terminateProcess serverProc
93 setCurrentDirectory prevDir
96 removeFile mappedClientRecFp
101 -- | The internal monad for tests that can fail or pass,
102 -- ending execution early.
103 type Session = ReaderT (MVar Bool) IO
105 failSession :: String -> Session ()
106 failSession reason = do
107 lift $ putStrLn reason
109 lift $ putMVar passVar False
111 passSession :: Session ()
114 lift $ putMVar passVar True
116 -- | Listens to the server output, makes sure it matches the record and
117 -- signals any semaphores
118 listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
119 listenServer [] _ _ = passSession
120 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
121 msg <- lift $ getNextMessage h
123 newExpectedMsgs <- case decode msg of
125 Nothing -> case decode msg of
126 Just m -> notification m
127 Nothing -> case decode msg of
129 Nothing -> failSession "Malformed message" >> return expectedMsgs
131 listenServer newExpectedMsgs h semas
134 where response :: LSP.ResponseMessage Value -> Session [B.ByteString]
136 lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
142 lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
146 request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString]
148 lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
154 lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
158 notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString]
160 lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
163 lift $ putStrLn $ (show ((length $ filter isNotification expectedMsgs) - 1)) ++ " notifications remaining"
165 if n ^. LSP.method == LSP.WindowLogMessage
166 then return expectedMsgs
169 checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
170 let (Just expected) = decode firstExpected
171 _ = expected == msg -- make expected type same as res
172 failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
174 markReceived msg = do
175 let new = deleteFirstJson msg expectedMsgs
176 in if (new == expectedMsgs)
177 then failSession ("Unexpected message: " ++ show msg) >> return new
180 deleteFirstJson _ [] = []
181 deleteFirstJson msg (x:xs)
182 | (Just msg) == (decode x) = xs
183 | otherwise = x:deleteFirstJson msg xs
185 firstExpected = head $ filter (not . isNotification) expectedMsgs
189 isNotification :: B.ByteString -> Bool
191 isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
193 -- TODO: QuickCheck tests?
194 -- | Checks wether or not the message appears in the right order
195 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
196 -- given N2, notification order doesn't matter.
197 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
199 -- @ N1 N3 N4 N5 REQ2 RES1 @
201 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
202 -- Order of requests and responses matter
203 inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
205 inRightOrder _ [] = error "Why is this empty"
206 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
208 inRightOrder received (expected:msgs)
209 | Just received == decode expected = True
210 | isNotification expected = inRightOrder received msgs
214 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
215 handlers serverH (reqSema, rspSema) = def
218 hoverHandler = Just request
219 , completionHandler = Just request
220 , completionResolveHandler = Just request
221 , signatureHelpHandler = Just request
222 , definitionHandler = Just request
223 , referencesHandler = Just request
224 , documentHighlightHandler = Just request
225 , documentSymbolHandler = Just request
226 , workspaceSymbolHandler = Just request
227 , codeActionHandler = Just request
228 , codeLensHandler = Just request
229 , codeLensResolveHandler = Just request
230 , documentFormattingHandler = Just request
231 , documentRangeFormattingHandler = Just request
232 , documentTypeFormattingHandler = Just request
233 , renameHandler = Just request
234 , documentLinkHandler = Just request
235 , documentLinkResolveHandler = Just request
236 , executeCommandHandler = Just request
237 , initializeRequestHandler = Just request
239 , didChangeConfigurationParamsHandler = Just notification
240 , didOpenTextDocumentNotificationHandler = Just notification
241 , didChangeTextDocumentNotificationHandler = Just notification
242 , didCloseTextDocumentNotificationHandler = Just notification
243 , didSaveTextDocumentNotificationHandler = Just notification
244 , didChangeWatchedFilesNotificationHandler = Just notification
245 , initializedHandler = Just notification
246 , willSaveTextDocumentNotificationHandler = Just notification
247 , cancelNotificationHandler = Just notification
248 , exitNotificationHandler = Just notification
250 , responseHandler = Just response
254 -- TODO: May need to prevent premature exit notification being sent
255 notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
256 putStrLn "Will send exit notification soon"
258 B.hPut serverH $ addHeader (encode msg)
259 notification msg@(LSP.NotificationMessage _ m _) = do
260 B.hPut serverH $ addHeader (encode msg)
262 putStrLn $ "Sent a notification " ++ show m
264 request msg@(LSP.RequestMessage _ id m _) = do
266 when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
268 B.hPut serverH $ addHeader (encode msg)
269 putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
271 rspId <- takeMVar reqSema
272 when (LSP.responseId id /= rspId)
279 response msg@(LSP.ResponseMessage _ id _ _) = do
280 putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
281 reqId <- takeMVar rspSema
282 if LSP.responseId reqId /= id
283 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
285 B.hPut serverH $ addHeader (encode msg)
286 putStrLn $ "Sent response to request id " ++ show id