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.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 replaySession :: String -- ^ The command to run the server.
38 -> FilePath -- ^ The recorded session directory.
40 replaySession serverExe sessionDir = do
42 entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
45 let unswappedEvents = map (fromJust . decode) entries
47 withServer serverExe False $ \serverIn serverOut serverProc -> do
49 pid <- getProcessID serverProc
50 events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents
52 let clientEvents = filter isClientMsg events
53 serverEvents = filter isServerMsg events
54 clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
55 serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
56 requestMap = getRequestMap clientMsgs
58 reqSema <- newEmptyMVar
59 rspSema <- newEmptyMVar
60 passSema <- newEmptyMVar
61 mainThread <- myThreadId
63 sessionThread <- liftIO $ forkIO $
64 runSessionWithHandles serverIn serverOut serverProc
65 (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)
70 (sendMessages clientMsgs reqSema rspSema)
72 killThread sessionThread
75 isClientMsg (FromClient _ _) = True
78 isServerMsg (FromServer _ _) = True
81 sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
82 sendMessages [] _ _ = return ()
83 sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
84 handleClientMessage request response notification nextMsg
86 -- TODO: May need to prevent premature exit notification being sent
87 notification msg@(NotificationMessage _ Exit _) = do
88 liftIO $ putStrLn "Will send exit notification soon"
89 liftIO $ threadDelay 10000000
94 notification msg@(NotificationMessage _ m _) = do
97 liftIO $ putStrLn $ "Sent a notification " ++ show m
99 sendMessages remainingMsgs reqSema rspSema
101 request msg@(RequestMessage _ id m _) = do
102 sendRequestMessage msg
103 liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
105 rsp <- liftIO $ takeMVar rspSema
106 when (responseId id /= rsp) $
107 error $ "Expected id " ++ show id ++ ", got " ++ show rsp
109 sendMessages remainingMsgs reqSema rspSema
111 response msg@(ResponseMessage _ id _ _) = do
112 liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
113 reqId <- liftIO $ takeMVar reqSema
114 if responseId reqId /= id
115 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
118 liftIO $ putStrLn $ "Sent response to request id " ++ show id
120 sendMessages remainingMsgs reqSema rspSema
122 sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()
123 sendRequestMessage req = do
124 -- Update the request map
125 reqMap <- requestMap <$> ask
126 liftIO $ modifyMVar_ reqMap $
127 \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)
132 isNotification :: FromServerMessage -> Bool
133 isNotification (NotPublishDiagnostics _) = True
134 isNotification (NotLogMessage _) = True
135 isNotification (NotShowMessage _) = True
136 isNotification (NotCancelRequestFromServer _) = True
137 isNotification _ = False
139 listenServer :: [FromServerMessage]
148 listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()
149 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do
151 msgBytes <- getNextMessage serverOut
152 let msg = decodeFromServerMsg reqMap msgBytes
154 handleServerMessage request response notification msg
157 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx
158 else if inRightOrder msg expectedMsgs
159 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
160 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
161 ++ [head $ dropWhile isNotification expectedMsgs]
162 exc = ReplayOutOfOrder msg remainingMsgs
163 in liftIO $ throwTo mainThreadId exc
166 response :: ResponseMessage a -> IO ()
168 putStrLn $ "Got response for id " ++ show (res ^. id)
170 putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
172 request :: RequestMessage ServerMethod a b -> IO ()
175 $ "Got request for id "
178 ++ show (req ^. method)
180 putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
182 notification :: NotificationMessage ServerMethod a -> IO ()
183 notification n = putStrLn $ "Got notification " ++ show (n ^. method)
187 -- TODO: QuickCheck tests?
188 -- | Checks wether or not the message appears in the right order
189 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
190 -- given N2, notification order doesn't matter.
191 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
193 -- @ N1 N3 N4 N5 REQ2 RES1 @
195 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
196 -- Order of requests and responses matter
197 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
199 inRightOrder _ [] = error "Why is this empty"
201 inRightOrder received (expected : msgs)
202 | received == expected = True
203 | isNotification expected = inRightOrder received msgs
206 -- | Ignore logging notifications since they vary from session to session
207 shouldSkip :: FromServerMessage -> Bool
208 shouldSkip (NotLogMessage _) = True
209 shouldSkip (NotShowMessage _) = True
210 shouldSkip (ReqShowMessage _) = True
213 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
214 swapCommands :: Int -> [Event] -> [Event]
215 swapCommands _ [] = []
217 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
218 where swapped = params . command .~ newCmd $ req
219 newCmd = swapPid pid (req ^. params . command)
221 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
222 where swapped = case newCommands of
223 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
225 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
226 newCommands = fmap (fmap (swapPid pid)) oldCommands
228 swapCommands pid (x:xs) = x:swapCommands pid xs
230 hasPid :: T.Text -> Bool
231 hasPid = (>= 2) . T.length . T.filter (':' ==)
232 swapPid :: Int -> T.Text -> T.Text
234 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t