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)
69 (sendMessages clientMsgs reqSema rspSema)
71 killThread sessionThread
74 isClientMsg (FromClient _ _) = True
77 isServerMsg (FromServer _ _) = True
80 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
81 sendMessages [] _ _ = return ()
82 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
83 handleClientMessage request response notification nextMsg
85 -- TODO: May need to prevent premature exit notification being sent
86 notification msg@(NotificationMessage _ Exit _) = do
87 liftIO $ putStrLn "Will send exit notification soon"
88 liftIO $ threadDelay 10000000
93 notification msg@(NotificationMessage _ m _) = do
96 liftIO $ putStrLn $ "Sent a notification " ++ show m
98 sendMessages remainingMsgs reqSema rspSema
100 request msg@(RequestMessage _ id m _) = do
101 sendRequestMessage msg
102 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
104 rsp <- liftIO $ takeMVar rspSema
105 when (responseId id /= rsp) $
106 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
108 sendMessages remainingMsgs reqSema rspSema
110 response msg@(ResponseMessage _ id _ _) = do
111 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
112 reqId <- liftIO $ takeMVar reqSema
113 if responseId reqId /= id
114 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
117 liftIO $ putStrLn $ "Sent response to request id " ++ show id
119 sendMessages remainingMsgs reqSema rspSema
121 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
122 sendRequestMessage req = do
123 -- Update the request map
124 reqMap <- requestMap <$> ask
125 liftIO $ modifyMVar_ reqMap $
126 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
131 isNotification :: FromServerMessage -> Bool
132 isNotification (NotPublishDiagnostics _) = True
133 isNotification (NotLogMessage _) = True
134 isNotification (NotShowMessage _) = True
135 isNotification (NotCancelRequestFromServer _) = True
136 isNotification _ = False
138 listenServer :: [FromServerMessage]
147 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
148 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
150 msgBytes <- getNextMessage serverOut
151 let msg = decodeFromServerMsg reqMap msgBytes
153 handleServerMessage request response notification msg
156 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
157 else if inRightOrder msg expectedMsgs
158 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
159 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
160 ++ [head $ dropWhile isNotification expectedMsgs]
161 exc = ReplayOutOfOrder msg remainingMsgs
162 in liftIO $ throwTo mainThreadId exc
165 response :: ResponseMessage a -> IO ()
167 putStrLn $ "Got response for id " ++ show (res ^. id)
169 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
171 request :: RequestMessage ServerMethod a b -> IO ()
174 $ "Got request for id "
177 ++ show (req ^. method)
179 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
181 notification :: NotificationMessage ServerMethod a -> IO ()
182 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
186 -- TODO: QuickCheck tests?
187 -- | Checks wether or not the message appears in the right order
188 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
189 -- given N2, notification order doesn't matter.
190 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
192 -- @ N1 N3 N4 N5 REQ2 RES1 @
194 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
195 -- Order of requests and responses matter
196 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
198 inRightOrder _ [] = error "Why is this empty"
200 inRightOrder received (expected : msgs)
201 | received == expected = True
202 | isNotification expected = inRightOrder received msgs
205 -- | Ignore logging notifications since they vary from session to session
206 shouldSkip :: FromServerMessage -> Bool
207 shouldSkip (NotLogMessage _) = True
208 shouldSkip (NotShowMessage _) = True
209 shouldSkip (ReqShowMessage _) = True
212 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
213 swapCommands :: Int -> [Event] -> [Event]
214 swapCommands _ [] = []
216 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
217 where swapped = params . command .~ newCmd $ req
218 newCmd = swapPid pid (req ^. params . command)
220 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
221 where swapped = case newCommands of
222 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
224 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
225 newCommands = fmap (fmap (swapPid pid)) oldCommands
227 swapCommands pid (x:xs) = x:swapCommands pid xs
229 hasPid :: T.Text -> Bool
230 hasPid = (>= 2) . T.length . T.filter (':' ==)
231 swapPid :: Int -> T.Text -> T.Text
233 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t