From 1f4a12c49be0cb8640d60c21f6499c5567646fba Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 5 Jun 2018 10:10:03 -0400 Subject: [PATCH] Start work adding the session monad for replays --- .travis.yml | 2 +- dist/cabal-config-flags | Bin 125 -> 0 bytes example/Main.hs | 2 +- example/Recorded.hs | 10 +- src/Language/Haskell/LSP/Test.hs | 8 +- src/Language/Haskell/LSP/Test/Recorded.hs | 317 ++++++++++------------ stack.yaml | 2 +- test/Test.hs | 38 +-- 8 files changed, 174 insertions(+), 205 deletions(-) delete mode 100644 dist/cabal-config-flags diff --git a/.travis.yml b/.travis.yml index 729bd20..013f95c 100644 --- a/.travis.yml +++ b/.travis.yml @@ -16,7 +16,7 @@ before_install: install: - git clone https://github.com/Bubba/haskell-ide-engine.git --recursive - cd haskell-ide-engine - - git checkout 377157dad7641c2c63e8b554a46a4888dca48721 + - git checkout d4fe878a545c2d1b9247c1ddf5e6174eeed066cb - stack --no-terminal --skip-ghc-check install -j1 - stack exec hoogle generate - cd .. diff --git a/dist/cabal-config-flags b/dist/cabal-config-flags deleted file mode 100644 index 7c101f6fae94a20e82804b64d3d4523d73b15e0e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 125 zcmZvVQ4WA03`4!pBp!fccz}Tuh*QV__4v;C>rb1sFD<}H;<B4FDl})grW}+nTwO tRKtBEGkSE$+I7v;=x%}v<^Tm-{9%nthk{pX@tw8bbj_@PcF#*^lm{f#Dpvpi diff --git a/example/Main.hs b/example/Main.hs index 8080991..4dd268c 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -9,7 +9,7 @@ import System.Environment main = do files <- getArgs - forM_ files $ \fp -> session $ do + forM_ files $ \fp -> manualSession $ do file <- liftIO $ canonicalizePath fp openDocument file symbols <- documentSymbols file diff --git a/example/Recorded.hs b/example/Recorded.hs index ce61cb1..5d7cac1 100644 --- a/example/Recorded.hs +++ b/example/Recorded.hs @@ -1,8 +1,12 @@ import Language.Haskell.LSP.Test.Recorded import System.Directory import System.Environment +import Control.Monad.IO.Class main = do - [session, dir] <- (take 2 <$> getArgs) >>= mapM canonicalizePath - passed <- replay session dir - putStrLn $ if passed then "Passed" else "Failed" + sessionFile <- (head <$> getArgs) >>= canonicalizePath + replay sessionFile $ do + x <- sendNextRequest + liftIO $ print x + y <- sendNextRequest + liftIO $ print y \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 6ee8405..5883271 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -2,7 +2,7 @@ module Language.Haskell.LSP.Test ( -- * Sessions - session + manualSession -- * Documents , openDocument , documentSymbols @@ -17,14 +17,16 @@ import Data.Maybe import Data.Proxy import System.Process import qualified Language.Haskell.LSP.Client as Client +import Language.Haskell.LSP.Messages import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP +import Language.Haskell.LSP.Test.Recorded import Capabilities import Compat type Session = ReaderT Client.Client IO -session :: Session a -> IO () -session f = do +manualSession :: Session a -> IO () +manualSession f = do (Just hin, Just hout, _, serverProc) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe, std_out = CreatePipe } client <- Client.start $ Client.Config hin hout notificationHandler requestHandler diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index 36a55fa..9c89a78 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -4,15 +4,17 @@ -- | 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 @@ -22,20 +24,30 @@ import Control.Lens 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 @@ -51,34 +63,26 @@ replay sessionFp curRootDir = do 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 @@ -86,9 +90,11 @@ replay sessionFp curRootDir = do 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 @@ -128,182 +134,143 @@ processClient serverH rspSema reqSema msg = case msg of 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 @@ -331,3 +298,19 @@ inRightOrder received (expected : msgs) | 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 diff --git a/stack.yaml b/stack.yaml index 35cf5b1..8de2811 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2018-05-30 +resolver: nightly-2018-06-02 packages: - . diff --git a/test/Test.hs b/test/Test.hs index 3fd14e4..7c7f272 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -2,37 +2,17 @@ import Test.Hspec import System.IO import System.Directory import Control.Lens +import Control.Monad.IO.Class import Language.Haskell.LSP.Test.Recorded -- import Language.Haskell.LSP.Test.Parsing -- import Language.Haskell.LSP.Test.Files import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP -main = hspec $ do - describe "Replay" $ do - it "passes a test" $ - replay "test/recordings/renamePass/client.log" - "test/recordings/renamePass/server.log" - "test/recordings/renamePass" - `shouldReturn` True - it "fails a test" $ - replay "test/recordings/documentSymbolFail/client.log" - "test/recordings/documentSymbolFail/server.log" - "test/recordings/documentSymbolFail" - `shouldReturn` False - - -- describe "file swapping" $ do - -- it "gets the base directory" $ do - -- h <- openFile "test/recordings/renamePass/client.log" ReadMode - -- msgs <- getAllMessages h - -- rootDir msgs `shouldBe` "/Users/luke/Desktop" - - -- it "gets builds a mapping of files" $ do - -- h <- openFile "test/recordings/renamePass/client.log" ReadMode - -- msgs <- getAllMessages h - -- let root = rootDir msgs - -- swapped <- swapFiles root "test/recordings/renamePass/" msgs - -- let (Just n) = decode (swapped !! 3) :: Maybe LSP.DidOpenNotification - - -- cd <- getCurrentDirectory - - -- n .^ params . uri `shouldBe` LSP.uriFromFilePath (cd "test/recordings/renamePass/") +main = hspec $ + describe "replay" $ + it "passes a replay" $ + replaySession "test/recordings/renamePass" $ do + x <- sendNextRequest + liftIO $ print x + y <- sendNextRequest + liftIO $ print y \ No newline at end of file -- 2.30.2