-- | 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
+ ( replaySession
)
where
+import Prelude hiding (id)
import Control.Concurrent
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Reader
-import Data.Default
+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 Language.Haskell.LSP.Core
-import qualified Language.Haskell.LSP.Types as LSP
+import Language.Haskell.LSP.Types hiding (error)
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 System.FilePath
+import Language.Haskell.LSP.Test
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 recorded session file.
- -> FilePath -- ^ The root directory of the project
+replaySession :: FilePath -- ^ The recorded session directory.
-> IO Bool
-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"]) { std_in = CreatePipe , std_out = CreatePipe }
+replaySession sessionDir = do
- hSetBuffering serverIn NoBuffering
- hSetBuffering serverOut NoBuffering
-
- -- 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
-
- entries <- B.lines <$> B.readFile sessionFp
+ entries <- B.lines <$> B.readFile (sessionDir </> "session.log")
-- decode session
let unswappedEvents = map (fromJust . decode) entries
- events <- swapFiles curRootDir unswappedEvents
-
- let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
- serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
+ events <- swapFiles sessionDir unswappedEvents
- -- listen to server
- forkIO $ runReaderT (listenServer serverEvents serverOut semas) didPass
+ let clientEvents = filter isClientMsg events
+ serverEvents = filter isServerMsg events
+ clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents
+ serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents
+ requestMap = getRequestMap clientMsgs
- forM_ clientEvents (processClient serverIn)
- print events
+ reqSema <- newEmptyMVar
+ rspSema <- newEmptyMVar
+ passVar <- newEmptyMVar :: IO (MVar Bool)
- result <- takeMVar didPass
- terminateProcess serverProc
+ forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) sessionDir $
+ sendMessages clientMsgs reqSema rspSema
- -- restore directory
- setCurrentDirectory prevDir
+ takeMVar passVar
- return result
where
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
+sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()
+sendMessages [] _ _ = return ()
+sendMessages (nextMsg:remainingMsgs) reqSema rspSema =
+ case nextMsg of
ReqInitialize m -> request m
ReqShutdown m -> request m
ReqHover m -> request m
ReqDocumentLink m -> request m
ReqDocumentLinkResolve m -> request m
ReqWillSaveWaitUntil m -> request m
+ RspApplyWorkspaceEdit m -> response m
+ RspFromClient m -> response m
+ NotInitialized m -> notification m
+ NotExit m -> notification m
+ NotCancelRequestFromClient m -> notification m
+ NotDidChangeConfiguration m -> notification m
+ NotDidOpenTextDocument m -> notification m
+ NotDidChangeTextDocument m -> notification m
+ NotDidCloseTextDocument m -> notification m
+ NotWillSaveTextDocument m -> notification m
+ NotDidSaveTextDocument m -> notification m
+ NotDidChangeWatchedFiles m -> notification m
+ UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show 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 _ 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
- 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"
- reqId <- takeMVar rspSema
- if LSP.responseId reqId /= id
- then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
- else do
- B.hPut serverH $ 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
-
-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)
+ notification msg@(NotificationMessage _ Exit _) = do
+ liftIO $ putStrLn "Will send exit notification soon"
+ liftIO $ threadDelay 10000000
+ sendNotification' msg
- lift $ print res
+ liftIO $ error "Done"
- 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)
+ notification msg@(NotificationMessage _ m _) = do
+ sendNotification' msg
- lift $ print req
+ liftIO $ putStrLn $ "Sent a notification " ++ show m
- checkOrder req
+ sendMessages remainingMsgs reqSema rspSema
- lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
+ request msg@(RequestMessage _ id m _) = do
+ sendRequest' msg
+ liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"
- markReceived req
+ rsp <- liftIO $ takeMVar rspSema
+ when (responseId id /= rsp) $
+ error $ "Expected id " ++ show id ++ ", got " ++ show rsp
- notification :: LSP.NotificationMessage LSP.ServerMethod a -> Session [FromServerMessage]
- notification n = do
- lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
- lift $ print n
+ sendMessages remainingMsgs reqSema rspSema
- 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")
+ response msg@(ResponseMessage _ id _ _) = do
+ liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
+ reqId <- liftIO $ takeMVar reqSema
+ if responseId reqId /= id
+ then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
+ else do
+ sendResponse' msg
+ liftIO $ putStrLn $ "Sent response to request id " ++ show id
- 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
+ sendMessages remainingMsgs reqSema rspSema
- firstExpected = head $ filter (not . isNotification) expectedMsgs
isNotification :: FromServerMessage -> Bool
isNotification (NotPublishDiagnostics _) = True
isNotification (NotCancelRequestFromServer _) = True
isNotification _ = False
+listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session ()
+listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True
+listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do
+ msgBytes <- liftIO $ getNextMessage serverOut
+ let msg = decodeFromServerMsg reqMap msgBytes
+
+ 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
+
+ if shouldSkip msg
+ then listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut
+ else if inRightOrder msg expectedMsgs
+ then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut
+ else liftIO $ do
+ putStrLn "Out of order"
+ putStrLn "Got:"
+ print msg
+ putStrLn "Expected one of:"
+ mapM_ print $ takeWhile (not . isNotification) expectedMsgs
+ print $ head $ dropWhile (not . isNotification) expectedMsgs
+ putMVar passVar False
+
+ where
+ response :: Show a => ResponseMessage a -> Session ()
+ response res = do
+ liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
+
+ liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
+
+ request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session ()
+ request req = do
+ liftIO
+ $ putStrLn
+ $ "Got request for id "
+ ++ show (req ^. id)
+ ++ " "
+ ++ show (req ^. method)
+
+ liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
+
+ notification :: Show a => NotificationMessage ServerMethod a -> Session ()
+ notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
+
+
+
-- TODO: QuickCheck tests?
-- | Checks wether or not the message appears in the right order
-- @ N1 N2 N3 REQ1 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 :: FromServerMessage -> [FromServerMessage] -> Bool
inRightOrder _ [] = error "Why is this empty"
--- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
inRightOrder received (expected : msgs)
- | Just received == decode expected = True
+ | received == expected = True
| isNotification expected = inRightOrder received msgs
| otherwise = False
+
+-- | Ignore logging notifications since they vary from session to session
+shouldSkip :: FromServerMessage -> Bool
+shouldSkip (NotLogMessage _) = True
+shouldSkip (NotShowMessage _) = True
+shouldSkip (ReqShowMessage _) = True
+shouldSkip _ = False
projects / opengl.git / blobdiff