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
119 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
120 sendRequestMessage req = do
121 -- Update the request map
122 reqMap <- requestMap <$> ask
123 liftIO $ modifyMVar_ reqMap $
124 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
129 isNotification :: FromServerMessage -> Bool
130 isNotification (NotPublishDiagnostics _) = True
131 isNotification (NotLogMessage _) = True
132 isNotification (NotShowMessage _) = True
133 isNotification (NotCancelRequestFromServer _) = True
134 isNotification _ = False
136 -- listenServer :: [FromServerMessage]
145 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
146 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
148 msgBytes <- getNextMessage serverOut
149 let msg = decodeFromServerMsg reqMap msgBytes
151 handleServerMessage request response notification msg
154 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
155 else if inRightOrder msg expectedMsgs
156 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
157 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
158 ++ [head $ dropWhile isNotification expectedMsgs]
159 exc = ReplayOutOfOrder msg remainingMsgs
160 in liftIO $ throwTo mainThreadId exc
163 response :: ResponseMessage a -> IO ()
165 putStrLn $ "Got response for id " ++ show (res ^. id)
167 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
169 request :: RequestMessage ServerMethod a b -> IO ()
172 $ "Got request for id "
175 ++ show (req ^. method)
177 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
179 notification :: NotificationMessage ServerMethod a -> IO ()
180 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
184 -- TODO: QuickCheck tests?
185 -- | Checks wether or not the message appears in the right order
186 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
187 -- given N2, notification order doesn't matter.
188 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
190 -- @ N1 N3 N4 N5 REQ2 RES1 @
192 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
193 -- Order of requests and responses matter
194 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
196 inRightOrder _ [] = error "Why is this empty"
198 inRightOrder received (expected : msgs)
199 | received == expected = True
200 | isNotification expected = inRightOrder received msgs
203 -- | Ignore logging notifications since they vary from session to session
204 shouldSkip :: FromServerMessage -> Bool
205 shouldSkip (NotLogMessage _) = True
206 shouldSkip (NotShowMessage _) = True
207 shouldSkip (ReqShowMessage _) = True
210 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
211 swapCommands :: Int -> [Event] -> [Event]
212 swapCommands _ [] = []
214 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
215 where swapped = params . command .~ newCmd $ req
216 newCmd = swapPid pid (req ^. params . command)
218 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
219 where swapped = case newCommands of
220 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
222 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
223 newCommands = fmap (fmap (swapPid pid)) oldCommands
225 swapCommands pid (x:xs) = x:swapCommands pid xs
227 hasPid :: T.Text -> Bool
228 hasPid = (>= 2) . T.length . T.filter (':' ==)
229 swapPid :: Int -> T.Text -> T.Text
231 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t