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
30 -- | Replays a captured client output and
31 -- makes sure it matches up with an expected response.
32 -- The session directory should have a captured session file in it
33 -- named "session.log".
34 replaySession :: String -- ^ The command to run the server.
35 -> FilePath -- ^ The recorded session directory.
37 replaySession serverExe sessionDir = do
39 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
42 let unswappedEvents = map (fromJust . decode) entries
44 withServer serverExe False $ \serverIn serverOut pid -> do
46 events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
48 let clientEvents = filter isClientMsg events
49 serverEvents = filter isServerMsg events
50 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
51 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
52 requestMap = getRequestMap clientMsgs
54 reqSema <- newEmptyMVar
55 rspSema <- newEmptyMVar
56 passSema <- newEmptyMVar
57 mainThread <- myThreadId
59 sessionThread <- liftIO $ forkIO $
60 runSessionWithHandles serverIn
62 (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
65 (sendMessages clientMsgs reqSema rspSema)
67 killThread sessionThread
70 isClientMsg (FromClient _ _) = True
73 isServerMsg (FromServer _ _) = True
76 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
77 sendMessages [] _ _ = return ()
78 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
79 handleClientMessage request response notification nextMsg
81 -- TODO: May need to prevent premature exit notification being sent
82 notification msg@(NotificationMessage _ Exit _) = do
83 liftIO $ putStrLn "Will send exit notification soon"
84 liftIO $ threadDelay 10000000
89 notification msg@(NotificationMessage _ m _) = do
92 liftIO $ putStrLn $ "Sent a notification " ++ show m
94 sendMessages remainingMsgs reqSema rspSema
96 request msg@(RequestMessage _ id m _) = do
97 sendRequestMessage msg
98 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
100 rsp <- liftIO $ takeMVar rspSema
101 when (responseId id /= rsp) $
102 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
104 sendMessages remainingMsgs reqSema rspSema
106 response msg@(ResponseMessage _ id _ _) = do
107 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
108 reqId <- liftIO $ takeMVar reqSema
109 if responseId reqId /= id
110 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
113 liftIO $ putStrLn $ "Sent response to request id " ++ show id
115 sendMessages remainingMsgs reqSema rspSema
118 isNotification :: FromServerMessage -> Bool
119 isNotification (NotPublishDiagnostics _) = True
120 isNotification (NotLogMessage _) = True
121 isNotification (NotShowMessage _) = True
122 isNotification (NotCancelRequestFromServer _) = True
123 isNotification _ = False
125 -- listenServer :: [FromServerMessage]
134 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
135 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
137 msgBytes <- getNextMessage serverOut
138 let msg = decodeFromServerMsg reqMap msgBytes
140 handleServerMessage request response notification msg
143 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
144 else if inRightOrder msg expectedMsgs
145 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
146 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
147 ++ [head $ dropWhile isNotification expectedMsgs]
148 exc = ReplayOutOfOrder msg remainingMsgs
149 in liftIO $ throwTo mainThreadId exc
152 response :: ResponseMessage a -> IO ()
154 putStrLn $ "Got response for id " ++ show (res ^. id)
156 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
158 request :: RequestMessage ServerMethod a b -> IO ()
161 $ "Got request for id "
164 ++ show (req ^. method)
166 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
168 notification :: NotificationMessage ServerMethod a -> IO ()
169 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
173 -- TODO: QuickCheck tests?
174 -- | Checks wether or not the message appears in the right order
175 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
176 -- given N2, notification order doesn't matter.
177 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
179 -- @ N1 N3 N4 N5 REQ2 RES1 @
181 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
182 -- Order of requests and responses matter
183 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
185 inRightOrder _ [] = error "Why is this empty"
187 inRightOrder received (expected : msgs)
188 | received == expected = True
189 | isNotification expected = inRightOrder received msgs
192 -- | Ignore logging notifications since they vary from session to session
193 shouldSkip :: FromServerMessage -> Bool
194 shouldSkip (NotLogMessage _) = True
195 shouldSkip (NotShowMessage _) = True
196 shouldSkip (ReqShowMessage _) = True
199 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
200 swapCommands :: Int -> [Event] -> [Event]
201 swapCommands _ [] = []
203 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
204 where swapped = params . command .~ newCmd $ req
205 newCmd = swapPid pid (req ^. params . command)
207 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
208 where swapped = case newCommands of
209 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
211 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
212 newCommands = fmap (fmap (swapPid pid)) oldCommands
214 swapCommands pid (x:xs) = x:swapCommands pid xs
216 hasPid :: T.Text -> Bool
217 hasPid = (>= 2) . T.length . T.filter (':' ==)
218 swapPid :: Int -> T.Text -> T.Text
220 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t