X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=9c89a78d8d12710de7ded927f8723c7fdccad5e8;hb=1f4a12c49be0cb8640d60c21f6499c5567646fba;hp=504f3ff1f74fb68fd810d88fff1061c80abc7353;hpb=0c8e8f8436125b79e91a51267ca581d2e352e702;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index 504f3ff..9c89a78 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -1,19 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} -- | 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 + ( replay, + sendNextRequest ) where import Control.Concurrent import Control.Monad.Trans.Class import Control.Monad.Trans.Reader -import Data.Default -import Language.Haskell.LSP.Control as Control +import Control.Monad.Trans.State +import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as B -import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Capture +import Language.Haskell.LSP.Messages import qualified Language.Haskell.LSP.Types as LSP import Data.Aeson import Data.Maybe @@ -21,24 +24,35 @@ import Control.Lens import Control.Monad import System.IO import System.Directory +import System.FilePath import System.Process import Language.Haskell.LSP.Test.Files import Language.Haskell.LSP.Test.Parsing +data SessionContext = SessionContext + { + reqSema :: MVar LSP.LspId, + rspSema :: MVar LSP.LspIdRsp, + serverIn :: Handle + } +type Session = StateT [FromClientMessage] (ReaderT SessionContext IO) + -- | Replays a recorded client output and -- makes sure it matches up with an expected response. -replay - :: FilePath -- ^ The client output to replay to the server. - -> FilePath -- ^ The expected response from the server. - -> FilePath -- ^ The root directory of the project - -> IO Bool -replay cfp sfp curRootDir = do +replay :: FilePath -- ^ The recorded session directory. + -> Session a + -> IO () +replay sessionDir session = do + + let sessionFp = sessionDir "session.log" -- need to keep hold of current directory since haskell-lsp changes it - prevDir <- getCurrentDirectory + prevRootDir <- getCurrentDirectory (Just serverIn, Just serverOut, _, serverProc) <- createProcess - (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe , std_out = CreatePipe } + (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe + , std_out = CreatePipe + } hSetBuffering serverIn NoBuffering hSetBuffering serverOut NoBuffering @@ -49,145 +63,221 @@ replay cfp sfp curRootDir = do rspSema <- newEmptyMVar :: IO (MVar LSP.LspId) let semas = (reqSema, rspSema) - didPass <- newEmptyMVar + entries <- B.lines <$> B.readFile sessionFp - -- the recorded client input to the server - clientRecIn <- openFile cfp ReadMode - serverRecIn <- openFile sfp ReadMode - null <- openFile "/dev/null" WriteMode + -- decode session + let unswappedEvents = map (fromJust . decode) entries + events <- swapFiles sessionDir unswappedEvents - unswappedClientMsgs <- getAllMessages clientRecIn + let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events + requestMap = getRequestMap clientEvents - let recRootDir = rootDir unswappedClientMsgs - - (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs - - tmpDir <- getTemporaryDirectory - (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped" - mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs - hSeek mappedClientRecIn AbsoluteSeek 0 + -- listen to server + forkIO $ listenServer serverOut requestMap semas - (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn + runReaderT (runStateT session clientEvents) (SessionContext rspSema reqSema serverIn) - -- listen to server - forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass - - -- start client replay - forkIO $ do - Control.runWithHandles mappedClientRecIn - null - (const $ Right (), const $ return Nothing) - (handlers serverIn semas) - def - Nothing - Nothing - - -- todo: we shouldn't do this, we should check all notifications were delivered first - putMVar didPass True - - result <- takeMVar didPass terminateProcess serverProc -- restore directory - setCurrentDirectory prevDir - - -- cleanup temp files - removeFile mappedClientRecFp - - return result - --- | The internal monad for tests that can fail or pass, --- ending execution early. -type Session = ReaderT (MVar Bool) IO - -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 :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Session () -listenServer [] _ _ = passSession -listenServer expectedMsgs h semas@(reqSema, rspSema) = do - msg <- lift $ getNextMessage h - - newExpectedMsgs <- case decode msg of - Just m -> request m - Nothing -> case decode msg of - Just m -> notification m - Nothing -> case decode msg of - Just m -> response m - Nothing -> failSession "Malformed message" >> return expectedMsgs + setCurrentDirectory prevRootDir - listenServer newExpectedMsgs h semas + where + isClientMsg (FromClient _ _) = True + isClientMsg _ = False + + isServerMsg (FromServer _ _) = True + isServerMsg _ = False + +sendNextRequest :: Session () +sendNextRequest = do + (nextMsg:remainingMsgs) <- get + put remainingMsgs + 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 -> + 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 + context <- lift ask + liftIO $ do + putStrLn "Will send exit notification soon" + threadDelay 10000000 + B.hPut (serverIn context) $ addHeader (encode msg) - where response :: LSP.ResponseMessage Value -> Session [B.ByteString] - response res = do - lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id) + notification msg@(LSP.NotificationMessage _ m _) = do + context <- lift ask - lift $ print res + liftIO $ B.hPut (serverIn context) $ addHeader (encode msg) - checkOrder res + liftIO $ putStrLn $ "Sent a notification " ++ show m - lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request + sendNextRequest - markReceived res + request msg@(LSP.RequestMessage _ id m _) = do + context <- lift ask - request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString] - request req = do - lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method) + liftIO $ do + when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000 - lift $ print req + B.hPut (serverIn context) $ addHeader (encode msg) + putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" - checkOrder req + rspId <- takeMVar (rspSema context) + when (LSP.responseId id /= rspId) $ + error $ "Expected id " ++ show id ++ ", got " ++ show rspId - lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response + response msg@(LSP.ResponseMessage _ id _ _) = do + context <- lift ask - markReceived req + liftIO $ do + putStrLn $ "Waiting for request id " ++ show id ++ " from the server" + reqId <- takeMVar (reqSema context) + if LSP.responseId reqId /= id + then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId + else do + B.hPut (serverIn context) $ addHeader (encode msg) + putStrLn $ "Sent response to request id " ++ show id - notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString] - notification n = do - lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) - lift $ print n + sendNextRequest - lift $ putStrLn $ show ((length $ filter isNotification expectedMsgs) - 1) ++ " notifications remaining" - if n ^. LSP.method == LSP.WindowLogMessage - then return expectedMsgs - else markReceived n +-- | Listens to the server output, makes sure it matches the record and +-- signals any semaphores +listenServer :: Handle -> RequestMap -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO () +listenServer h reqMap semas@(reqSema, rspSema) = do + msgBytes <- getNextMessage h + + let msg = decodeFromServerMsg reqMap msgBytes + + print msg + + 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 + + listenServer h reqMap semas - checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do - let (Just expected) = decode firstExpected - _ = expected == msg -- make expected type same as res - failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n") + where + response :: Show a => LSP.ResponseMessage a -> IO () + response res = do + putStrLn $ "Got response for id " ++ show (res ^. LSP.id) - markReceived msg = - let new = deleteFirstJson msg expectedMsgs - in if new == expectedMsgs - then failSession ("Unexpected message: " ++ show msg) >> return new - else return new + print res - deleteFirstJson _ [] = [] - deleteFirstJson msg (x:xs) - | Just msg == decode x = xs - | otherwise = x:deleteFirstJson msg xs + putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request - firstExpected = head $ filter (not . isNotification) expectedMsgs + request :: Show a => LSP.RequestMessage LSP.ServerMethod a b -> IO () + request req = do + putStrLn + $ "Got request for id " + ++ show (req ^. LSP.id) + ++ " " + ++ show (req ^. LSP.method) + print req + putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response -isNotification :: B.ByteString -> Bool -isNotification msg = - isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value)) + notification :: Show a => LSP.NotificationMessage LSP.ServerMethod a -> IO () + notification n = do + putStrLn $ "Got notification " ++ show (n ^. LSP.method) + print n + + -- lift + -- $ putStrLn + -- $ show (length (filter isNotification expectedMsgs) - 1) + -- ++ " notifications remaining" + + -- 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 @@ -199,87 +289,28 @@ isNotification msg = -- given RES1 -- @ N1 N3 N4 N5 XXXX RES1 @ False! -- Order of requests and responses matter -inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool +inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool inRightOrder _ [] = error "Why is this empty" -- inRightOrder (LSP.NotificationMessage _ _ _) _ = True inRightOrder received (expected : msgs) - | Just received == decode expected = True + | received == expected = True | isNotification expected = inRightOrder received msgs | otherwise = False - -handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers -handlers serverH (reqSema, rspSema) = def - { - -- Requests - hoverHandler = Just request - , completionHandler = Just request - , completionResolveHandler = Just request - , signatureHelpHandler = Just request - , definitionHandler = Just request - , referencesHandler = Just request - , documentHighlightHandler = Just request - , documentSymbolHandler = Just request - , workspaceSymbolHandler = Just request - , codeActionHandler = Just request - , codeLensHandler = Just request - , codeLensResolveHandler = Just request - , documentFormattingHandler = Just request - , documentRangeFormattingHandler = Just request - , documentTypeFormattingHandler = Just request - , renameHandler = Just request - , documentLinkHandler = Just request - , documentLinkResolveHandler = Just request - , executeCommandHandler = Just request - , initializeRequestHandler = Just request - -- Notifications - , didChangeConfigurationParamsHandler = Just notification - , didOpenTextDocumentNotificationHandler = Just notification - , didChangeTextDocumentNotificationHandler = Just notification - , didCloseTextDocumentNotificationHandler = Just notification - , didSaveTextDocumentNotificationHandler = Just notification - , didChangeWatchedFilesNotificationHandler = Just notification - , initializedHandler = Just notification - , willSaveTextDocumentNotificationHandler = Just notification - , cancelNotificationHandler = Just notification - , exitNotificationHandler = Just notification - -- Responses - , responseHandler = Just response - } - 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 - 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 \ No newline at end of file