X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=c028478dc1e7411c3cea400d57d9dbee8e5e452e;hb=13928a9c66b4a352ae784660877d4fae57ac81d9;hp=f1854d1fb6268330a374b33fabbcc10ff870d2b2;hpb=ad24be51d5cb2445e8a6a8216a6c8e580447439a;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index f1854d1..c028478 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -1,145 +1,236 @@ {-# 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 + ( replaySession ) where +import Prelude hiding (id) 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.IO.Class import qualified Data.ByteString.Lazy.Char8 as B -import Language.Haskell.LSP.Core -import qualified Language.Haskell.LSP.Types as LSP +import Language.Haskell.LSP.Capture +import Language.Haskell.LSP.Messages +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 client output to replay to the server. - -> FilePath -- ^ The expected response from the server. +replaySession :: FilePath -- ^ The recorded session directory. -> IO Bool -replay cfp sfp = 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", "-d"]) { std_in = CreatePipe - , std_out = CreatePipe - } - - hSetBuffering serverIn NoBuffering - hSetBuffering serverOut NoBuffering - - -- todo: use qsem - -- 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 - - -- the recorded client input to the server - clientRecIn <- openFile cfp ReadMode - serverRecIn <- openFile sfp ReadMode - null <- openFile "/dev/null" WriteMode - - expectedMsgs <- getAllMessages serverRecIn - - -- listen to server - forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass - - -- start client replay - forkIO $ do - Control.runWithHandles clientRecIn - 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 - - 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 - lift $ putStrLn $ "Remaining messages " ++ show (length expectedMsgs) +replaySession sessionDir = do + + entries <- B.lines <$> B.readFile (sessionDir "session.log") + + -- decode session + let unswappedEvents = map (fromJust . decode) entries + + events <- swapFiles sessionDir unswappedEvents + + let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events + serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events + requestMap = getRequestMap clientEvents + + + reqSema <- newEmptyMVar + rspSema <- newEmptyMVar + passVar <- newEmptyMVar :: IO (MVar Bool) + + forkIO $ runSessionWithHandler (listenServer serverEvents requestMap reqSema rspSema passVar) sessionDir $ + sendMessages clientEvents reqSema rspSema + + takeMVar passVar + + where + isClientMsg (FromClient _ _) = True + isClientMsg _ = False + + isServerMsg (FromServer _ _) = True + isServerMsg _ = False + +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 + where + -- TODO: May need to prevent premature exit notification being sent + 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 + sendResponse' msg + liftIO $ putStrLn $ "Sent response to request id " ++ show id + + sendMessages remainingMsgs reqSema rspSema + + +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 do + 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 + + where + response :: Show a => ResponseMessage a -> Session () + response res = do + liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) - whenResponse msg $ \res -> lift $ do - putStrLn $ "Got response for id " ++ show (res ^. LSP.id) - putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request + liftIO $ print res - whenRequest msg $ \req -> lift $ do - putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method) - putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response + liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - whenNotification msg $ \n -> lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) + request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session () + request req = do + liftIO + $ putStrLn + $ "Got request for id " + ++ show (req ^. id) + ++ " " + ++ show (req ^. method) - unless (msg `elem` expectedMsgs) $ failSession "Got an unexpected message" + liftIO $ print req - listenServer (delete msg expectedMsgs) h semas - else - let reason = "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs)) - in failSession reason + liftIO $ putMVar reqSema (req ^. 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 => NotificationMessage ServerMethod a -> Session () + notification n = do + liftIO $ putStrLn $ "Got notification " ++ show (n ^. method) + liftIO $ print n -whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> Session ()) -> Session () -whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of - Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg') - _ -> return () + liftIO + $ putStrLn + $ show (length (filter isNotification expectedMsgs) - 1) + ++ " notifications remaining" -whenRequest - :: B.ByteString -> (LSP.RequestMessage Value Value Value -> Session ()) -> Session () -whenRequest msg = - forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value))) -whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> Session ()) -> Session () -whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value))) -- TODO: QuickCheck tests? -- | Checks wether or not the message appears in the right order @@ -151,117 +242,12 @@ whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Valu -- given RES1 -- @ N1 N3 N4 N5 XXXX RES1 @ False! -- Order of requests and responses matter -inRightOrder :: B.ByteString -> [B.ByteString] -> Bool -inRightOrder _ [] = error "why is this empty" -inRightOrder received msgs = received `elem` valid - where - valid = takeWhile canSkip msgs ++ firstNonSkip - -- we don't care about the order of notifications - canSkip = isNotification - nonSkip = dropWhile canSkip msgs - firstNonSkip | null nonSkip = [] - | otherwise = [head nonSkip] - -getAllMessages :: Handle -> IO [B.ByteString] -getAllMessages h = do - done <- hIsEOF h - if done - then return [] - else do - msg <- getNextMessage h - (msg :) <$> getAllMessages h - --- | Fetches the next message bytes based on --- the Content-Length header -getNextMessage :: Handle -> IO B.ByteString -getNextMessage h = do - headers <- getHeaders h - case read . init <$> lookup "Content-Length" headers of - Nothing -> error "Couldn't read Content-Length header" - Just size -> B.hGet h size - - -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 - 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 - -addHeader :: B.ByteString -> B.ByteString -addHeader content = B.concat - [ "Content-Length: " - , B.pack $ show $ B.length content - , "\r\n" - , "\r\n" - , content - ] - -getHeaders :: Handle -> IO [(String, String)] -getHeaders h = do - l <- hGetLine h - let (name, val) = span (/= ':') l - if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h +inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool + +inRightOrder _ [] = error "Why is this empty" +-- inRightOrder (LSP.NotificationMessage _ _ _) _ = True + +inRightOrder received (expected : msgs) + | received == expected = True + | isNotification expected = inRightOrder received msgs + | otherwise = False \ No newline at end of file