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.Exception
11 import Control.Monad.IO.Class
12 import qualified Data.ByteString.Lazy.Char8 as B
13 import qualified Data.Text as T
14 import Language.Haskell.LSP.Capture
15 import Language.Haskell.LSP.Messages
16 import Language.Haskell.LSP.Types hiding (error)
20 import Control.Lens hiding (List)
23 import System.FilePath
24 import Language.Haskell.LSP.Test
25 import Language.Haskell.LSP.Test.Files
26 import Language.Haskell.LSP.Test.Decoding
27 import Language.Haskell.LSP.Test.Messages
28 import Language.Haskell.LSP.Test.Server
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 $ \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 passVar <- newEmptyMVar :: IO (MVar Bool)
60 runSessionWithHandles serverIn
62 (listenServer serverMsgs requestMap reqSema rspSema passVar)
64 (sendMessages clientMsgs reqSema rspSema)
66 result <- takeMVar passVar
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
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] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
127 listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
128 listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
130 let handler :: IOException -> IO B.ByteString
131 handler _ = putMVar passVar False >> return B.empty
133 msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
134 let msg = decodeFromServerMsg reqMap msgBytes
136 handleServerMessage request response notification msg
139 then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
140 else if inRightOrder msg expectedMsgs
141 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
143 putStrLn "Out of order"
146 putStrLn "Expected one of:"
147 mapM_ print $ takeWhile (not . isNotification) expectedMsgs
148 print $ head $ dropWhile isNotification expectedMsgs
149 putMVar passVar False
152 response :: ResponseMessage a -> Session ()
154 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
156 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
158 request :: RequestMessage ServerMethod a b -> Session ()
162 $ "Got request for id "
165 ++ show (req ^. method)
167 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
169 notification :: NotificationMessage ServerMethod a -> Session ()
170 notification n = liftIO $ 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 . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
212 oldCommands = rsp ^? result . _Just . 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