-- | 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
+ ( replay,
+ sendNextRequest
)
where
import Control.Concurrent
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as B
-import Data.List
import Language.Haskell.LSP.Capture
import Language.Haskell.LSP.Messages
import qualified Language.Haskell.LSP.Types as LSP
import Control.Monad
import System.IO
import System.Directory
+import System.FilePath
import System.Process
import Language.Haskell.LSP.Test.Files
import Language.Haskell.LSP.Test.Parsing
+data SessionContext = SessionContext
+ {
+ reqSema :: MVar LSP.LspId,
+ rspSema :: MVar LSP.LspIdRsp,
+ serverIn :: Handle
+ }
+type Session = StateT [FromClientMessage] (ReaderT SessionContext IO)
+
-- | Replays a recorded client output and
-- makes sure it matches up with an expected response.
-replay
- :: FilePath -- ^ The recorded session file.
- -> FilePath -- ^ The root directory of the project
- -> IO Bool
-replay sessionFp curRootDir = do
+replay :: FilePath -- ^ The recorded session directory.
+ -> Session a
+ -> IO ()
+replay sessionDir session = do
+
+ let sessionFp = sessionDir </> "session.log"
-- need to keep hold of current directory since haskell-lsp changes it
- prevDir <- getCurrentDirectory
+ prevRootDir <- getCurrentDirectory
(Just serverIn, Just serverOut, _, serverProc) <- createProcess
(proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe
rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
let semas = (reqSema, rspSema)
- didPass <- newEmptyMVar
-
entries <- B.lines <$> B.readFile sessionFp
-- decode session
let unswappedEvents = map (fromJust . decode) entries
- events <- swapFiles curRootDir unswappedEvents
+ events <- swapFiles sessionDir unswappedEvents
- let clientEvents =
- map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
- serverEvents =
- map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
+ let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
requestMap = getRequestMap clientEvents
-- listen to server
- forkIO $ runReaderT (listenServer serverEvents serverOut requestMap semas)
- didPass
+ forkIO $ listenServer serverOut requestMap semas
- forM_ clientEvents (processClient serverIn rspSema reqSema)
+ runReaderT (runStateT session clientEvents) (SessionContext rspSema reqSema serverIn)
- result <- takeMVar didPass
terminateProcess serverProc
-- restore directory
- setCurrentDirectory prevDir
+ setCurrentDirectory prevRootDir
- return result
where
isClientMsg (FromClient _ _) = True
isClientMsg _ = False
isServerMsg (FromServer _ _) = True
isServerMsg _ = False
-processClient
- :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO ()
-processClient serverH rspSema reqSema msg = case msg of
+sendNextRequest :: Session ()
+sendNextRequest = do
+ (nextMsg:remainingMsgs) <- get
+ put remainingMsgs
+ case nextMsg of
ReqInitialize m -> request m
ReqShutdown m -> request m
ReqHover m -> request m
where
-- TODO: May need to prevent premature exit notification being sent
notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
+ context <- lift ask
+
+ liftIO $ do
putStrLn "Will send exit notification soon"
threadDelay 10000000
- B.hPut serverH $ addHeader (encode msg)
+ B.hPut (serverIn context) $ addHeader (encode msg)
+
notification msg@(LSP.NotificationMessage _ m _) = do
- B.hPut serverH $ addHeader (encode msg)
+ context <- lift ask
+
+ liftIO $ B.hPut (serverIn context) $ addHeader (encode msg)
- putStrLn $ "Sent a notification " ++ show m
+ liftIO $ putStrLn $ "Sent a notification " ++ show m
+
+ sendNextRequest
request msg@(LSP.RequestMessage _ id m _) = do
+ context <- lift ask
+ liftIO $ 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
- when (LSP.responseId id /= rspId)
- $ error
- $ "Expected id "
- ++ show id
- ++ ", got "
- ++ show rspId
+ B.hPut (serverIn context) $ addHeader (encode msg)
+ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
+
+ rspId <- takeMVar (rspSema context)
+ when (LSP.responseId id /= rspId) $
+ error $ "Expected id " ++ show id ++ ", got " ++ show rspId
response msg@(LSP.ResponseMessage _ id _ _) = do
+ context <- lift ask
+
+ liftIO $ do
putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
- reqId <- takeMVar rspSema
+ reqId <- takeMVar (reqSema context)
if LSP.responseId reqId /= id
then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
else do
- B.hPut serverH $ addHeader (encode msg)
+ B.hPut (serverIn context) $ addHeader (encode msg)
putStrLn $ "Sent response to request id " ++ show id
--- | 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
+ sendNextRequest
-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
- -> RequestMap
- -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
- -> Session ()
-listenServer [] _ _ _ = passSession
-listenServer expectedMsgs h reqMap semas@(reqSema, rspSema) = do
- msgBytes <- lift $ getNextMessage h
-
- let actualMsg = decodeFromServerMsg reqMap msgBytes
-
- lift $ print actualMsg
-
- newExpectedMsgs <- case actualMsg of
- ReqRegisterCapability m -> request actualMsg m
- ReqApplyWorkspaceEdit m -> request actualMsg m
- ReqShowMessage m -> request actualMsg m
- ReqUnregisterCapability m -> request actualMsg m
- RspInitialize m -> response actualMsg m
- RspShutdown m -> response actualMsg m
- RspHover m -> response actualMsg m
- RspCompletion m -> response actualMsg m
- RspCompletionItemResolve m -> response actualMsg m
- RspSignatureHelp m -> response actualMsg m
- RspDefinition m -> response actualMsg m
- RspFindReferences m -> response actualMsg m
- RspDocumentHighlights m -> response actualMsg m
- RspDocumentSymbols m -> response actualMsg m
- RspWorkspaceSymbols m -> response actualMsg m
- RspCodeAction m -> response actualMsg m
- RspCodeLens m -> response actualMsg m
- RspCodeLensResolve m -> response actualMsg m
- RspDocumentFormatting m -> response actualMsg m
- RspDocumentRangeFormatting m -> response actualMsg m
- RspDocumentOnTypeFormatting m -> response actualMsg m
- RspRename m -> response actualMsg m
- RspExecuteCommand m -> response actualMsg m
- RspError m -> response actualMsg m
- RspDocumentLink m -> response actualMsg m
- RspDocumentLinkResolve m -> response actualMsg m
- RspWillSaveWaitUntil m -> response actualMsg m
- NotPublishDiagnostics m -> notification actualMsg m
- NotLogMessage m -> notification actualMsg m
- NotShowMessage m -> notification actualMsg m
- NotTelemetry m -> notification actualMsg m
- NotCancelRequestFromServer m -> notification actualMsg m
-
- listenServer newExpectedMsgs h reqMap semas
+listenServer :: Handle -> RequestMap -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO ()
+listenServer h reqMap semas@(reqSema, rspSema) = do
+ msgBytes <- getNextMessage h
+
+ let msg = decodeFromServerMsg reqMap msgBytes
+
+ print msg
+
+ 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
+
+ listenServer h reqMap semas
+
where
- response
- :: Show a
- => FromServerMessage
- -> LSP.ResponseMessage a
- -> Session [FromServerMessage]
- response msg res = do
- lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
-
- lift $ print res
-
- checkOrder msg
-
- lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
-
- markReceived msg
-
- request
- :: (Show a, Show b)
- => FromServerMessage
- -> LSP.RequestMessage LSP.ServerMethod a b
- -> Session [FromServerMessage]
- request msg req = do
- lift
- $ putStrLn
+ response :: Show a => LSP.ResponseMessage a -> IO ()
+ response res = do
+ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
+
+ print res
+
+ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
+
+ request :: Show a => LSP.RequestMessage LSP.ServerMethod a b -> IO ()
+ request req = do
+ putStrLn
$ "Got request for id "
++ show (req ^. LSP.id)
++ " "
++ show (req ^. LSP.method)
- lift $ print req
+ print req
- checkOrder msg
+ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
- lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
+ notification :: Show a => LSP.NotificationMessage LSP.ServerMethod a -> IO ()
+ notification n = do
+ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
+ print n
- markReceived msg
+ -- lift
+ -- $ putStrLn
+ -- $ show (length (filter isNotification expectedMsgs) - 1)
+ -- ++ " notifications remaining"
- notification
- :: Show a
- => FromServerMessage
- -> LSP.NotificationMessage LSP.ServerMethod a
- -> Session [FromServerMessage]
- notification msg n = do
- lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
- lift $ print n
+ -- checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
+ -- ( "Out of order\nExpected\n"
+ -- ++ show firstExpected
+ -- ++ "\nGot\n"
+ -- ++ show msg
+ -- ++ "\n"
+ -- )
- lift
- $ putStrLn
- $ show (length (filter isNotification expectedMsgs) - 1)
- ++ " notifications remaining"
+ -- markReceived :: FromServerMessage -> Session [FromServerMessage]
+ -- markReceived msg =
+ -- let new = delete msg expectedMsgs
+ -- in if new == expectedMsgs
+ -- then failSession ("Unexpected message: " ++ show msg) >> return new
+ -- else return new
- if n ^. LSP.method == LSP.WindowLogMessage
- then return expectedMsgs
- else markReceived msg
-
- checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
- ( "Out of order\nExpected\n"
- ++ show firstExpected
- ++ "\nGot\n"
- ++ show msg
- ++ "\n"
- )
-
- markReceived :: FromServerMessage -> Session [FromServerMessage]
- markReceived msg =
- 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
+ -- firstExpected = head $ filter (not . isNotification) expectedMsgs
isNotification :: FromServerMessage -> Bool
isNotification (NotPublishDiagnostics _) = True
| received == expected = True
| isNotification expected = inRightOrder received msgs
| otherwise = False
+
+-- | 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
\ No newline at end of file