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)
54 runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar)
56 (sendMessages clientMsgs reqSema rspSema)
58 result <- takeMVar passVar
63 isClientMsg (FromClient _ _) = True
66 isServerMsg (FromServer _ _) = True
69 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
70 sendMessages [] _ _ = return ()
71 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
72 handleClientMessage request response notification nextMsg
74 -- TODO: May need to prevent premature exit notification being sent
75 notification msg@(NotificationMessage _ Exit _) = do
76 liftIO $ putStrLn "Will send exit notification soon"
77 liftIO $ threadDelay 10000000
82 notification msg@(NotificationMessage _ m _) = do
85 liftIO $ putStrLn $ "Sent a notification " ++ show m
87 sendMessages remainingMsgs reqSema rspSema
89 request msg@(RequestMessage _ id m _) = do
91 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
93 rsp <- liftIO $ takeMVar rspSema
94 when (responseId id /= rsp) $
95 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
97 sendMessages remainingMsgs reqSema rspSema
99 response msg@(ResponseMessage _ id _ _) = do
100 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
101 reqId <- liftIO $ takeMVar reqSema
102 if responseId reqId /= id
103 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
106 liftIO $ putStrLn $ "Sent response to request id " ++ show id
108 sendMessages remainingMsgs reqSema rspSema
111 isNotification :: FromServerMessage -> Bool
112 isNotification (NotPublishDiagnostics _) = True
113 isNotification (NotLogMessage _) = True
114 isNotification (NotShowMessage _) = True
115 isNotification (NotCancelRequestFromServer _) = True
116 isNotification _ = False
118 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
119 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
120 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
121 msgBytes <- liftIO $ getNextMessage serverOut
122 let msg = decodeFromServerMsg reqMap msgBytes
124 handleServerMessage request response notification msg
127 then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
128 else if inRightOrder msg expectedMsgs
129 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
131 putStrLn "Out of order"
134 putStrLn "Expected one of:"
135 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
136 print $ head $ dropWhile isNotification expectedMsgs
137 putMVar passVar False
140 response :: ResponseMessage a -> Session ()
142 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
144 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
146 request :: RequestMessage ServerMethod a b -> Session ()
150 $ "Got request for id "
153 ++ show (req ^. method)
155 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
157 notification :: NotificationMessage ServerMethod a -> Session ()
158 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
162 -- TODO: QuickCheck tests?
163 -- | Checks wether or not the message appears in the right order
164 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
165 -- given N2, notification order doesn't matter.
166 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
168 -- @ N1 N3 N4 N5 REQ2 RES1 @
170 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
171 -- Order of requests and responses matter
172 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
174 inRightOrder _ [] = error "Why is this empty"
176 inRightOrder received (expected : msgs)
177 | received == expected = True
178 | isNotification expected = inRightOrder received msgs
181 -- | Ignore logging notifications since they vary from session to session
182 shouldSkip :: FromServerMessage -> Bool
183 shouldSkip (NotLogMessage _) = True
184 shouldSkip (NotShowMessage _) = True
185 shouldSkip (ReqShowMessage _) = True