X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=f856144caa2b268d9cd890be82d835385a3660d7;hb=2560f39d64911bc247fa479868052545dca4f827;hp=6ec19c2a0059a19430a802248f7e65f59c6c05ad;hpb=5e5c00290ef9cad30bfcebcd579047ed59d5cdae;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index 6ec19c2..f856144 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -1,44 +1,50 @@ {-# 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 ) 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 qualified Data.ByteString.Lazy.Char8 as B +import Data.List +import Language.Haskell.LSP.Capture +import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Core import qualified Language.Haskell.LSP.Types as LSP 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 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. + :: FilePath -- ^ The recorded session file. + -> FilePath -- ^ The root directory of the project -> IO Bool -replay cfp sfp = do +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", "-d"]) { 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 - -- todo: use qsem -- whether to send the next request reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp) -- whether to send the next response @@ -47,28 +53,22 @@ replay cfp sfp = do didPass <- newEmptyMVar - -- the recorded client input to the server - clientRecIn <- openFile cfp ReadMode - serverRecIn <- openFile sfp ReadMode - null <- openFile "/dev/null" WriteMode + entries <- B.lines <$> B.readFile sessionFp + + -- decode session + let unswappedEvents = map (fromJust . decode) entries + + events <- swapFiles curRootDir unswappedEvents - expectedMsgs <- getAllMessages serverRecIn + let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events + serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events -- listen to server - forkIO $ listenServer expectedMsgs serverOut semas didPass + forkIO $ runReaderT (listenServer serverEvents serverOut semas) didPass - -- start client replay - forkIO $ do - Control.runWithHandles clientRecIn - null - (const $ Right (), const $ return Nothing) - (handlers serverIn semas) - def - Nothing - Nothing + forM_ clientEvents (processClient serverIn) - -- todo: we shouldn't do this, we should check all notifications were delivered first - putMVar didPass True + print events result <- takeMVar didPass terminateProcess serverProc @@ -77,150 +77,64 @@ replay cfp sfp = do setCurrentDirectory prevDir return result - --- todo: Maybe make a reader monad and a fail function for it? -listenServer - :: [B.ByteString] - -> Handle - -> (MVar LSP.LspIdRsp, MVar LSP.LspId) - -> MVar Bool - -> IO () -listenServer [] _ _ passVar = putMVar passVar True -listenServer expectedMsgs h semas@(reqSema, rspSema) passVar = do - msg <- getNextMessage h - putStrLn $ "Remaining messages " ++ show (length expectedMsgs) - if inRightOrder msg expectedMsgs - then do - - whenResponse msg $ \res -> do - putStrLn $ "Got response for id " ++ show (res ^. LSP.id) - putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request - - whenRequest msg $ \req -> 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 - - whenNotification msg $ \n -> putStrLn $ "Got notification " ++ (show (n ^. LSP.method)) - - when (not (msg `elem` expectedMsgs)) $ do - putStrLn "Got an unexpected message" - putMVar passVar False - - listenServer (delete msg expectedMsgs) h semas passVar - else do - putStrLn $ "Got: " ++ show msg ++ "\n Expected: " ++ show - (head (filter (not . isNotification) expectedMsgs)) - putMVar passVar False - -isNotification :: B.ByteString -> Bool -isNotification msg = - isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value)) - -whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> IO ()) -> IO () -whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of - Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg') - _ -> return () - -whenRequest - :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO () -whenRequest msg = - forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value))) - -whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> IO ()) -> IO () -whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value))) - --- TODO: QuickCheck tests? --- | Checks wether or not the message appears in the right order --- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @ --- given N2, notification order doesn't matter. --- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @ --- given REQ1 --- @ N1 N3 N4 N5 REQ2 RES1 @ --- 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 - } + isClientMsg (FromClient _ _) = True + isClientMsg _ = False + + isServerMsg (FromServer _ _) = True + isServerMsg _ = False + +processEvent :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> Event -> IO () +processEvent serverH rspSema reqSema (FromClient _ msg) = processClient serverH rspSema reqSema msg +processEvent _ _ _ (FromServer _ msg) = processServer msg + +processClient + :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO () +processClient serverH rspSema reqSema msg = case msg 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 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 _ 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" + putStrLn + $ "Sent a request id " + ++ show id + ++ ": " + ++ show m + ++ "\nWaiting for a response" rspId <- takeMVar reqSema when (LSP.responseId id /= rspId) @@ -239,17 +153,112 @@ handlers serverH (reqSema, rspSema) = def 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 +-- | 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 -> (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 + + listenServer newExpectedMsgs h semas + + where response :: LSP.ResponseMessage a -> Session [FromServerMessage] + response res = do + lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id) + + lift $ print res + + checkOrder res + + lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request + + markReceived res + + request :: LSP.RequestMessage LSP.ServerMethod a b -> Session [FromServerMessage] + request req = do + lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method) + + lift $ print req + + checkOrder req + + lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response + + markReceived req + + notification :: LSP.NotificationMessage LSP.ServerMethod a -> Session [FromServerMessage] + notification n = do + lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) + lift $ print n + + lift $ putStrLn $ show (length (filter isNotification expectedMsgs) - 1) ++ " notifications remaining" + + if n ^. LSP.method == LSP.WindowLogMessage + then return expectedMsgs + else markReceived n + + 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") + + markReceived :: Eq a => a -> [FromServerMessage] -> Session [FromServerMessage] + markReceived msg = + -- TODO: Find some way of equating FromServerMessage and LSP.ResponseMessage etc. + 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 +-- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @ +-- given N2, notification order doesn't matter. +-- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @ +-- given REQ1 +-- @ N1 N3 N4 N5 REQ2 RES1 @ +-- 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 _ [] = error "Why is this empty" +-- inRightOrder (LSP.NotificationMessage _ _ _) _ = True + +inRightOrder received (expected:msgs) + | Just received == decode expected = True + | isNotification expected = inRightOrder received msgs + | otherwise = False \ No newline at end of file