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.Exception
11 import Control.Monad.IO.Class
12 import qualified Data.ByteString.Lazy.Char8 as B
13 import qualified Data.Text as T
15 import Language.Haskell.LSP.Capture
16 import Language.Haskell.LSP.Messages
17 import Language.Haskell.LSP.Types hiding (error)
21 import Control.Lens hiding (List)
24 import System.FilePath
26 import Language.Haskell.LSP.Test
27 import Language.Haskell.LSP.Test.Files
28 import Language.Haskell.LSP.Test.Decoding
29 import Language.Haskell.LSP.Test.Messages
30 import Language.Haskell.LSP.Test.Server
33 -- | Replays a captured client output and
34 -- makes sure it matches up with an expected response.
35 -- The session directory should have a captured session file in it
36 -- named "session.log".
37 replaySession :: String -- ^ The command to run the server.
38 -> FilePath -- ^ The recorded session directory.
40 replaySession serverExe sessionDir = do
42 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
45 let unswappedEvents = map (fromJust . decode) entries
47 withServer serverExe $ \serverIn serverOut pid -> do
49 events <- swapUUIDs pid <$> swapFiles sessionDir unswappedEvents
51 let clientEvents = filter isClientMsg events
52 serverEvents = filter isServerMsg events
53 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
54 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
55 requestMap = getRequestMap clientMsgs
57 reqSema <- newEmptyMVar
58 rspSema <- newEmptyMVar
59 passVar <- newEmptyMVar :: IO (MVar Bool)
62 runSessionWithHandles serverIn
64 (listenServer serverMsgs requestMap reqSema rspSema passVar)
66 (sendMessages clientMsgs reqSema rspSema)
68 result <- takeMVar passVar
73 isClientMsg (FromClient _ _) = True
76 isServerMsg (FromServer _ _) = True
79 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
80 sendMessages [] _ _ = return ()
81 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
82 handleClientMessage request response notification nextMsg
84 -- TODO: May need to prevent premature exit notification being sent
85 notification msg@(NotificationMessage _ Exit _) = do
86 liftIO $ putStrLn "Will send exit notification soon"
87 liftIO $ threadDelay 10000000
92 notification msg@(NotificationMessage _ m _) = do
95 liftIO $ putStrLn $ "Sent a notification " ++ show m
97 sendMessages remainingMsgs reqSema rspSema
99 request msg@(RequestMessage _ id m _) = do
101 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
103 rsp <- liftIO $ takeMVar rspSema
104 when (responseId id /= rsp) $
105 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
107 sendMessages remainingMsgs reqSema rspSema
109 response msg@(ResponseMessage _ id _ _) = do
110 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
111 reqId <- liftIO $ takeMVar reqSema
112 if responseId reqId /= id
113 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
116 liftIO $ putStrLn $ "Sent response to request id " ++ show id
118 sendMessages remainingMsgs reqSema rspSema
121 isNotification :: FromServerMessage -> Bool
122 isNotification (NotPublishDiagnostics _) = True
123 isNotification (NotLogMessage _) = True
124 isNotification (NotShowMessage _) = True
125 isNotification (NotCancelRequestFromServer _) = True
126 isNotification _ = False
128 listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
129 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
130 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
132 let handler :: IOException -> IO B.ByteString
133 handler _ = putMVar passVar False >> return B.empty
135 msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
136 let msg = decodeFromServerMsg reqMap msgBytes
138 handleServerMessage request response notification msg
141 then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
142 else if inRightOrder msg expectedMsgs
143 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
145 putStrLn "Out of order"
148 putStrLn "Expected one of:"
149 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
150 print $ head $ dropWhile isNotification expectedMsgs
151 putMVar passVar False
154 response :: ResponseMessage a -> Session ()
156 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
158 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
160 request :: RequestMessage ServerMethod a b -> Session ()
164 $ "Got request for id "
167 ++ show (req ^. method)
169 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
171 notification :: NotificationMessage ServerMethod a -> Session ()
172 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
176 -- TODO: QuickCheck tests?
177 -- | Checks wether or not the message appears in the right order
178 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
179 -- given N2, notification order doesn't matter.
180 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
182 -- @ N1 N3 N4 N5 REQ2 RES1 @
184 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
185 -- Order of requests and responses matter
186 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
188 inRightOrder _ [] = error "Why is this empty"
190 inRightOrder received (expected : msgs)
191 | received == expected = True
192 | isNotification expected = inRightOrder received msgs
195 -- | Ignore logging notifications since they vary from session to session
196 shouldSkip :: FromServerMessage -> Bool
197 shouldSkip (NotLogMessage _) = True
198 shouldSkip (NotShowMessage _) = True
199 shouldSkip (ReqShowMessage _) = True
202 -- | Swaps out the expected UUIDs to match the current process ID
203 swapUUIDs :: Int -> [Event] -> [Event]
205 swapUUIDs pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapUUIDs pid xs
206 where swapped = case newCommands of
207 Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
209 oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
210 newCommands = fmap (fmap swap) oldCommands
212 | isUuid cmd = T.append uuid $ T.dropWhile (/= ':') cmd
214 uuid = toText $ fst $ random $ mkStdGen pid
215 isUuid = isJust . fromText . T.takeWhile (/= ':')
216 swapUUIDs pid (x:xs) = x:swapUUIDs pid xs