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
49 reqSema <- newEmptyMVar
50 rspSema <- newEmptyMVar
51 passVar <- newEmptyMVar :: IO (MVar Bool)
53 forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $
54 sendMessages clientMsgs reqSema rspSema
59 isClientMsg (FromClient _ _) = True
62 isServerMsg (FromServer _ _) = True
65 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
66 sendMessages [] _ _ = return ()
67 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
68 handleClientMessage request response notification nextMsg
70 -- TODO: May need to prevent premature exit notification being sent
71 notification msg@(NotificationMessage _ Exit _) = do
72 liftIO $ putStrLn "Will send exit notification soon"
73 liftIO $ threadDelay 10000000
78 notification msg@(NotificationMessage _ m _) = do
81 liftIO $ putStrLn $ "Sent a notification " ++ show m
83 sendMessages remainingMsgs reqSema rspSema
85 request msg@(RequestMessage _ id m _) = do
87 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
89 rsp <- liftIO $ takeMVar rspSema
90 when (responseId id /= rsp) $
91 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
93 sendMessages remainingMsgs reqSema rspSema
95 response msg@(ResponseMessage _ id _ _) = do
96 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
97 reqId <- liftIO $ takeMVar reqSema
98 if responseId reqId /= id
99 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
102 liftIO $ putStrLn $ "Sent response to request id " ++ show id
104 sendMessages remainingMsgs reqSema rspSema
107 isNotification :: FromServerMessage -> Bool
108 isNotification (NotPublishDiagnostics _) = True
109 isNotification (NotLogMessage _) = True
110 isNotification (NotShowMessage _) = True
111 isNotification (NotCancelRequestFromServer _) = True
112 isNotification _ = False
114 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
115 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
116 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
117 msgBytes <- liftIO $ getNextMessage serverOut
118 let msg = decodeFromServerMsg reqMap msgBytes
120 handleServerMessage request response notification msg
123 then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
124 else if inRightOrder msg expectedMsgs
125 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
127 putStrLn "Out of order"
130 putStrLn "Expected one of:"
131 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
132 print $ head $ dropWhile isNotification expectedMsgs
133 putMVar passVar False
136 response :: ResponseMessage a -> Session ()
138 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
140 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
142 request :: RequestMessage ServerMethod a b -> Session ()
146 $ "Got request for id "
149 ++ show (req ^. method)
151 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
153 notification :: NotificationMessage ServerMethod a -> Session ()
154 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
158 -- TODO: QuickCheck tests?
159 -- | Checks wether or not the message appears in the right order
160 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
161 -- given N2, notification order doesn't matter.
162 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
164 -- @ N1 N3 N4 N5 REQ2 RES1 @
166 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
167 -- Order of requests and responses matter
168 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
170 inRightOrder _ [] = error "Why is this empty"
172 inRightOrder received (expected : msgs)
173 | received == expected = True
174 | isNotification expected = inRightOrder received msgs
177 -- | Ignore logging notifications since they vary from session to session
178 shouldSkip :: FromServerMessage -> Bool
179 shouldSkip (NotLogMessage _) = True
180 shouldSkip (NotShowMessage _) = True
181 shouldSkip (ReqShowMessage _) = True