{-# 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 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.
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
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)
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?
then return []
else do
msg <- getNextMessage h
+
(msg :) <$> getAllMessages h
-- | Fetches the next message bytes based on
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
{
, 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"
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"
projects / lsp-test.git / blobdiff