X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FRecorded.hs;h=488499ac1bee9c2cf9494ae9eb4cb04490b74057;hb=e728814eed6134acf8281a1ad08eecaf438a736a;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..488499a 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -1,10 +1,15 @@ {-# 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 @@ -18,6 +23,7 @@ import Control.Monad import System.IO import System.Directory import System.Process +import Language.Haskell.LSP.Test.Files -- | Replays a recorded client output and -- makes sure it matches up with an expected response. @@ -31,14 +37,11 @@ replay cfp sfp = do 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 @@ -52,14 +55,23 @@ replay cfp sfp = do serverRecIn <- openFile sfp ReadMode null <- openFile "/dev/null" WriteMode - expectedMsgs <- getAllMessages serverRecIn + + (clientMsgs, fileMap) <- loadSwappedFiles emptyFileMap clientRecIn + + tmpDir <- getTemporaryDirectory + (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped" + mapM_ (B.hPut mappedClientRecIn) $ map addHeader clientMsgs + hSeek mappedClientRecIn AbsoluteSeek 0 + + + (expectedMsgs, _) <- loadSwappedFiles fileMap serverRecIn -- listen to server - forkIO $ listenServer expectedMsgs serverOut semas didPass + forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass -- start client replay forkIO $ do - Control.runWithHandles clientRecIn + Control.runWithHandles mappedClientRecIn null (const $ Right (), const $ return Nothing) (handlers serverIn semas) @@ -78,55 +90,63 @@ replay cfp sfp = do 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) +-- | 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) if inRightOrder msg expectedMsgs then do - whenResponse msg $ \res -> do + 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 - whenRequest msg $ \req -> do + 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 - whenNotification msg $ \n -> putStrLn $ "Got notification " ++ (show (n ^. LSP.method)) + whenNotification msg $ \n -> lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) - when (not (msg `elem` expectedMsgs)) $ do - putStrLn "Got an unexpected message" - putMVar passVar False + unless (msg `elem` expectedMsgs) $ failSession "Got an unexpected message" - listenServer (delete msg expectedMsgs) h semas passVar - else do - putStrLn $ "Got: " ++ show msg ++ "\n Expected: " ++ show - (head (filter (not . isNotification) expectedMsgs)) - putMVar passVar False + listenServer (delete msg expectedMsgs) h semas + else + let reason = "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs)) + in failSession reason isNotification :: B.ByteString -> Bool isNotification msg = isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value)) -whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> IO ()) -> IO () +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 () whenRequest - :: B.ByteString -> (LSP.RequestMessage Value Value Value -> IO ()) -> IO () + :: 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 -> IO ()) -> IO () +whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> Session ()) -> Session () whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value))) -- TODO: QuickCheck tests? @@ -157,6 +177,7 @@ getAllMessages h = do then return [] else do msg <- getNextMessage h + (msg :) <$> getAllMessages h -- | Fetches the next message bytes based on @@ -168,7 +189,6 @@ getNextMessage h = do 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 { @@ -208,6 +228,7 @@ handlers serverH (reqSema, rspSema) = def , 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" @@ -219,6 +240,9 @@ handlers serverH (reqSema, rspSema) = def 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"