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
15 import qualified Data.ByteString.Lazy.Char8 as B
17 import Language.Haskell.LSP.Capture
18 import Language.Haskell.LSP.Messages
19 import Language.Haskell.LSP.Core
20 import qualified Language.Haskell.LSP.Types as LSP
26 import System.Directory
28 import Language.Haskell.LSP.Test.Files
29 import Language.Haskell.LSP.Test.Parsing
31 -- | Replays a recorded client output and
32 -- makes sure it matches up with an expected response.
34 :: FilePath -- ^ The recorded session file.
35 -> FilePath -- ^ The root directory of the project
37 replay sessionFp curRootDir = do
39 -- need to keep hold of current directory since haskell-lsp changes it
40 prevDir <- getCurrentDirectory
42 (Just serverIn, Just serverOut, _, serverProc) <- createProcess
43 (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe , 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
63 let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
64 serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
67 forkIO $ runReaderT (listenServer serverEvents serverOut semas) didPass
69 forM_ clientEvents (processClient serverIn)
73 result <- takeMVar didPass
74 terminateProcess serverProc
77 setCurrentDirectory prevDir
81 isClientMsg (FromClient _ _) = True
84 isServerMsg (FromServer _ _) = True
87 processEvent :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> Event -> IO ()
88 processEvent serverH rspSema reqSema (FromClient _ msg) = processClient serverH rspSema reqSema msg
89 processEvent _ _ _ (FromServer _ msg) = processServer msg
92 :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO ()
93 processClient serverH rspSema reqSema msg = case msg of
94 ReqInitialize m -> request m
95 ReqShutdown m -> request m
96 ReqHover m -> request m
97 ReqCompletion m -> request m
98 ReqCompletionItemResolve m -> request m
99 ReqSignatureHelp m -> request m
100 ReqDefinition m -> request m
101 ReqFindReferences m -> request m
102 ReqDocumentHighlights m -> request m
103 ReqDocumentSymbols m -> request m
104 ReqWorkspaceSymbols m -> request m
105 ReqCodeAction m -> request m
106 ReqCodeLens m -> request m
107 ReqCodeLensResolve m -> request m
108 ReqDocumentFormatting m -> request m
109 ReqDocumentRangeFormatting m -> request m
110 ReqDocumentOnTypeFormatting m -> request m
111 ReqRename m -> request m
112 ReqExecuteCommand m -> request m
113 ReqDocumentLink m -> request m
114 ReqDocumentLinkResolve m -> request m
115 ReqWillSaveWaitUntil m -> request m
117 -- TODO: May need to prevent premature exit notification being sent
118 notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
119 putStrLn "Will send exit notification soon"
121 B.hPut serverH $ addHeader (encode msg)
122 notification msg@(LSP.NotificationMessage _ m _) = do
123 B.hPut serverH $ addHeader (encode msg)
125 putStrLn $ "Sent a notification " ++ show m
127 request msg@(LSP.RequestMessage _ id m _) = do
129 when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
131 B.hPut serverH $ addHeader (encode msg)
133 $ "Sent a request id "
137 ++ "\nWaiting for a response"
139 rspId <- takeMVar reqSema
140 when (LSP.responseId id /= rspId)
147 response msg@(LSP.ResponseMessage _ id _ _) = do
148 putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
149 reqId <- takeMVar rspSema
150 if LSP.responseId reqId /= id
151 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
153 B.hPut serverH $ addHeader (encode msg)
154 putStrLn $ "Sent response to request id " ++ show id
156 -- | The internal monad for tests that can fail or pass,
157 -- ending execution early.
158 type Session = ReaderT (MVar Bool) IO
160 -- TODO: Make return type polymoprhic more like error
161 failSession :: String -> Session ()
162 failSession reason = do
163 lift $ putStrLn reason
165 lift $ putMVar passVar False
167 passSession :: Session ()
170 lift $ putMVar passVar True
172 -- | Listens to the server output, makes sure it matches the record and
173 -- signals any semaphores
174 listenServer :: [FromServerMessage] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
175 listenServer [] _ _ = passSession
176 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
177 msg <- lift $ getNextMessage h
179 newExpectedMsgs <- case decode msg of
181 Nothing -> case decode msg of
182 Just m -> notification m
183 Nothing -> case decode msg of
185 Nothing -> failSession "Malformed message" >> return expectedMsgs
187 listenServer newExpectedMsgs h semas
189 where response :: LSP.ResponseMessage a -> Session [FromServerMessage]
191 lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
197 lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
201 request :: LSP.RequestMessage LSP.ServerMethod a b -> Session [FromServerMessage]
203 lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
209 lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
213 notification :: LSP.NotificationMessage LSP.ServerMethod a -> Session [FromServerMessage]
215 lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
218 lift $ putStrLn $ show (length (filter isNotification expectedMsgs) - 1) ++ " notifications remaining"
220 if n ^. LSP.method == LSP.WindowLogMessage
221 then return expectedMsgs
224 checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
225 let (Just expected) = decode firstExpected
226 _ = expected == msg -- make expected type same as res
227 failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
229 markReceived :: Eq a => a -> [FromServerMessage] -> Session [FromServerMessage]
231 -- TODO: Find some way of equating FromServerMessage and LSP.ResponseMessage etc.
232 let new = delete msg expectedMsgs
233 in if new == expectedMsgs
234 then failSession ("Unexpected message: " ++ show msg) >> return new
237 firstExpected = head $ filter (not . isNotification) expectedMsgs
239 isNotification :: FromServerMessage -> Bool
240 isNotification (NotPublishDiagnostics _) = True
241 isNotification (NotLogMessage _) = True
242 isNotification (NotShowMessage _) = True
243 isNotification (NotCancelRequestFromServer _) = True
244 isNotification _ = False
246 -- TODO: QuickCheck tests?
247 -- | Checks wether or not the message appears in the right order
248 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
249 -- given N2, notification order doesn't matter.
250 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
252 -- @ N1 N3 N4 N5 REQ2 RES1 @
254 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
255 -- Order of requests and responses matter
256 inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
258 inRightOrder _ [] = error "Why is this empty"
259 -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
261 inRightOrder received (expected:msgs)
262 | Just received == decode expected = True
263 | isNotification expected = inRightOrder received msgs