X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FReplay.hs;h=9d7f136a20056a7f81359e23f9856c0248c915de;hb=7d0ddb8022d9cccc68a99008dd55c1d39ddda3e7;hp=c9507b5ffd02c7dc2dcb6f7ba770a4b0207162a7;hpb=bf56f6dd8c0b0fc34770135819caa54a6410b1df;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index c9507b5..9d7f136 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -- | A testing tool for replaying captured client logs back to a server, -- and validating that the server output matches up with another log. module Language.Haskell.LSP.Test.Replay @@ -24,16 +21,18 @@ import System.IO import System.FilePath import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Files -import Language.Haskell.LSP.Test.Parsing +import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Messages -- | Replays a captured client output and -- makes sure it matches up with an expected response. -- The session directory should have a captured session file in it -- named "session.log". -replaySession :: FilePath -- ^ The recorded session directory. +replaySession :: String -- ^ The command to run the server. + -> FilePath -- ^ The recorded session directory. -> IO Bool -replaySession sessionDir = do +replaySession serverExe sessionDir = do entries <- B.lines <$> B.readFile (sessionDir "session.log") @@ -48,15 +47,19 @@ replaySession sessionDir = do serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents requestMap = getRequestMap clientMsgs - reqSema <- newEmptyMVar rspSema <- newEmptyMVar passVar <- newEmptyMVar :: IO (MVar Bool) - forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $ - sendMessages clientMsgs reqSema rspSema + threadId <- forkIO $ + runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) + serverExe + sessionDir + (sendMessages clientMsgs reqSema rspSema) - takeMVar passVar + result <- takeMVar passVar + killThread threadId + return result where isClientMsg (FromClient _ _) = True @@ -68,42 +71,7 @@ replaySession sessionDir = do sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session () sendMessages [] _ _ = return () sendMessages (nextMsg:remainingMsgs) reqSema rspSema = - case nextMsg of - ReqInitialize m -> request m - ReqShutdown m -> request m - ReqHover m -> request m - ReqCompletion m -> request m - ReqCompletionItemResolve m -> request m - ReqSignatureHelp m -> request m - ReqDefinition m -> request m - ReqFindReferences m -> request m - ReqDocumentHighlights m -> request m - ReqDocumentSymbols m -> request m - ReqWorkspaceSymbols m -> request m - ReqCodeAction m -> request m - ReqCodeLens m -> request m - ReqCodeLensResolve m -> request m - ReqDocumentFormatting m -> request m - ReqDocumentRangeFormatting m -> request m - ReqDocumentOnTypeFormatting m -> request m - ReqRename m -> request m - ReqExecuteCommand m -> request m - ReqDocumentLink m -> request m - ReqDocumentLinkResolve m -> request m - ReqWillSaveWaitUntil m -> request m - RspApplyWorkspaceEdit m -> response m - RspFromClient m -> response m - NotInitialized m -> notification m - NotExit m -> notification m - NotCancelRequestFromClient m -> notification m - NotDidChangeConfiguration m -> notification m - NotDidOpenTextDocument m -> notification m - NotDidChangeTextDocument m -> notification m - NotDidCloseTextDocument m -> notification m - NotWillSaveTextDocument m -> notification m - NotDidSaveTextDocument m -> notification m - NotDidChangeWatchedFiles m -> notification m - UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m + handleClientMessage request response notification nextMsg where -- TODO: May need to prevent premature exit notification being sent notification msg@(NotificationMessage _ Exit _) = do @@ -136,7 +104,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = if responseId reqId /= id then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId else do - sendResponse' msg + sendResponse msg liftIO $ putStrLn $ "Sent response to request id " ++ show id sendMessages remainingMsgs reqSema rspSema @@ -155,39 +123,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do msgBytes <- liftIO $ getNextMessage serverOut let msg = decodeFromServerMsg reqMap msgBytes - case msg of - ReqRegisterCapability m -> request m - ReqApplyWorkspaceEdit m -> request m - ReqShowMessage m -> request m - ReqUnregisterCapability m -> request m - RspInitialize m -> response m - RspShutdown m -> response m - RspHover m -> response m - RspCompletion m -> response m - RspCompletionItemResolve m -> response m - RspSignatureHelp m -> response m - RspDefinition m -> response m - RspFindReferences m -> response m - RspDocumentHighlights m -> response m - RspDocumentSymbols m -> response m - RspWorkspaceSymbols m -> response m - RspCodeAction m -> response m - RspCodeLens m -> response m - RspCodeLensResolve m -> response m - RspDocumentFormatting m -> response m - RspDocumentRangeFormatting m -> response m - RspDocumentOnTypeFormatting m -> response m - RspRename m -> response m - RspExecuteCommand m -> response m - RspError m -> response m - RspDocumentLink m -> response m - RspDocumentLinkResolve m -> response m - RspWillSaveWaitUntil m -> response m - NotPublishDiagnostics m -> notification m - NotLogMessage m -> notification m - NotShowMessage m -> notification m - NotTelemetry m -> notification m - NotCancelRequestFromServer m -> notification m + handleServerMessage request response notification msg if shouldSkip msg then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut @@ -199,17 +135,17 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do print msg putStrLn "Expected one of:" mapM_ print $ takeWhile (not . isNotification) expectedMsgs - print $ head $ dropWhile (not . isNotification) expectedMsgs + print $ head $ dropWhile isNotification expectedMsgs putMVar passVar False where - response :: Show a => ResponseMessage a -> Session () + response :: ResponseMessage a -> Session () response res = do liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session () + request :: RequestMessage ServerMethod a b -> Session () request req = do liftIO $ putStrLn @@ -220,7 +156,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - notification :: Show a => NotificationMessage ServerMethod a -> Session () + notification :: NotificationMessage ServerMethod a -> Session () notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)