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 qualified Data.Text as T
13 import Language.Haskell.LSP.Capture
14 import Language.Haskell.LSP.Messages
15 import Language.Haskell.LSP.Types as LSP hiding (error)
20 import Control.Lens hiding (List)
22 import System.FilePath
23 import Language.Haskell.LSP.Test
24 import Language.Haskell.LSP.Test.Files
25 import Language.Haskell.LSP.Test.Decoding
26 import Language.Haskell.LSP.Test.Messages
27 import Language.Haskell.LSP.Test.Server
28 import Language.Haskell.LSP.Test.Session
31 -- | Replays a captured client output and
32 -- makes sure it matches up with an expected response.
33 -- The session directory should have a captured session file in it
34 -- named "session.log".
35 replaySession :: String -- ^ The command to run the server.
36 -> FilePath -- ^ The recorded session directory.
38 replaySession serverExe sessionDir = do
40 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
43 let unswappedEvents = map (fromJust . decode) entries
45 withServer serverExe False $ \serverIn serverOut pid -> do
47 events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
49 let clientEvents = filter isClientMsg events
50 serverEvents = filter isServerMsg events
51 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
52 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
53 requestMap = getRequestMap clientMsgs
55 reqSema <- newEmptyMVar
56 rspSema <- newEmptyMVar
57 passSema <- newEmptyMVar
58 mainThread <- myThreadId
60 sessionThread <- liftIO $ forkIO $
61 runSessionWithHandles serverIn
63 (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
67 (sendMessages clientMsgs reqSema rspSema)
69 killThread sessionThread
72 isClientMsg (FromClient _ _) = True
75 isServerMsg (FromServer _ _) = True
78 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
79 sendMessages [] _ _ = return ()
80 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
81 handleClientMessage request response notification nextMsg
83 -- TODO: May need to prevent premature exit notification being sent
84 notification msg@(NotificationMessage _ Exit _) = do
85 liftIO $ putStrLn "Will send exit notification soon"
86 liftIO $ threadDelay 10000000
91 notification msg@(NotificationMessage _ m _) = do
94 liftIO $ putStrLn $ "Sent a notification " ++ show m
96 sendMessages remainingMsgs reqSema rspSema
98 request msg@(RequestMessage _ id m _) = do
99 sendRequestMessage msg
100 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
102 rsp <- liftIO $ takeMVar rspSema
103 when (responseId id /= rsp) $
104 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
106 sendMessages remainingMsgs reqSema rspSema
108 response msg@(ResponseMessage _ id _ _) = do
109 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
110 reqId <- liftIO $ takeMVar reqSema
111 if responseId reqId /= id
112 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
115 liftIO $ putStrLn $ "Sent response to request id " ++ show id
117 sendMessages remainingMsgs reqSema rspSema
120 isNotification :: FromServerMessage -> Bool
121 isNotification (NotPublishDiagnostics _) = True
122 isNotification (NotLogMessage _) = True
123 isNotification (NotShowMessage _) = True
124 isNotification (NotCancelRequestFromServer _) = True
125 isNotification _ = False
127 -- listenServer :: [FromServerMessage]
136 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
137 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
139 msgBytes <- getNextMessage serverOut
140 let msg = decodeFromServerMsg reqMap msgBytes
142 handleServerMessage request response notification msg
145 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
146 else if inRightOrder msg expectedMsgs
147 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
148 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
149 ++ [head $ dropWhile isNotification expectedMsgs]
150 exc = ReplayOutOfOrder msg remainingMsgs
151 in liftIO $ throwTo mainThreadId exc
154 response :: ResponseMessage a -> IO ()
156 putStrLn $ "Got response for id " ++ show (res ^. id)
158 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
160 request :: RequestMessage ServerMethod a b -> IO ()
163 $ "Got request for id "
166 ++ show (req ^. method)
168 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
170 notification :: NotificationMessage ServerMethod a -> IO ()
171 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
175 -- TODO: QuickCheck tests?
176 -- | Checks wether or not the message appears in the right order
177 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
178 -- given N2, notification order doesn't matter.
179 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
181 -- @ N1 N3 N4 N5 REQ2 RES1 @
183 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
184 -- Order of requests and responses matter
185 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
187 inRightOrder _ [] = error "Why is this empty"
189 inRightOrder received (expected : msgs)
190 | received == expected = True
191 | isNotification expected = inRightOrder received msgs
194 -- | Ignore logging notifications since they vary from session to session
195 shouldSkip :: FromServerMessage -> Bool
196 shouldSkip (NotLogMessage _) = True
197 shouldSkip (NotShowMessage _) = True
198 shouldSkip (ReqShowMessage _) = True
201 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
202 swapCommands :: Int -> [Event] -> [Event]
203 swapCommands _ [] = []
205 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
206 where swapped = params . command .~ newCmd $ req
207 newCmd = swapPid pid (req ^. params . command)
209 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
210 where swapped = case newCommands of
211 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
213 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
214 newCommands = fmap (fmap (swapPid pid)) oldCommands
216 swapCommands pid (x:xs) = x:swapCommands pid xs
218 hasPid :: T.Text -> Bool
219 hasPid = (>= 2) . T.length . T.filter (':' ==)
220 swapPid :: Int -> T.Text -> T.Text
222 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t