X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=c028478dc1e7411c3cea400d57d9dbee8e5e452e;hb=13928a9c66b4a352ae784660877d4fae57ac81d9;hp=36a55fafd5adf579365b2c612b40ae1010e0dfd5;hpb=4de144bafd28f3f2a8067a896bedb1430f68f745;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index 36a55fa..c028478 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -4,81 +4,56 @@ -- | A testing tool for replaying recorded client logs back to a server, -- and validating that the server output matches up with another log. module Language.Haskell.LSP.Test.Recorded - ( replay + ( replaySession ) where +import Prelude hiding (id) import Control.Concurrent -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader +import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as B -import Data.List import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages -import qualified Language.Haskell.LSP.Types as LSP +import Language.Haskell.LSP.Types hiding (error) import Data.Aeson +import Data.List import Data.Maybe import Control.Lens import Control.Monad import System.IO -import System.Directory -import System.Process +import System.FilePath +import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Files import Language.Haskell.LSP.Test.Parsing + -- | Replays a recorded client output and -- makes sure it matches up with an expected response. -replay - :: FilePath -- ^ The recorded session file. - -> FilePath -- ^ The root directory of the project +replaySession :: FilePath -- ^ The recorded session directory. -> IO Bool -replay sessionFp curRootDir = do - - -- need to keep hold of current directory since haskell-lsp changes it - prevDir <- getCurrentDirectory - - (Just serverIn, Just serverOut, _, serverProc) <- createProcess - (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe - , std_out = CreatePipe - } +replaySession sessionDir = do - hSetBuffering serverIn NoBuffering - hSetBuffering serverOut NoBuffering - - -- whether to send the next request - reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp) - -- whether to send the next response - rspSema <- newEmptyMVar :: IO (MVar LSP.LspId) - let semas = (reqSema, rspSema) - - didPass <- newEmptyMVar - - entries <- B.lines <$> B.readFile sessionFp + entries <- B.lines <$> B.readFile (sessionDir "session.log") -- decode session let unswappedEvents = map (fromJust . decode) entries - events <- swapFiles curRootDir unswappedEvents + events <- swapFiles sessionDir unswappedEvents - let clientEvents = - map (\(FromClient _ msg) -> msg) $ filter isClientMsg events - serverEvents = - map (\(FromServer _ msg) -> msg) $ filter isServerMsg events + let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events + serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events requestMap = getRequestMap clientEvents - -- listen to server - forkIO $ runReaderT (listenServer serverEvents serverOut requestMap semas) - didPass - forM_ clientEvents (processClient serverIn rspSema reqSema) + reqSema <- newEmptyMVar + rspSema <- newEmptyMVar + passVar <- newEmptyMVar :: IO (MVar Bool) - result <- takeMVar didPass - terminateProcess serverProc + forkIO $ runSessionWithHandler (listenServer serverEvents requestMap reqSema rspSema passVar) sessionDir $ + sendMessages clientEvents reqSema rspSema - -- restore directory - setCurrentDirectory prevDir + takeMVar passVar - return result where isClientMsg (FromClient _ _) = True isClientMsg _ = False @@ -86,9 +61,10 @@ replay sessionFp curRootDir = do isServerMsg (FromServer _ _) = True isServerMsg _ = False -processClient - :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO () -processClient serverH rspSema reqSema msg = case msg of +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 @@ -123,194 +99,138 @@ processClient serverH rspSema reqSema msg = case msg of NotWillSaveTextDocument m -> notification m NotDidSaveTextDocument m -> notification m NotDidChangeWatchedFiles m -> notification m - UnknownFromClientMessage m -> - error $ "Unknown message was recorded from the client" ++ show m + UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m where -- TODO: May need to prevent premature exit notification being sent - notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do - putStrLn "Will send exit notification soon" - threadDelay 10000000 - B.hPut serverH $ addHeader (encode msg) - notification msg@(LSP.NotificationMessage _ m _) = do - B.hPut serverH $ addHeader (encode msg) - - putStrLn $ "Sent a notification " ++ show m - - request msg@(LSP.RequestMessage _ id m _) = do - - when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000 - - B.hPut serverH $ addHeader (encode msg) - putStrLn - $ "Sent a request id " - ++ show id - ++ ": " - ++ show m - ++ "\nWaiting for a response" - - rspId <- takeMVar reqSema - when (LSP.responseId id /= rspId) - $ error - $ "Expected id " - ++ show id - ++ ", got " - ++ show rspId - - response msg@(LSP.ResponseMessage _ id _ _) = do - putStrLn $ "Waiting for request id " ++ show id ++ " from the server" - reqId <- takeMVar rspSema - if LSP.responseId reqId /= id + notification msg@(NotificationMessage _ Exit _) = do + liftIO $ putStrLn "Will send exit notification soon" + liftIO $ threadDelay 10000000 + sendNotification' msg + + liftIO $ error "Done" + + notification msg@(NotificationMessage _ m _) = do + sendNotification' msg + + liftIO $ putStrLn $ "Sent a notification " ++ show m + + sendMessages remainingMsgs reqSema rspSema + + request msg@(RequestMessage _ id m _) = do + liftIO $ print $ addHeader $ encode msg + + sendRequest' msg + liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" + + rsp <- liftIO $ takeMVar rspSema + when (responseId id /= rsp) $ + error $ "Expected id " ++ show id ++ ", got " ++ show rsp + + sendMessages remainingMsgs reqSema rspSema + + response msg@(ResponseMessage _ id _ _) = do + liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server" + reqId <- liftIO $ takeMVar reqSema + if responseId reqId /= id then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId else do - B.hPut serverH $ addHeader (encode msg) - putStrLn $ "Sent response to request id " ++ show id - --- | The internal monad for tests that can fail or pass, --- ending execution early. -type Session = ReaderT (MVar Bool) IO - --- TODO: Make return type polymoprhic more like error -failSession :: String -> Session () -failSession reason = do - lift $ putStrLn reason - passVar <- ask - lift $ putMVar passVar False - -passSession :: Session () -passSession = do - passVar <- ask - lift $ putMVar passVar True - --- | Listens to the server output, makes sure it matches the record and --- signals any semaphores -listenServer - :: [FromServerMessage] - -> Handle - -> RequestMap - -> (MVar LSP.LspIdRsp, MVar LSP.LspId) - -> Session () -listenServer [] _ _ _ = passSession -listenServer expectedMsgs h reqMap semas@(reqSema, rspSema) = do - msgBytes <- lift $ getNextMessage h - - let actualMsg = decodeFromServerMsg reqMap msgBytes - - lift $ print actualMsg - - newExpectedMsgs <- case actualMsg of - ReqRegisterCapability m -> request actualMsg m - ReqApplyWorkspaceEdit m -> request actualMsg m - ReqShowMessage m -> request actualMsg m - ReqUnregisterCapability m -> request actualMsg m - RspInitialize m -> response actualMsg m - RspShutdown m -> response actualMsg m - RspHover m -> response actualMsg m - RspCompletion m -> response actualMsg m - RspCompletionItemResolve m -> response actualMsg m - RspSignatureHelp m -> response actualMsg m - RspDefinition m -> response actualMsg m - RspFindReferences m -> response actualMsg m - RspDocumentHighlights m -> response actualMsg m - RspDocumentSymbols m -> response actualMsg m - RspWorkspaceSymbols m -> response actualMsg m - RspCodeAction m -> response actualMsg m - RspCodeLens m -> response actualMsg m - RspCodeLensResolve m -> response actualMsg m - RspDocumentFormatting m -> response actualMsg m - RspDocumentRangeFormatting m -> response actualMsg m - RspDocumentOnTypeFormatting m -> response actualMsg m - RspRename m -> response actualMsg m - RspExecuteCommand m -> response actualMsg m - RspError m -> response actualMsg m - RspDocumentLink m -> response actualMsg m - RspDocumentLinkResolve m -> response actualMsg m - RspWillSaveWaitUntil m -> response actualMsg m - NotPublishDiagnostics m -> notification actualMsg m - NotLogMessage m -> notification actualMsg m - NotShowMessage m -> notification actualMsg m - NotTelemetry m -> notification actualMsg m - NotCancelRequestFromServer m -> notification actualMsg m - - listenServer newExpectedMsgs h reqMap semas - where - response - :: Show a - => FromServerMessage - -> LSP.ResponseMessage a - -> Session [FromServerMessage] - response msg res = do - lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id) + sendResponse' msg + liftIO $ putStrLn $ "Sent response to request id " ++ show id + + sendMessages remainingMsgs reqSema rspSema + - lift $ print res +isNotification :: FromServerMessage -> Bool +isNotification (NotPublishDiagnostics _) = True +isNotification (NotLogMessage _) = True +isNotification (NotShowMessage _) = True +isNotification (NotCancelRequestFromServer _) = True +isNotification _ = False + +listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session () +listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True +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 + + if inRightOrder msg expectedMsgs + then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut + else liftIO $ do + putStrLn "Out of order" + putStrLn "Got:" + print msg + putStrLn "Expected one of:" + mapM_ print $ takeWhile (not . isNotification) expectedMsgs + print $ head $ dropWhile (not . isNotification) expectedMsgs + putMVar passVar False - checkOrder msg + where + response :: Show a => ResponseMessage a -> Session () + response res = do + liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) - lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request + liftIO $ print res - markReceived msg + liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - request - :: (Show a, Show b) - => FromServerMessage - -> LSP.RequestMessage LSP.ServerMethod a b - -> Session [FromServerMessage] - request msg req = do - lift + request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session () + request req = do + liftIO $ putStrLn $ "Got request for id " - ++ show (req ^. LSP.id) + ++ show (req ^. id) ++ " " - ++ show (req ^. LSP.method) - - lift $ print req - - checkOrder msg + ++ show (req ^. method) - lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response + liftIO $ print req - markReceived msg + liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - notification - :: Show a - => FromServerMessage - -> LSP.NotificationMessage LSP.ServerMethod a - -> Session [FromServerMessage] - notification msg n = do - lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) - lift $ print n + notification :: Show a => NotificationMessage ServerMethod a -> Session () + notification n = do + liftIO $ putStrLn $ "Got notification " ++ show (n ^. method) + liftIO $ print n - lift + liftIO $ putStrLn $ show (length (filter isNotification expectedMsgs) - 1) ++ " notifications remaining" - if n ^. LSP.method == LSP.WindowLogMessage - then return expectedMsgs - else markReceived msg - checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession - ( "Out of order\nExpected\n" - ++ show firstExpected - ++ "\nGot\n" - ++ show msg - ++ "\n" - ) - - markReceived :: FromServerMessage -> Session [FromServerMessage] - markReceived msg = - let new = delete msg expectedMsgs - in if new == expectedMsgs - then failSession ("Unexpected message: " ++ show msg) >> return new - else return new - - firstExpected = head $ filter (not . isNotification) expectedMsgs - -isNotification :: FromServerMessage -> Bool -isNotification (NotPublishDiagnostics _) = True -isNotification (NotLogMessage _) = True -isNotification (NotShowMessage _) = True -isNotification (NotCancelRequestFromServer _) = True -isNotification _ = False -- TODO: QuickCheck tests? -- | Checks wether or not the message appears in the right order