From 0f8b9d328f4d950ff0a2e1c3b5aed593b21c2d3a Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 20 Jun 2018 23:39:10 +0100 Subject: [PATCH] Add SessionConfig Add timeouts Closes #8 --- haskell-lsp-test.cabal | 1 + src/Language/Haskell/LSP/Test.hs | 23 +++++--- src/Language/Haskell/LSP/Test/Compat.hs | 1 + src/Language/Haskell/LSP/Test/Exceptions.hs | 10 ++++ src/Language/Haskell/LSP/Test/Parsing.hs | 41 ++++++++------ src/Language/Haskell/LSP/Test/Replay.hs | 8 ++- src/Language/Haskell/LSP/Test/Session.hs | 63 ++++++++++++++------- test/ParsingTests.hs | 5 ++ test/Test.hs | 18 +++++- 9 files changed, 120 insertions(+), 50 deletions(-) create mode 100644 src/Language/Haskell/LSP/Test/Exceptions.hs diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index eef87c6..d6f8a4d 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -42,6 +42,7 @@ library build-depends: unix other-modules: Language.Haskell.LSP.Test.Compat Language.Haskell.LSP.Test.Decoding + Language.Haskell.LSP.Test.Exceptions Language.Haskell.LSP.Test.Files Language.Haskell.LSP.Test.Messages Language.Haskell.LSP.Test.Parsing diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index d3b1b65..8da170c 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -16,8 +16,12 @@ module Language.Haskell.LSP.Test -- * Sessions runSession , runSessionWithHandles - , runSessionWithCapabilities + , runSessionWithConfig , Session + , SessionConfig(..) + , MonadSessionConfig(..) + , SessionException(..) + , anySessionException -- * Sending , sendRequest , sendNotification @@ -74,12 +78,12 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Default import qualified Data.Map as Map import Data.Maybe -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types as LSP (error, id) -import Language.Haskell.LSP.TH.ClientCapabilities +import Language.Haskell.LSP.Types hiding (id, capabilities) +import qualified Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Test.Exceptions import Language.Haskell.LSP.Test.Parsing import Language.Haskell.LSP.Test.Session import Language.Haskell.LSP.Test.Server @@ -93,15 +97,15 @@ runSession :: String -- ^ The command to run the server. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a -runSession = runSessionWithCapabilities def +runSession = runSessionWithConfig def -- | Starts a new sesion with a client with the specified capabilities. -runSessionWithCapabilities :: ClientCapabilities -- ^ The capabilities the client should have. +runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should have. -> String -- ^ The command to run the server. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a -runSessionWithCapabilities caps serverExe rootDir session = do +runSessionWithConfig config serverExe rootDir session = do pid <- getProcessID absRootDir <- canonicalizePath rootDir @@ -109,10 +113,11 @@ runSessionWithCapabilities caps serverExe rootDir session = do (Just $ T.pack absRootDir) (Just $ filePathToUri absRootDir) Nothing - caps + (capabilities config) (Just TraceOff) - withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do + withServer serverExe $ \serverIn serverOut _ -> + runSessionWithHandles serverIn serverOut listenServer config rootDir $ do -- Wrap the session around initialize and shutdown calls sendRequest Initialize initializeParams diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs index e9b2c4c..2372b09 100644 --- a/src/Language/Haskell/LSP/Test/Compat.hs +++ b/src/Language/Haskell/LSP/Test/Compat.hs @@ -32,3 +32,4 @@ chanSource c = do x <- liftIO $ readChan c yield x chanSource c + \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs new file mode 100644 index 0000000..deea111 --- /dev/null +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -0,0 +1,10 @@ +module Language.Haskell.LSP.Test.Exceptions where + +import Control.Exception + +data SessionException = TimeoutException + deriving Show +instance Exception SessionException + +anySessionException :: SessionException -> Bool +anySessionException = const True \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 693c62e..9e6bdd5 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -5,39 +5,56 @@ module Language.Haskell.LSP.Test.Parsing where import Control.Applicative +import Control.Concurrent +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Conduit.Parser import Data.Maybe import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.Test.Exceptions import Language.Haskell.LSP.Test.Messages +import Language.Haskell.LSP.Test.Session + +satisfy :: (MonadIO m, MonadSessionConfig m) => (a -> Bool) -> ConduitParser a m a +satisfy pred = do + timeout <- timeout <$> lift sessionConfig + tId <- liftIO myThreadId + liftIO $ forkIO $ do + threadDelay (timeout * 1000000) + throwTo tId TimeoutException + x <- await + if pred x + then return x + else empty -- | Matches if the message is a notification. -anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage +anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage anyNotification = satisfy isServerNotification -notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) +notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) notification = do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a) x <- satisfy (isJust . parser) return $ decodeMsg $ encodeMsg x -- | Matches if the message is a request. -anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage +anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage anyRequest = satisfy isServerRequest -request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b) +request :: forall m a b. (MonadIO m, MonadSessionConfig m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b) request = do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b) x <- satisfy (isJust . parser) return $ decodeMsg $ encodeMsg x -- | Matches if the message is a response. -anyResponse :: Monad m => ConduitParser FromServerMessage m FromServerMessage +anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage anyResponse = satisfy isServerResponse -response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) +response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) response = do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) x <- satisfy (isJust . parser) @@ -53,7 +70,7 @@ decodeMsg x = fromMaybe (error $ "Unexpected message type\nGot:\n " ++ show x) (decode x) -- | Matches if the message is a log message notification or a show message notification/request. -loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage +loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage loggingNotification = satisfy shouldSkip where shouldSkip (NotLogMessage _) = True @@ -61,17 +78,9 @@ loggingNotification = satisfy shouldSkip shouldSkip (ReqShowMessage _) = True shouldSkip _ = False -publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification +publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification publishDiagnosticsNotification = do NotPublishDiagnostics diags <- satisfy test return diags where test (NotPublishDiagnostics _) = True test _ = False \ No newline at end of file - -satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a -satisfy pred = do - x <- await - if pred x - then return x - else empty - diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 0be0c54..1e36154 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -13,8 +13,9 @@ import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Text as T import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.Types as LSP hiding (error) import Data.Aeson +import Data.Default import Data.List import Data.Maybe import Control.Lens hiding (List) @@ -60,6 +61,7 @@ replaySession serverExe sessionDir = do runSessionWithHandles serverIn serverOut (listenServer serverMsgs requestMap reqSema rspSema passVar) + def sessionDir (sendMessages clientMsgs reqSema rspSema) @@ -207,9 +209,9 @@ swapCommands pid (FromClient t (ReqExecuteCommand req):xs) = FromClient t (ReqE swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs where swapped = case newCommands of - Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp + Just cmds -> result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp Nothing -> rsp - oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands + oldCommands = rsp ^? result . _Just . LSP.capabilities . executeCommandProvider . _Just . commands newCommands = fmap (fmap (swapPid pid)) oldCommands swapCommands pid (x:xs) = x:swapCommands pid xs diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 9868b5c..a427137 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,9 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} module Language.Haskell.LSP.Test.Session ( Session - , SessionState(..) + , SessionConfig(..) , SessionContext(..) + , SessionState(..) + , MonadSessionConfig(..) , runSessionWithHandles , get , put @@ -25,10 +28,12 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson import Data.Conduit import Data.Conduit.Parser +import Data.Default import Data.Foldable import Data.List import qualified Data.HashMap.Strict as HashMap import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.TH.ClientCapabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat @@ -36,6 +41,35 @@ import Language.Haskell.LSP.Test.Decoding import System.Directory import System.IO +-- | A session representing one instance of launching and connecting to a server. +-- +-- You can send and receive messages to the server within 'Session' via 'getMessage', +-- 'sendRequest' and 'sendNotification'. +-- +-- @ +-- runSession \"path\/to\/root\/dir\" $ do +-- docItem <- getDocItem "Desktop/simple.hs" "haskell" +-- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) +-- diagnostics <- getMessage :: Session PublishDiagnosticsNotification +-- @ +type Session = ParserStateReader FromServerMessage SessionState SessionContext IO + +-- | Stuff you can configure for a 'Session'. +data SessionConfig = SessionConfig + { + capabilities :: ClientCapabilities, -- ^ Specific capabilities the client should advertise. + timeout :: Int -- ^ Maximum time to wait for a request in seconds. + } + +instance Default SessionConfig where + def = SessionConfig def 60 + +class Monad m => MonadSessionConfig m where + sessionConfig :: m SessionConfig + +instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where + sessionConfig = config <$> lift Reader.ask + data SessionContext = SessionContext { serverIn :: Handle @@ -43,6 +77,7 @@ data SessionContext = SessionContext , messageChan :: Chan FromServerMessage , requestMap :: MVar RequestMap , initRsp :: MVar InitializeResponse + , config :: SessionConfig } data SessionState = SessionState @@ -53,23 +88,10 @@ data SessionState = SessionState type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) --- | A session representing one instance of launching and connecting to a server. --- --- You can send and receive messages to the server within 'Session' via 'getMessage', --- 'sendRequest' and 'sendNotification'. --- --- @ --- runSession \"path\/to\/root\/dir\" $ do --- docItem <- getDocItem "Desktop/simple.hs" "haskell" --- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) --- diagnostics <- getMessage :: Session PublishDiagnosticsNotification --- @ -type Session = ParserStateReader FromServerMessage SessionState SessionContext IO - type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) -runSession' :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession' chan preprocessor context state session = runReaderT (runStateT conduit state) context +runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser session get :: Monad m => ParserStateReader a s r m s @@ -89,10 +111,11 @@ ask = lift $ lift Reader.ask runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out -> (Handle -> Session ()) -- ^ Server listener + -> SessionConfig -> FilePath -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler rootDir session = do +runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do absRootDir <- canonicalizePath rootDir hSetBuffering serverIn NoBuffering @@ -103,11 +126,11 @@ runSessionWithHandles serverIn serverOut serverHandler rootDir session = do meaninglessChan <- newChan initRsp <- newEmptyMVar - let context = SessionContext serverIn absRootDir messageChan reqMap initRsp + let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config initState = SessionState (IdInt 0) mempty - threadId <- forkIO $ void $ runSession' meaninglessChan processor context initState (serverHandler serverOut) - (result, _) <- runSession' messageChan processor context initState session + threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut) + (result, _) <- runSession messageChan processor context initState session killThread threadId diff --git a/test/ParsingTests.hs b/test/ParsingTests.hs index 31bcfef..8676b2d 100644 --- a/test/ParsingTests.hs +++ b/test/ParsingTests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} module ParsingTests where import Control.Lens hiding (List) @@ -7,10 +8,14 @@ import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Data.Conduit import Data.Conduit.Parser +import Data.Default import Test.Hspec type TestSession = ConduitParser FromServerMessage IO +instance MonadSessionConfig IO where + sessionConfig = return def + parsingSpec :: Spec parsingSpec = describe "diagnostics" $ do diff --git a/test/Test.hs b/test/Test.hs index d83d03d..d9ecf21 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -7,13 +7,14 @@ import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HM import Data.Maybe +import Control.Concurrent import Control.Monad.IO.Class import Control.Lens hiding (List) import GHC.Generics import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Replay import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types hiding (capabilities) import ParsingTests main = hspec $ do @@ -51,7 +52,20 @@ main = hspec $ do let caps = def { _workspace = Just workspaceCaps } workspaceCaps = def { _didChangeConfiguration = Just configCaps } configCaps = DidChangeConfigurationClientCapabilities (Just True) - runSessionWithCapabilities caps "hie --lsp" "test/data/renamePass" $ return () + conf = def { capabilities = caps } + runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return () + + it "times out" $ + let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do + skipMany loggingNotification + _ <- request :: Session ApplyWorkspaceEditRequest + return () + in sesh `shouldThrow` anySessionException + + it "doesn't time out" $ runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do + loggingNotification + liftIO $ threadDelay 5 + describe "replay session" $ do it "passes a test" $ -- 2.30.2