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
14 import Language.Haskell.LSP.Capture
15 import Language.Haskell.LSP.Messages
16 import Language.Haskell.LSP.Types as LSP hiding (error)
21 import Control.Lens hiding (List)
24 import System.FilePath
25 import Language.Haskell.LSP.Test
26 import Language.Haskell.LSP.Test.Files
27 import Language.Haskell.LSP.Test.Decoding
28 import Language.Haskell.LSP.Test.Messages
29 import Language.Haskell.LSP.Test.Server
32 -- | Replays a captured client output and
33 -- makes sure it matches up with an expected response.
34 -- The session directory should have a captured session file in it
35 -- named "session.log".
36 replaySession :: String -- ^ The command to run the server.
37 -> FilePath -- ^ The recorded session directory.
39 replaySession serverExe sessionDir = do
41 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
44 let unswappedEvents = map (fromJust . decode) entries
46 withServer serverExe $ \serverIn serverOut pid -> do
48 events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
50 let clientEvents = filter isClientMsg events
51 serverEvents = filter isServerMsg events
52 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
53 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
54 requestMap = getRequestMap clientMsgs
56 reqSema <- newEmptyMVar
57 rspSema <- newEmptyMVar
58 passVar <- newEmptyMVar :: IO (MVar Bool)
61 runSessionWithHandles serverIn
63 (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 any commands uniqued with process IDs to match the specified process ID
203 swapCommands :: Int -> [Event] -> [Event]
204 swapCommands _ [] = []
206 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
207 where swapped = params . command .~ newCmd $ req
208 newCmd = swapPid pid (req ^. params . command)
210 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
211 where swapped = case newCommands of
212 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
214 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
215 newCommands = fmap (fmap (swapPid pid)) oldCommands
217 swapCommands pid (x:xs) = x:swapCommands pid xs
219 hasPid :: T.Text -> Bool
220 hasPid = (>= 2) . T.length . T.filter (':' ==)
221 swapPid :: Int -> T.Text -> T.Text
223 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t