1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 -- | A testing tool for replaying recorded client logs back to a server,
4 -- and validating that the server output matches up with another log.
5 module Language.Haskell.LSP.Test.Recorded
10 import Control.Concurrent
11 import Control.Monad.Trans.Class
12 import Control.Monad.Trans.Reader
14 import Language.Haskell.LSP.Control as Control
15 import qualified Data.ByteString.Lazy.Char8 as B
16 import Language.Haskell.LSP.Core
17 import qualified Language.Haskell.LSP.Types as LSP
24 import System.Directory
26 import Language.Haskell.LSP.Test.Files
28 -- | Replays a recorded client output and
29 -- makes sure it matches up with an expected response.
31 :: FilePath -- ^ The client output to replay to the server.
32 -> FilePath -- ^ The expected response from the server.
36 -- need to keep hold of current directory since haskell-lsp changes it
37 prevDir <- getCurrentDirectory
39 (Just serverIn, Just serverOut, _, serverProc) <- createProcess
40 (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe , std_out = CreatePipe }
42 hSetBuffering serverIn NoBuffering
43 hSetBuffering serverOut NoBuffering
45 -- whether to send the next request
46 reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp)
47 -- whether to send the next response
48 rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
49 let semas = (reqSema, rspSema)
51 didPass <- newEmptyMVar
53 -- the recorded client input to the server
54 clientRecIn <- openFile cfp ReadMode
55 serverRecIn <- openFile sfp ReadMode
56 null <- openFile "/dev/null" WriteMode
59 (clientMsgs, fileMap) <- loadSwappedFiles emptyFileMap clientRecIn
61 tmpDir <- getTemporaryDirectory
62 (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
63 mapM_ (B.hPut mappedClientRecIn) $ map addHeader clientMsgs
64 hSeek mappedClientRecIn AbsoluteSeek 0
67 (expectedMsgs, _) <- loadSwappedFiles fileMap serverRecIn
70 forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
72 -- start client replay
74 Control.runWithHandles mappedClientRecIn
76 (const $ Right (), const $ return Nothing)
77 (handlers serverIn semas)
82 -- todo: we shouldn't do this, we should check all notifications were delivered first
85 result <- takeMVar didPass
86 terminateProcess serverProc
89 setCurrentDirectory prevDir
93 -- | The internal monad for tests that can fail or pass,
94 -- ending execution early.
95 type Session = ReaderT (MVar Bool) IO
97 failSession :: String -> Session ()
98 failSession reason = do
99 lift $ putStrLn reason
101 lift $ putMVar passVar False
103 passSession :: Session ()
106 lift $ putMVar passVar True
108 -- | Listens to the server output, makes sure it matches the record and
109 -- signals any semaphores
110 listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session ()
111 listenServer [] _ _ = passSession
112 listenServer expectedMsgs h semas@(reqSema, rspSema) = do
113 msg <- lift $ getNextMessage h
114 lift $ putStrLn $ "Remaining messages " ++ show (length expectedMsgs)
115 if inRightOrder msg expectedMsgs
118 whenResponse msg $ \res -> lift $ do
119 putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
120 putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
122 whenRequest msg $ \req -> lift $ do
123 putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
124 putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
126 whenNotification msg $ \n -> lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
128 unless (msg `elem` expectedMsgs) $ failSession "Got an unexpected message"
130 listenServer (delete msg expectedMsgs) h semas
132 let reason = "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs))
133 in failSession reason
135 isNotification :: B.ByteString -> Bool
137 isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
139 whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> Session ()) -> Session ()
140 whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of
141 Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg')
145 :: B.ByteString -> (LSP.RequestMessage Value Value Value -> Session ()) -> Session ()
147 forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value)))
149 whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> Session ()) -> Session ()
150 whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value)))
152 -- TODO: QuickCheck tests?
153 -- | Checks wether or not the message appears in the right order
154 -- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @
155 -- given N2, notification order doesn't matter.
156 -- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @
158 -- @ N1 N3 N4 N5 REQ2 RES1 @
160 -- @ N1 N3 N4 N5 XXXX RES1 @ False!
161 -- Order of requests and responses matter
162 inRightOrder :: B.ByteString -> [B.ByteString] -> Bool
163 inRightOrder _ [] = error "why is this empty"
164 inRightOrder received msgs = received `elem` valid
166 valid = takeWhile canSkip msgs ++ firstNonSkip
167 -- we don't care about the order of notifications
168 canSkip = isNotification
169 nonSkip = dropWhile canSkip msgs
170 firstNonSkip | null nonSkip = []
171 | otherwise = [head nonSkip]
173 getAllMessages :: Handle -> IO [B.ByteString]
174 getAllMessages h = do
179 msg <- getNextMessage h
181 (msg :) <$> getAllMessages h
183 -- | Fetches the next message bytes based on
184 -- the Content-Length header
185 getNextMessage :: Handle -> IO B.ByteString
186 getNextMessage h = do
187 headers <- getHeaders h
188 case read . init <$> lookup "Content-Length" headers of
189 Nothing -> error "Couldn't read Content-Length header"
190 Just size -> B.hGet h size
192 handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
193 handlers serverH (reqSema, rspSema) = def
196 hoverHandler = Just request
197 , completionHandler = Just request
198 , completionResolveHandler = Just request
199 , signatureHelpHandler = Just request
200 , definitionHandler = Just request
201 , referencesHandler = Just request
202 , documentHighlightHandler = Just request
203 , documentSymbolHandler = Just request
204 , workspaceSymbolHandler = Just request
205 , codeActionHandler = Just request
206 , codeLensHandler = Just request
207 , codeLensResolveHandler = Just request
208 , documentFormattingHandler = Just request
209 , documentRangeFormattingHandler = Just request
210 , documentTypeFormattingHandler = Just request
211 , renameHandler = Just request
212 , documentLinkHandler = Just request
213 , documentLinkResolveHandler = Just request
214 , executeCommandHandler = Just request
215 , initializeRequestHandler = Just request
217 , didChangeConfigurationParamsHandler = Just notification
218 , didOpenTextDocumentNotificationHandler = Just notification
219 , didChangeTextDocumentNotificationHandler = Just notification
220 , didCloseTextDocumentNotificationHandler = Just notification
221 , didSaveTextDocumentNotificationHandler = Just notification
222 , didChangeWatchedFilesNotificationHandler = Just notification
223 , initializedHandler = Just notification
224 , willSaveTextDocumentNotificationHandler = Just notification
225 , cancelNotificationHandler = Just notification
226 , exitNotificationHandler = Just notification
228 , responseHandler = Just response
232 -- TODO: May need to prevent premature exit notification being sent
233 -- notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
234 -- putStrLn "Will send exit notification soon"
235 -- threadDelay 10000000
236 -- B.hPut serverH $ addHeader (encode msg)
237 notification msg@(LSP.NotificationMessage _ m _) = do
238 B.hPut serverH $ addHeader (encode msg)
240 putStrLn $ "Sent a notification " ++ show m
242 request msg@(LSP.RequestMessage _ id m _) = do
244 when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
246 B.hPut serverH $ addHeader (encode msg)
247 putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
249 rspId <- takeMVar reqSema
250 when (LSP.responseId id /= rspId)
257 response msg@(LSP.ResponseMessage _ id _ _) = do
258 putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
259 reqId <- takeMVar rspSema
260 if LSP.responseId reqId /= id
261 then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
263 B.hPut serverH $ addHeader (encode msg)
264 putStrLn $ "Sent response to request id " ++ show id
266 addHeader :: B.ByteString -> B.ByteString
267 addHeader content = B.concat
269 , B.pack $ show $ B.length content
275 getHeaders :: Handle -> IO [(String, String)]
278 let (name, val) = span (/= ':') l
279 if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h