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)
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 False $ \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 passSema <- newEmptyMVar
58 mainThread <- myThreadId
60 sessionThread <- liftIO $ forkIO $
61 runSessionWithHandles serverIn
63 (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
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 () -> ThreadId -> Handle -> Session ()
127 listenServer [] _ _ _ passSema _ _ = liftIO $ putMVar passSema ()
128 listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut = do
130 msgBytes <- liftIO $ getNextMessage serverOut
131 let msg = decodeFromServerMsg reqMap msgBytes
133 handleServerMessage request response notification msg
136 then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut
137 else if inRightOrder msg expectedMsgs
138 then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut
139 else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
140 ++ [head $ dropWhile isNotification expectedMsgs]
141 exc = ReplayOutOfOrderException msg remainingMsgs
142 in liftIO $ throwTo mainThreadId exc
145 response :: ResponseMessage a -> Session ()
147 liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
149 liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
151 request :: RequestMessage ServerMethod a b -> Session ()
155 $ "Got request for id "
158 ++ show (req ^. method)
160 liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
162 notification :: NotificationMessage ServerMethod a -> Session ()
163 notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
167 -- TODO: QuickCheck tests?
168 -- | Checks wether or not the message appears in the right order
169 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
170 -- given N2, notification order doesn't matter.
171 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
173 -- @ N1 N3 N4 N5 REQ2 RES1 @
175 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
176 -- Order of requests and responses matter
177 inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool
179 inRightOrder _ [] = error "Why is this empty"
181 inRightOrder received (expected : msgs)
182 | received == expected = True
183 | isNotification expected = inRightOrder received msgs
186 -- | Ignore logging notifications since they vary from session to session
187 shouldSkip :: FromServerMessage -> Bool
188 shouldSkip (NotLogMessage _) = True
189 shouldSkip (NotShowMessage _) = True
190 shouldSkip (ReqShowMessage _) = True
193 -- | Swaps out any commands uniqued with process IDs to match the specified process ID
194 swapCommands :: Int -> [Event] -> [Event]
195 swapCommands _ [] = []
197 swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqExecuteCommand swapped):swapCommands pid xs
198 where swapped = params . command .~ newCmd $ req
199 newCmd = swapPid pid (req ^. params . command)
201 swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs
202 where swapped = case newCommands of
203 Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
205 oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands
206 newCommands = fmap (fmap (swapPid pid)) oldCommands
208 swapCommands pid (x:xs) = x:swapCommands pid xs
210 hasPid :: T.Text -> Bool
211 hasPid = (>= 2) . T.length . T.filter (':' ==)
212 swapPid :: Int -> T.Text -> T.Text
214 | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t