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 :: 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 =
69 handleClientMessage request response notification nextMsg
71 -- TODO: May need to prevent premature exit notification being sent
72 notification msg@(NotificationMessage _ Exit _) = do
73 liftIO $ putStrLn "Will send exit notification soon"
74 liftIO $ threadDelay 10000000
79 notification msg@(NotificationMessage _ m _) = do
82 liftIO $ putStrLn $ "Sent a notification " ++ show m
84 sendMessages remainingMsgs reqSema rspSema
86 request msg@(RequestMessage _ id m _) = do
88 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
90 rsp <- liftIO $ takeMVar rspSema
91 when (responseId id /= rsp) $
92 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
94 sendMessages remainingMsgs reqSema rspSema
96 response msg@(ResponseMessage _ id _ _) = do
97 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
98 reqId <- liftIO $ takeMVar reqSema
99 if responseId reqId /= id
100 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
103 liftIO $ putStrLn $ "Sent response to request id " ++ show id
105 sendMessages remainingMsgs reqSema rspSema
108 isNotification :: FromServerMessage -> Bool
109 isNotification (NotPublishDiagnostics _) = True
110 isNotification (NotLogMessage _) = True
111 isNotification (NotShowMessage _) = True
112 isNotification (NotCancelRequestFromServer _) = True
113 isNotification _ = False
115 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
116 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
117 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
118 msgBytes <- liftIO $ getNextMessage serverOut
119 let msg = decodeFromServerMsg reqMap msgBytes
121 handleServerMessage request response notification msg
124 then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
125 else if inRightOrder msg expectedMsgs
126 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
128 putStrLn "Out of order"
131 putStrLn "Expected one of:"
132 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
133 print $ head $ dropWhile (not . isNotification) expectedMsgs
134 putMVar passVar False
137 response :: ResponseMessage a -> Session ()
139 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
141 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
143 request :: RequestMessage ServerMethod a b -> Session ()
147 $ "Got request for id "
150 ++ show (req ^. method)
152 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
154 notification :: NotificationMessage ServerMethod a -> Session ()
155 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
159 -- TODO: QuickCheck tests?
160 -- | Checks wether or not the message appears in the right order
161 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
162 -- given N2, notification order doesn't matter.
163 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
165 -- @ N1 N3 N4 N5 REQ2 RES1 @
167 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
168 -- Order of requests and responses matter
169 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
171 inRightOrder _ [] = error "Why is this empty"
173 inRightOrder received (expected : msgs)
174 | received == expected = True
175 | isNotification expected = inRightOrder received msgs
178 -- | Ignore logging notifications since they vary from session to session
179 shouldSkip :: FromServerMessage -> Bool
180 shouldSkip (NotLogMessage _) = True
181 shouldSkip (NotShowMessage _) = True
182 shouldSkip (ReqShowMessage _) = True