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
21 import Control.Lens hiding (List)
23 import System.FilePath
25 import Language.Haskell.LSP.Test
26 import Language.Haskell.LSP.Test.Compat
27 import Language.Haskell.LSP.Test.Files
28 import Language.Haskell.LSP.Test.Decoding
29 import Language.Haskell.LSP.Test.Messages
30 import Language.Haskell.LSP.Test.Server
31 import Language.Haskell.LSP.Test.Session
33 -- | Replays a captured client output and
34 -- makes sure it matches up with an expected response.
35 -- The session directory should have a captured session file in it
36 -- named "session.log".
37 -- You can get these capture files from 'Language.Haskell.LSP.resCaptureFile' in
39 replaySession :: String -- ^ The command to run the server.
40 -> FilePath -- ^ The recorded session directory.
42 replaySession serverExe sessionDir = do
44 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
47 let unswappedEvents = map (fromJust . decode) entries
49 withServer serverExe False $ \serverIn serverOut serverProc -> do
51 pid <- getProcessID serverProc
52 events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
54 let clientEvents = filter isClientMsg events
55 serverEvents = filter isServerMsg events
56 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
57 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
58 requestMap = getRequestMap clientMsgs
60 reqSema <- newEmptyMVar
61 rspSema <- newEmptyMVar
62 passSema <- newEmptyMVar
63 mainThread <- myThreadId
65 sessionThread <- liftIO $ forkIO $
66 runSessionWithHandles serverIn serverOut serverProc
67 (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
71 (return ()) -- No finalizer cleanup
72 (sendMessages clientMsgs reqSema rspSema)
74 killThread sessionThread
77 isClientMsg (FromClient _ _) = True
80 isServerMsg (FromServer _ _) = True
83 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
84 sendMessages [] _ _ = return ()
85 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
86 handleClientMessage request response notification nextMsg
88 -- TODO: May need to prevent premature exit notification being sent
89 notification msg@(NotificationMessage _ Exit _) = do
90 liftIO $ putStrLn "Will send exit notification soon"
91 liftIO $ threadDelay 10000000
96 notification msg@(NotificationMessage _ m _) = do
99 liftIO $ putStrLn $ "Sent a notification " ++ show m
101 sendMessages remainingMsgs reqSema rspSema
103 request msg@(RequestMessage _ id m _) = do
104 sendRequestMessage msg
105 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
107 rsp <- liftIO $ takeMVar rspSema
108 when (responseId id /= rsp) $
109 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
111 sendMessages remainingMsgs reqSema rspSema
113 response msg@(ResponseMessage _ id _) = do
114 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
115 reqId <- liftIO $ takeMVar reqSema
116 if responseId reqId /= id
117 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
120 liftIO $ putStrLn $ "Sent response to request id " ++ show id
122 sendMessages remainingMsgs reqSema rspSema
124 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
125 sendRequestMessage req = do
126 -- Update the request map
127 reqMap <- requestMap <$> ask
128 liftIO $ modifyMVar_ reqMap $
129 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
134 isNotification :: FromServerMessage -> Bool
135 isNotification (NotPublishDiagnostics _) = True
136 isNotification (NotLogMessage _) = True
137 isNotification (NotShowMessage _) = True
138 isNotification (NotCancelRequestFromServer _) = True
139 isNotification _ = False
141 listenServer :: [FromServerMessage]
150 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
151 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
153 msgBytes <- getNextMessage serverOut
154 let msg = decodeFromServerMsg reqMap msgBytes
156 handleServerMessage request response notification msg
159 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
160 else if inRightOrder msg expectedMsgs
161 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
162 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
163 ++ [head $ dropWhile isNotification expectedMsgs]
164 exc = ReplayOutOfOrder msg remainingMsgs
165 in liftIO $ throwTo mainThreadId exc
168 response :: ResponseMessage a -> IO ()
170 putStrLn $ "Got response for id " ++ show (res ^. id)
172 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
174 request :: RequestMessage ServerMethod a b -> IO ()
177 $ "Got request for id "
180 ++ show (req ^. method)
182 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
184 notification :: NotificationMessage ServerMethod a -> IO ()
185 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
189 -- TODO: QuickCheck tests?
190 -- | Checks wether or not the message appears in the right order
191 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
192 -- given N2, notification order doesn't matter.
193 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
195 -- @ N1 N3 N4 N5 REQ2 RES1 @
197 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
198 -- Order of requests and responses matter
199 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
201 inRightOrder _ [] = error "Why is this empty"
203 inRightOrder received (expected : msgs)
204 | received == expected = True
205 | isNotification expected = inRightOrder received msgs
208 -- | Ignore logging notifications since they vary from session to session
209 shouldSkip :: FromServerMessage -> Bool
210 shouldSkip (NotLogMessage _) = True
211 shouldSkip (NotShowMessage _) = True
212 shouldSkip (ReqShowMessage _) = True
215 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
216 swapCommands :: Int -> [Event] -> [Event]
217 swapCommands _ [] = []
219 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
220 where swapped = params . command .~ newCmd $ req
221 newCmd = swapPid pid (req ^. params . command)
223 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
224 where swapped = case newCommands of
225 Just cmds -> result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
227 oldCommands = rsp ^? result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands
228 newCommands = fmap (fmap (swapPid pid)) oldCommands
230 swapCommands pid (x:xs) = x:swapCommands pid xs
232 hasPid :: T.Text -> Bool
233 hasPid = (>= 2) . T.length . T.filter (':' ==)
234 swapPid :: Int -> T.Text -> T.Text
236 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t