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)
66 (sendMessages clientMsgs reqSema rspSema)
68 killThread sessionThread
71 isClientMsg (FromClient _ _) = True
74 isServerMsg (FromServer _ _) = True
77 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
78 sendMessages [] _ _ = return ()
79 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
80 handleClientMessage request response notification nextMsg
82 -- TODO: May need to prevent premature exit notification being sent
83 notification msg@(NotificationMessage _ Exit _) = do
84 liftIO $ putStrLn "Will send exit notification soon"
85 liftIO $ threadDelay 10000000
90 notification msg@(NotificationMessage _ m _) = do
93 liftIO $ putStrLn $ "Sent a notification " ++ show m
95 sendMessages remainingMsgs reqSema rspSema
97 request msg@(RequestMessage _ id m _) = do
98 sendRequestMessage msg
99 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
101 rsp <- liftIO $ takeMVar rspSema
102 when (responseId id /= rsp) $
103 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
105 sendMessages remainingMsgs reqSema rspSema
107 response msg@(ResponseMessage _ id _ _) = do
108 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
109 reqId <- liftIO $ takeMVar reqSema
110 if responseId reqId /= id
111 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
114 liftIO $ putStrLn $ "Sent response to request id " ++ show id
116 sendMessages remainingMsgs reqSema rspSema
119 isNotification :: FromServerMessage -> Bool
120 isNotification (NotPublishDiagnostics _) = True
121 isNotification (NotLogMessage _) = True
122 isNotification (NotShowMessage _) = True
123 isNotification (NotCancelRequestFromServer _) = True
124 isNotification _ = False
126 -- listenServer :: [FromServerMessage]
135 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
136 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
138 msgBytes <- getNextMessage serverOut
139 let msg = decodeFromServerMsg reqMap msgBytes
141 handleServerMessage request response notification msg
144 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
145 else if inRightOrder msg expectedMsgs
146 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
147 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
148 ++ [head $ dropWhile isNotification expectedMsgs]
149 exc = ReplayOutOfOrder msg remainingMsgs
150 in liftIO $ throwTo mainThreadId exc
153 response :: ResponseMessage a -> IO ()
155 putStrLn $ "Got response for id " ++ show (res ^. id)
157 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
159 request :: RequestMessage ServerMethod a b -> IO ()
162 $ "Got request for id "
165 ++ show (req ^. method)
167 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
169 notification :: NotificationMessage ServerMethod a -> IO ()
170 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
174 -- TODO: QuickCheck tests?
175 -- | Checks wether or not the message appears in the right order
176 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
177 -- given N2, notification order doesn't matter.
178 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
180 -- @ N1 N3 N4 N5 REQ2 RES1 @
182 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
183 -- Order of requests and responses matter
184 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
186 inRightOrder _ [] = error "Why is this empty"
188 inRightOrder received (expected : msgs)
189 | received == expected = True
190 | isNotification expected = inRightOrder received msgs
193 -- | Ignore logging notifications since they vary from session to session
194 shouldSkip :: FromServerMessage -> Bool
195 shouldSkip (NotLogMessage _) = True
196 shouldSkip (NotShowMessage _) = True
197 shouldSkip (ReqShowMessage _) = True
200 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
201 swapCommands :: Int -> [Event] -> [Event]
202 swapCommands _ [] = []
204 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
205 where swapped = params . command .~ newCmd $ req
206 newCmd = swapPid pid (req ^. params . command)
208 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
209 where swapped = case newCommands of
210 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
212 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
213 newCommands = fmap (fmap (swapPid pid)) oldCommands
215 swapCommands pid (x:xs) = x:swapCommands pid xs
217 hasPid :: T.Text -> Bool
218 hasPid = (>= 2) . T.length . T.filter (':' ==)
219 swapPid :: Int -> T.Text -> T.Text
221 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t