X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=c92664c977deb811361f206dff29e37fe4e023d0;hb=6930c3cb143fb7aca3f14ea865052ab79c386684;hp=d109d9a74a9140abfec989b20120b5105db3c21e;hpb=092af98d24a00b540c3370774ebaa33161e98f3b;p=lsp-test.git diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index d109d9a..c92664c 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -1,111 +1,182 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +-- | 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 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. +replay + :: FilePath -- ^ The client output to replay to the server. -> FilePath -- ^ The expected response from the server. - -> IO Int -replay cfp sfp = do + -> FilePath -- ^ The root directory of the project + -> IO Bool +replay cfp sfp curRootDir = do - (Just serverIn, Just serverOut, _, _) <- createProcess - (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in = CreatePipe - , std_out = CreatePipe - } + -- 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 } 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 + unswappedClientMsgs <- getAllMessages clientRecIn - -- listen to server - forkIO $ listenServer expectedMsgs serverOut semas + let recRootDir = rootDir unswappedClientMsgs + + (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs - -- send initialize request ourselves since haskell-lsp consumes it - -- rest are handled via `handlers` - sendInitialize clientRecIn serverIn + tmpDir <- getTemporaryDirectory + (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped" + mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs + hSeek mappedClientRecIn AbsoluteSeek 0 - -- wait for initialize response - putStrLn "Waiting for initialzie response" - takeMVar reqSema - putStrLn "Got initialize response" + (expectedMsgs, _) <- swapFiles fileMap recRootDir curRootDir =<< getAllMessages serverRecIn - Control.runWithHandles clientRecIn + -- 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 - where - listenServer :: [B.ByteString] -> Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO () + + -- 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 <- getNextMessage h - putStrLn $ "Remaining messages " ++ show (length expectedMsgs) - if inRightOrder msg expectedMsgs - then do - - -- if we got a request response unblock the replay waiting for a response - whenResponse msg $ \res -> do - putStrLn ("Got response for id " ++ show (res ^. LSP.id)) - putMVar reqSema (res ^. LSP.id) - - whenRequest msg $ \req -> do - putStrLn ("Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)) - putMVar rspSema (req ^. LSP.id) - - listenServer (delete msg expectedMsgs) h semas - else error $ "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs)) - - sendInitialize recH serverH = do - message <- getNextMessage recH - B.hPut serverH (addHeader message) - putStrLn $ "Sent initialize response " ++ show message - -- bring the file back to the start for haskell-lsp - hSeek recH AbsoluteSeek 0 + msg <- lift $ getNextMessage h -isNotification :: B.ByteString -> Bool -isNotification msg = isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value)) + 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 jsonEqual :: (FromJSON a, Eq a) => a -> B.ByteString -> Bool + jsonEqual x y = Just x == decode y + + deleteFirstJson _ [] = [] + deleteFirstJson msg (x:xs) + | jsonEqual msg x = xs + | otherwise = x:deleteFirstJson msg xs -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 () + -- firstExpected :: Show a => a + firstExpected = head $ filter (not . isNotification) expectedMsgs -whenRequest :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO () -whenRequest msg = forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value))) + response :: LSP.ResponseMessage Value -> Session [B.ByteString] + 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 + + return $ deleteFirstJson res expectedMsgs + + 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) + + lift $ print req + + checkOrder req + + lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response + + return $ deleteFirstJson req expectedMsgs + + notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString] + notification n = do + lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) + lift $ print n + return $ deleteFirstJson n expectedMsgs + + checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do + let expected = decode firstExpected + _ = expected == Just msg -- make expected type same as res + failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n") + + +isNotification :: B.ByteString -> Bool +isNotification msg = + isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value)) -- TODO: QuickCheck tests? -- | Checks wether or not the message appears in the right order @@ -117,34 +188,15 @@ whenRequest msg = forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Va -- 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 +inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool + +inRightOrder _ [] = error "Why is this empty" +-- inRightOrder (LSP.NotificationMessage _ _ _) _ = True --- | 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 +inRightOrder received (expected:msgs) + | Just received == decode expected = True + | isNotification expected = inRightOrder received msgs + | otherwise = False handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers @@ -170,6 +222,7 @@ handlers serverH (reqSema, rspSema) = def , documentLinkHandler = Just request , documentLinkResolveHandler = Just request , executeCommandHandler = Just request + , initializeRequestHandler = Just request -- Notifications , didChangeConfigurationParamsHandler = Just notification , didOpenTextDocumentNotificationHandler = Just notification @@ -180,23 +233,36 @@ handlers serverH (reqSema, rspSema) = def , initializedHandler = Just notification , willSaveTextDocumentNotificationHandler = Just notification , cancelNotificationHandler = Just notification + , exitNotificationHandler = Just notification -- Responses , responseHandler = Just response } where - notification m = do - B.hPut serverH $ addHeader (encode m) - putStrLn "Sent a notification" + + -- 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 - if LSP.responseId id /= rspId - then error $ "Expected id " ++ show id ++ ", got " ++ show rspId - else putStrLn $ "Got a response for request id " ++ show id ++ ": " ++ show m + 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" @@ -206,18 +272,3 @@ handlers serverH (reqSema, rspSema) = def 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