Add SessionConfig

Add timeouts
Closes #8

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index eef87c601a08b41cd0cff95414727d39ff648a40..d6f8a4d41f7f609648c91165ec869127aa80dc2b 100644 (file)
--- 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 d3b1b65e4c5a7b9c2e9e5190897852e87a2ec018..8da170c0d4fe6e984e2d21ffcd05dab6a79cfbc3 100644 (file)
--- 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 e9b2c4c8f2fd7e645b9bf08f5bd0ac4c2bd46e98..2372b09eabdb70e20fb25024eb244bc898f134d1 100644 (file)
--- 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 (file)
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 693c62e9aab0670e83001003803d72798cb2ec1f..9e6bdd5c5739f07b9b8590598fe2a1c08cfcae86 100644 (file)
--- 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 0be0c54d3736d4e90d920271af8125a4107f327b..1e361542b71f39b1356491b2232f1f119e072165 100644 (file)
--- 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 9868b5c029a6f7a6d823c3b2522fc604f5376049..a427137825c7978ad8ba891c406848f66288e2eb 100644 (file)
--- 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 31bcfefd7a882c1620cc4d71fed58e7c4702c191..8676b2d6874fbdaf196cb4728dbfef422f8b6e25 100644 (file)
--- 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 d83d03d5082b2cc138b2ea9bcfb86b984954cdfd..d9ecf219e7779794e39bb2fa053f264e186b704a 100644 (file)
--- 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" $