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
16 import Language.Haskell.LSP.Types.Lens as LSP hiding (error)
21 import Control.Lens hiding (List)
23 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
30 import Language.Haskell.LSP.Test.Session
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 False $ \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 passSema <- newEmptyMVar
59 mainThread <- myThreadId
61 sessionThread <- liftIO $ forkIO $
62 runSessionWithHandles serverIn
64 (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
68 (sendMessages clientMsgs reqSema rspSema)
70 killThread sessionThread
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
100 sendRequestMessage msg
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
120 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
121 sendRequestMessage req = do
122 -- Update the request map
123 reqMap <- requestMap <$> ask
124 liftIO $ modifyMVar_ reqMap $
125 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
130 isNotification :: FromServerMessage -> Bool
131 isNotification (NotPublishDiagnostics _) = True
132 isNotification (NotLogMessage _) = True
133 isNotification (NotShowMessage _) = True
134 isNotification (NotCancelRequestFromServer _) = True
135 isNotification _ = False
137 listenServer :: [FromServerMessage]
146 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
147 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
149 msgBytes <- getNextMessage serverOut
150 let msg = decodeFromServerMsg reqMap msgBytes
152 handleServerMessage request response notification msg
155 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
156 else if inRightOrder msg expectedMsgs
157 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
158 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
159 ++ [head $ dropWhile isNotification expectedMsgs]
160 exc = ReplayOutOfOrder msg remainingMsgs
161 in liftIO $ throwTo mainThreadId exc
164 response :: ResponseMessage a -> IO ()
166 putStrLn $ "Got response for id " ++ show (res ^. id)
168 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
170 request :: RequestMessage ServerMethod a b -> IO ()
173 $ "Got request for id "
176 ++ show (req ^. method)
178 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
180 notification :: NotificationMessage ServerMethod a -> IO ()
181 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
185 -- TODO: QuickCheck tests?
186 -- | Checks wether or not the message appears in the right order
187 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
188 -- given N2, notification order doesn't matter.
189 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
191 -- @ N1 N3 N4 N5 REQ2 RES1 @
193 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
194 -- Order of requests and responses matter
195 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
197 inRightOrder _ [] = error "Why is this empty"
199 inRightOrder received (expected : msgs)
200 | received == expected = True
201 | isNotification expected = inRightOrder received msgs
204 -- | Ignore logging notifications since they vary from session to session
205 shouldSkip :: FromServerMessage -> Bool
206 shouldSkip (NotLogMessage _) = True
207 shouldSkip (NotShowMessage _) = True
208 shouldSkip (ReqShowMessage _) = True
211 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
212 swapCommands :: Int -> [Event] -> [Event]
213 swapCommands _ [] = []
215 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
216 where swapped = params . command .~ newCmd $ req
217 newCmd = swapPid pid (req ^. params . command)
219 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
220 where swapped = case newCommands of
221 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
223 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
224 newCommands = fmap (fmap (swapPid pid)) oldCommands
226 swapCommands pid (x:xs) = x:swapCommands pid xs
228 hasPid :: T.Text -> Bool
229 hasPid = (>= 2) . T.length . T.filter (':' ==)
230 swapPid :: Int -> T.Text -> T.Text
232 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t