1 -- | A testing tool for replaying captured client logs back to a server,
2 -- and validating that the server output matches up with another log.
3 module Language.Haskell.LSP.Test.Replay
8 import Prelude hiding (id)
9 import Control.Concurrent
10 import Control.Monad.IO.Class
11 import qualified Data.ByteString.Lazy.Char8 as B
12 import Language.Haskell.LSP.Capture
13 import Language.Haskell.LSP.Messages
14 import Language.Haskell.LSP.Types hiding (error)
21 import System.FilePath
22 import Language.Haskell.LSP.Test
23 import Language.Haskell.LSP.Test.Files
24 import Language.Haskell.LSP.Test.Decoding
25 import Language.Haskell.LSP.Test.Messages
28 -- | Replays a captured client output and
29 -- makes sure it matches up with an expected response.
30 -- The session directory should have a captured session file in it
31 -- named "session.log".
32 replaySession :: String -- ^ The command to run the server.
33 -> FilePath -- ^ The recorded session directory.
35 replaySession serverExe sessionDir = do
37 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
40 let unswappedEvents = map (fromJust . decode) entries
42 events <- swapFiles sessionDir unswappedEvents
44 let clientEvents = filter isClientMsg events
45 serverEvents = filter isServerMsg events
46 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
47 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
48 requestMap = getRequestMap clientMsgs
50 reqSema <- newEmptyMVar
51 rspSema <- newEmptyMVar
52 passVar <- newEmptyMVar :: IO (MVar Bool)
55 runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar)
58 (sendMessages clientMsgs reqSema rspSema)
60 result <- takeMVar passVar
65 isClientMsg (FromClient _ _) = True
68 isServerMsg (FromServer _ _) = True
71 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
72 sendMessages [] _ _ = return ()
73 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
74 handleClientMessage request response notification nextMsg
76 -- TODO: May need to prevent premature exit notification being sent
77 notification msg@(NotificationMessage _ Exit _) = do
78 liftIO $ putStrLn "Will send exit notification soon"
79 liftIO $ threadDelay 10000000
84 notification msg@(NotificationMessage _ m _) = do
87 liftIO $ putStrLn $ "Sent a notification " ++ show m
89 sendMessages remainingMsgs reqSema rspSema
91 request msg@(RequestMessage _ id m _) = do
93 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
95 rsp <- liftIO $ takeMVar rspSema
96 when (responseId id /= rsp) $
97 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
99 sendMessages remainingMsgs reqSema rspSema
101 response msg@(ResponseMessage _ id _ _) = do
102 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
103 reqId <- liftIO $ takeMVar reqSema
104 if responseId reqId /= id
105 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
108 liftIO $ putStrLn $ "Sent response to request id " ++ show id
110 sendMessages remainingMsgs reqSema rspSema
113 isNotification :: FromServerMessage -> Bool
114 isNotification (NotPublishDiagnostics _) = True
115 isNotification (NotLogMessage _) = True
116 isNotification (NotShowMessage _) = True
117 isNotification (NotCancelRequestFromServer _) = True
118 isNotification _ = False
120 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
121 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
122 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
123 msgBytes <- liftIO $ getNextMessage serverOut
124 let msg = decodeFromServerMsg reqMap msgBytes
126 handleServerMessage request response notification msg
129 then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
130 else if inRightOrder msg expectedMsgs
131 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
133 putStrLn "Out of order"
136 putStrLn "Expected one of:"
137 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
138 print $ head $ dropWhile isNotification expectedMsgs
139 putMVar passVar False
142 response :: ResponseMessage a -> Session ()
144 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
146 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
148 request :: RequestMessage ServerMethod a b -> Session ()
152 $ "Got request for id "
155 ++ show (req ^. method)
157 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
159 notification :: NotificationMessage ServerMethod a -> Session ()
160 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
164 -- TODO: QuickCheck tests?
165 -- | Checks wether or not the message appears in the right order
166 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
167 -- given N2, notification order doesn't matter.
168 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
170 -- @ N1 N3 N4 N5 REQ2 RES1 @
172 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
173 -- Order of requests and responses matter
174 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
176 inRightOrder _ [] = error "Why is this empty"
178 inRightOrder received (expected : msgs)
179 | received == expected = True
180 | isNotification expected = inRightOrder received msgs
183 -- | Ignore logging notifications since they vary from session to session
184 shouldSkip :: FromServerMessage -> Bool
185 shouldSkip (NotLogMessage _) = True
186 shouldSkip (NotShowMessage _) = True
187 shouldSkip (ReqShowMessage _) = True