From: Luke Lau Date: Mon, 9 Jul 2018 00:27:48 +0000 (+0100) Subject: Merge branch 'master' into script-fsm X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=fbb260c6078a39ff071fefd6586af18715b3e6a3;hp=54b23e6b7a8aa59e649a807ab286f0808908935a Merge branch 'master' into script-fsm --- diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 7deb60e..c5d1391 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -114,7 +114,6 @@ test-suite tests , aeson , unordered-containers , text - other-modules: ParsingTests default-language: Haskell2010 executable lsp-test-example diff --git a/lib/Language/Haskell/LSP/Test.hs b/lib/Language/Haskell/LSP/Test.hs index 6c2c052..eda3cd2 100644 --- a/lib/Language/Haskell/LSP/Test.hs +++ b/lib/Language/Haskell/LSP/Test.hs @@ -19,9 +19,9 @@ module Language.Haskell.LSP.Test , runSessionWithConfig , Session , SessionConfig(..) - , MonadSessionConfig(..) , SessionException(..) , anySessionException + , withTimeout -- * Sending , sendRequest , sendRequest_ @@ -31,12 +31,10 @@ module Language.Haskell.LSP.Test , sendNotification' , sendResponse -- * Receving + , message , anyRequest - , request , anyResponse - , response , anyNotification - , notification , anyMessage , loggingNotification , publishDiagnosticsNotification @@ -94,7 +92,7 @@ import Data.Default import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe -import Language.Haskell.LSP.Types hiding (id, capabilities) +import Language.Haskell.LSP.Types hiding (id, capabilities, message) import qualified Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.VFS @@ -151,20 +149,19 @@ runSessionWithConfig config serverExe rootDir session = do sendNotification Exit ExitParams return result - + where -- | Listens to the server output, makes sure it matches the record and -- signals any semaphores -listenServer :: Handle -> Session () -listenServer serverOut = do - msgBytes <- liftIO $ getNextMessage serverOut + listenServer :: Handle -> SessionContext -> IO () + listenServer serverOut context = do + msgBytes <- getNextMessage serverOut - context <- ask - reqMap <- liftIO $ readMVar $ requestMap context + reqMap <- readMVar $ requestMap context let msg = decodeFromServerMsg reqMap msgBytes - liftIO $ writeChan (messageChan context) msg + writeChan (messageChan context) (ServerMessage msg) - listenServer serverOut + listenServer serverOut context -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text @@ -177,7 +174,7 @@ documentContents doc = do -- and returns the new content getDocumentEdit :: TextDocumentIdentifier -> Session T.Text getDocumentEdit doc = do - req <- request :: Session ApplyWorkspaceEditRequest + req <- message :: Session ApplyWorkspaceEditRequest unless (checkDocumentChanges req || checkChanges req) $ liftIO $ throw (IncorrectApplyEditRequestException (show req)) @@ -318,7 +315,7 @@ getDocUri file = do waitForDiagnostics :: Session [Diagnostic] waitForDiagnostics = do - diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification + diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification let (List diags) = diagsNot ^. params . LSP.diagnostics return diags @@ -327,7 +324,7 @@ waitForDiagnostics = do -- returned. noDiagnostics :: Session () noDiagnostics = do - diagsNot <- notification :: Session PublishDiagnosticsNotification + diagsNot <- message :: Session PublishDiagnosticsNotification when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException -- | Returns the symbols in a document. @@ -370,4 +367,4 @@ executeCodeAction action = do where handleEdit :: WorkspaceEdit -> Session () handleEdit e = let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e) - in processMessage (ReqApplyWorkspaceEdit req) \ No newline at end of file + in updateState (ReqApplyWorkspaceEdit req) diff --git a/lib/Language/Haskell/LSP/Test/Replay.hs b/lib/Language/Haskell/LSP/Test/Replay.hs index 250fb2a..b224be6 100644 --- a/lib/Language/Haskell/LSP/Test/Replay.hs +++ b/lib/Language/Haskell/LSP/Test/Replay.hs @@ -19,7 +19,6 @@ import Data.List import Data.Maybe import Control.Lens hiding (List) import Control.Monad -import System.IO import System.FilePath import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Files @@ -123,44 +122,51 @@ isNotification (NotShowMessage _) = True isNotification (NotCancelRequestFromServer _) = True isNotification _ = False -listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar () -> ThreadId -> Handle -> Session () -listenServer [] _ _ _ passSema _ _ = liftIO $ putMVar passSema () -listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut = do - - msgBytes <- liftIO $ getNextMessage serverOut +-- listenServer :: [FromServerMessage] +-- -> RequestMap +-- -> MVar LspId +-- -> MVar LspIdRsp +-- -> MVar () +-- -> ThreadId +-- -> Handle +-- -> SessionContext +-- -> IO () +listenServer [] _ _ _ passSema _ _ _ = putMVar passSema () +listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do + + msgBytes <- getNextMessage serverOut let msg = decodeFromServerMsg reqMap msgBytes handleServerMessage request response notification msg if shouldSkip msg - then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut + then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx else if inRightOrder msg expectedMsgs - then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut + then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs ++ [head $ dropWhile isNotification expectedMsgs] exc = ReplayOutOfOrderException msg remainingMsgs in liftIO $ throwTo mainThreadId exc where - response :: ResponseMessage a -> Session () + response :: ResponseMessage a -> IO () response res = do - liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) + putStrLn $ "Got response for id " ++ show (res ^. id) - liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request + putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - request :: RequestMessage ServerMethod a b -> Session () + request :: RequestMessage ServerMethod a b -> IO () request req = do - liftIO - $ putStrLn + putStrLn $ "Got request for id " ++ show (req ^. id) ++ " " ++ show (req ^. method) - liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response + putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - notification :: NotificationMessage ServerMethod a -> Session () - notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method) + notification :: NotificationMessage ServerMethod a -> IO () + notification n = putStrLn $ "Got notification " ++ show (n ^. method) diff --git a/src/Language/Haskell/LSP/Test/Compat.hs b/src/Language/Haskell/LSP/Test/Compat.hs index 6b018cc..f616331 100644 --- a/src/Language/Haskell/LSP/Test/Compat.hs +++ b/src/Language/Haskell/LSP/Test/Compat.hs @@ -5,9 +5,6 @@ {-# OPTIONS_GHC -Wunused-imports #-} module Language.Haskell.LSP.Test.Compat where -import Control.Concurrent.Chan -import Control.Monad.IO.Class -import Data.Conduit import Data.Maybe #if MIN_VERSION_process(1,6,3) @@ -51,13 +48,3 @@ getProcessID p = fromIntegral . fromJust <$> getProcessID' p #endif _ -> return Nothing #endif - -#if MIN_VERSION_conduit(1,3,0) -chanSource :: MonadIO m => Chan o -> ConduitT i o m b -#else -chanSource :: MonadIO m => Chan o -> ConduitM i o m b -#endif -chanSource c = do - x <- liftIO $ readChan c - yield x - chanSource c diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index 3f122f2..c8ca4f9 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -12,6 +12,7 @@ data SessionException = TimeoutException | UnexpectedDiagnosticsException | IncorrectApplyEditRequestException String | UnexpectedResponseError LspIdRsp ResponseError + deriving Eq instance Exception SessionException @@ -19,8 +20,8 @@ instance Show SessionException where show TimeoutException = "Timed out waiting to receive a message from the server." show (UnexpectedMessageException expected lastMsg) = "Received an unexpected message from the server:\n" ++ - "Expected: " ++ expected ++ "\n" ++ - "Last message accepted: " ++ show lastMsg + "Was parsing: " ++ expected ++ "\n" ++ + "Last message received: " ++ show lastMsg show (ReplayOutOfOrderException received expected) = "Replay is out of order:\n" ++ -- Print json so its a bit easier to update the session logs diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 06776cb..88109a5 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -8,27 +8,37 @@ import Control.Applicative import Control.Concurrent import Control.Lens import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Monad import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Conduit.Parser import Data.Maybe +import qualified Data.Text as T +import Data.Typeable import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types as LSP hiding (error) -import Language.Haskell.LSP.Test.Exceptions import Language.Haskell.LSP.Test.Messages import Language.Haskell.LSP.Test.Session import System.Console.ANSI -satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage +satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage satisfy pred = do - timeout <- timeout <$> lift sessionConfig - tId <- liftIO myThreadId - timeoutThread <- liftIO $ forkIO $ do + + skipTimeout <- overridingTimeout <$> get + timeoutId <- curTimeoutId <$> get + unless skipTimeout $ do + chan <- asks messageChan + timeout <- asks (messageTimeout . config) + void $ liftIO $ forkIO $ do threadDelay (timeout * 1000000) - throwTo tId TimeoutException + writeChan chan (TimeoutMessage timeoutId) + x <- await - liftIO $ killThread timeoutThread + + unless skipTimeout $ + modify $ \s -> s { curTimeoutId = timeoutId + 1 } + + modify $ \s -> s { lastReceivedMessage = Just x } if pred x then do @@ -39,43 +49,33 @@ satisfy pred = do return x else empty --- | Matches if the message is a notification. -anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage -anyNotification = named "Any notification" $ satisfy isServerNotification - -notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) -notification = named "Notification" $ do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a) +-- | Matches a message of type 'a'. +message :: forall a. (Typeable a, FromJSON a) => Session a +message = + let parser = decode . encodeMsg :: FromServerMessage -> Maybe a + in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ do x <- satisfy (isJust . parser) return $ castMsg x +-- | Matches if the message is a notification. +anyNotification :: Session FromServerMessage +anyNotification = named "Any notification" $ satisfy isServerNotification + -- | Matches if the message is a request. -anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyRequest :: Session FromServerMessage anyRequest = named "Any request" $ satisfy isServerRequest -request :: forall m a b. (MonadIO m, MonadSessionConfig m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b) -request = named "Request" $ do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b) - x <- satisfy (isJust . parser) - return $ castMsg x - -- | Matches if the message is a response. -anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyResponse :: Session FromServerMessage anyResponse = named "Any response" $ satisfy isServerResponse -response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) -response = named "Response" $ do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) - x <- satisfy (isJust . parser) - return $ castMsg x - -responseForId :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => LspId -> ConduitParser FromServerMessage m (ResponseMessage a) -responseForId lid = named "Response for id" $ do +responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a) +responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser) return $ castMsg x -anyMessage :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyMessage :: Session FromServerMessage anyMessage = satisfy (const True) -- | A stupid method for getting out the inner message. @@ -91,7 +91,7 @@ toJSONMsg :: FromServerMessage -> Value toJSONMsg = genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) -- | Matches if the message is a log message notification or a show message notification/request. -loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip where shouldSkip (NotLogMessage _) = True @@ -99,7 +99,7 @@ loggingNotification = named "Logging notification" $ satisfy shouldSkip shouldSkip (ReqShowMessage _) = True shouldSkip _ = False -publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification +publishDiagnosticsNotification :: Session PublishDiagnosticsNotification publishDiagnosticsNotification = named "Publish diagnostics notification" $ do NotPublishDiagnostics diags <- satisfy test return diags diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index ec6d45d..10f63b2 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -6,9 +6,9 @@ module Language.Haskell.LSP.Test.Session ( Session , SessionConfig(..) + , SessionMessage(..) , SessionContext(..) , SessionState(..) - , MonadSessionConfig(..) , runSessionWithHandles , get , put @@ -16,7 +16,9 @@ module Language.Haskell.LSP.Test.Session , ask , asks , sendMessage - , processMessage) + , updateState + , withTimeout + ) where @@ -32,8 +34,8 @@ import Control.Monad.Trans.State (StateT, runStateT) import qualified Control.Monad.Trans.State as State (get, put) import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson -import Data.Conduit hiding (await) -import Data.Conduit.Parser +import Data.Conduit as Conduit +import Data.Conduit.Parser as Parser import Data.Default import Data.Foldable import Data.List @@ -46,7 +48,6 @@ import Language.Haskell.LSP.Messages import Language.Haskell.LSP.TH.ClientCapabilities import Language.Haskell.LSP.Types hiding (error) import Language.Haskell.LSP.VFS -import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Exceptions import System.Console.ANSI @@ -70,24 +71,22 @@ type Session = ParserStateReader FromServerMessage SessionState SessionContext I data SessionConfig = SessionConfig { capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything. - , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60. + , messageTimeout :: Int -- ^ Maximum time to wait for a message in seconds. Defaults to 60. , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False } instance Default SessionConfig where def = SessionConfig def 60 False -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 SessionMessage = ServerMessage FromServerMessage + | TimeoutMessage Int + deriving Show data SessionContext = SessionContext { serverIn :: Handle , rootDir :: FilePath - , messageChan :: Chan FromServerMessage + , messageChan :: Chan SessionMessage , requestMap :: MVar RequestMap , initRsp :: MVar InitializeResponse , config :: SessionConfig @@ -101,7 +100,7 @@ class Monad m => HasReader r m where instance Monad m => HasReader r (ParserStateReader a s r m) where ask = lift $ lift Reader.ask -instance HasReader SessionContext SessionProcessor where +instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where ask = lift $ lift Reader.ask data SessionState = SessionState @@ -109,6 +108,11 @@ data SessionState = SessionState curReqId :: LspId , vfs :: VFS , curDiagnostics :: Map.Map Uri [Diagnostic] + , curTimeoutId :: Int + , overridingTimeout :: Bool + -- ^ The last received message from the server. + -- Used for providing exception information + , lastReceivedMessage :: Maybe FromServerMessage } class Monad m => HasState s m where @@ -123,45 +127,45 @@ instance Monad m => HasState s (ParserStateReader a s r m) where get = lift State.get put = lift . State.put -instance HasState SessionState SessionProcessor where +instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) + where get = lift State.get put = lift . State.put type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) -type SessionProcessor = ConduitM 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 - where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler) - handler e@(Unexpected "ConduitParser.empty") = do +runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) +runSession context state session = + -- source <- sourceList <$> getChanContents (messageChan context) + runReaderT (runStateT conduit state) context + where + conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) - -- Horrible way to get last item in conduit: - -- Add a fake message so we can tell when to stop - liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) - x <- peek - case x of - Just x -> do - lastMsg <- skipToEnd x + handler (Unexpected "ConduitParser.empty") = do + lastMsg <- fromJust . lastReceivedMessage <$> get name <- getParserName liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg) - Nothing -> throw e handler e = throw e - skipToEnd x = do - y <- peek - case y of - Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x - Just _ -> await >>= skipToEnd - Nothing -> return x + chanSource = do + msg <- liftIO $ readChan (messageChan context) + yield msg + chanSource + + + watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () + watchdog = Conduit.awaitForever $ \msg -> do + curId <- curTimeoutId <$> get + case msg of + ServerMessage sMsg -> yield sMsg + TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException -- | An internal version of 'runSession' that allows for a custom handler to listen to the server. -- It also does not automatically send initialize and exit messages. runSessionWithHandles :: Handle -- ^ Server in -> Handle -- ^ Server out - -> (Handle -> Session ()) -- ^ Server listener + -> (Handle -> SessionContext -> IO ()) -- ^ Server listener -> SessionConfig -> FilePath -> Session a @@ -174,34 +178,32 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = reqMap <- newMVar newRequestMap messageChan <- newChan - meaninglessChan <- newChan initRsp <- newEmptyMVar let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config - initState = SessionState (IdInt 0) mempty mempty + initState = SessionState (IdInt 0) mempty mempty 0 False Nothing - threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut) - (result, _) <- runSession messageChan processor context initState session + threadId <- forkIO $ void $ serverHandler serverOut context + (result, _) <- runSession context initState session killThread threadId return result - where processor :: SessionProcessor () - processor = awaitForever $ \msg -> do - processMessage msg +updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () +updateStateC = awaitForever $ \msg -> do + updateState msg yield msg - -processMessage :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () -processMessage (NotPublishDiagnostics n) = do +updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () +updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri modify (\s -> let newDiags = Map.insert doc diags (curDiagnostics s) in s { curDiagnostics = newDiags }) -processMessage (ReqApplyWorkspaceEdit r) = do +updateState (ReqApplyWorkspaceEdit r) = do allChangeParams <- case r ^. params . edit . documentChanges of Just (List cs) -> do @@ -252,7 +254,7 @@ processMessage (ReqApplyWorkspaceEdit r) = do mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) in DidChangeTextDocumentParams (head params ^. textDocument) (List events) -processMessage _ = return () +updateState _ = return () sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () sendMessage msg = do @@ -265,3 +267,20 @@ sendMessage msg = do setSGR [Reset] B.hPut h (addHeader encoded) + +-- | Execute a block f that will throw a 'TimeoutException' +-- after duration seconds. This will override the global timeout +-- for waiting for messages to arrive defined in 'SessionConfig'. +withTimeout :: Int -> Session a -> Session a +withTimeout duration f = do + chan <- asks messageChan + timeoutId <- curTimeoutId <$> get + modify $ \s -> s { overridingTimeout = True } + liftIO $ forkIO $ do + threadDelay (duration * 1000000) + writeChan chan (TimeoutMessage timeoutId) + res <- f + modify $ \s -> s { curTimeoutId = timeoutId + 1, + overridingTimeout = False + } + return res diff --git a/test/ParsingTests.hs b/test/ParsingTests.hs deleted file mode 100644 index fe8d366..0000000 --- a/test/ParsingTests.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -module ParsingTests where - -import Control.Lens hiding (List) -import Language.Haskell.LSP.Messages -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 - let testDiag = NotPublishDiagnostics - (NotificationMessage "2.0" - TextDocumentPublishDiagnostics - (PublishDiagnosticsParams (Uri "foo") - (List []))) - it "get picked up" $ do - let source = yield testDiag - session = do - diags <- publishDiagnosticsNotification :: TestSession PublishDiagnosticsNotification - return $ diags ^. params . uri - runConduit (source .| runConduitParser session) `shouldReturn` Uri "foo" - it "get picked up after skipping others before" $ do - let testDiag = NotPublishDiagnostics - (NotificationMessage "2.0" - TextDocumentPublishDiagnostics - (PublishDiagnosticsParams (Uri "foo") - (List []))) - notTestDiag = NotLogMessage (NotificationMessage "2.0" WindowLogMessage (LogMessageParams MtLog "foo")) - source = yield notTestDiag >> yield testDiag - session = do - diags <- skipManyTill anyNotification notification :: TestSession PublishDiagnosticsNotification - return $ diags ^. params . uri - runConduit (source .| runConduitParser session) `shouldReturn` Uri "foo" \ No newline at end of file diff --git a/test/Test.hs b/test/Test.hs index b3a54ed..90be1e2 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -10,14 +10,15 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Control.Concurrent import Control.Monad.IO.Class +import Control.Monad import Control.Lens hiding (List) import GHC.Generics import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Replay import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.Types hiding (capabilities) -import ParsingTests +import Language.Haskell.LSP.Types hiding (message, capabilities) +import System.Timeout main = hspec $ do describe "manual session" $ do @@ -39,33 +40,81 @@ main = hspec $ do conf = def { capabilities = caps } runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return () + describe "withTimeout" $ do + it "times out" $ + let sesh = runSession "hie --lsp" "test/data/renamePass" $ do + openDoc "Desktop/simple.hs" "haskell" + -- won't receive a request - will timeout + -- incoming logging requests shouldn't increase the + -- timeout + withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + -- wait just a bit longer than 5 seconds so we have time + -- to open the document + in timeout 6000000 sesh `shouldThrow` anySessionException + + it "doesn't time out" $ + let sesh = runSession "hie --lsp" "test/data/renamePass" $ do + openDoc "Desktop/simple.hs" "haskell" + withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification + in void $ timeout 6000000 sesh + + it "further timeout messages are ignored" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + withTimeout 3 $ getDocumentSymbols doc + liftIO $ threadDelay 5000000 + -- shouldn't throw an exception + getDocumentSymbols doc + return () + + it "overrides global message timeout" $ + let sesh = + runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + -- shouldn't time out in here since we are overriding it + withTimeout 10 $ liftIO $ threadDelay 7000000 + getDocumentSymbols doc + return True + in sesh `shouldReturn` True + + it "unoverrides global message timeout" $ + let sesh = + runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + -- shouldn't time out in here since we are overriding it + withTimeout 10 $ liftIO $ threadDelay 7000000 + getDocumentSymbols doc + -- should now timeout + skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest + in sesh `shouldThrow` (== TimeoutException) + + describe "exceptions" $ do it "throw on time out" $ - let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do + let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do skipMany loggingNotification - _ <- request :: Session ApplyWorkspaceEditRequest + _ <- message :: Session ApplyWorkspaceEditRequest return () in sesh `shouldThrow` anySessionException - it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 5}) "hie --lsp" "test/data/renamePass" $ do + it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" "test/data/renamePass" $ do loggingNotification liftIO $ threadDelay 10 _ <- openDoc "Desktop/simple.hs" "haskell" return () - it "throw when there's an unexpected message" $ + describe "UnexpectedMessageException" $ do + it "throws when there's an unexpected message" $ let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True selector _ = False in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector - - it "throw when there's an unexpected message 2" $ - let selector (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True + it "provides the correct types that were expected and received" $ + let selector (UnexpectedMessageException "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc) skipMany anyNotification - response :: Session RenameResponse -- the wrong type + message :: Session RenameResponse -- the wrong type in runSession "hie --lsp" "test/data/renamePass" sesh `shouldThrow` selector @@ -101,7 +150,7 @@ main = hspec $ do reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) sendRequest_ WorkspaceExecuteCommand reqParams - editReq <- request :: Session ApplyWorkspaceEditRequest + editReq <- message :: Session ApplyWorkspaceEditRequest liftIO $ do let (Just cs) = editReq ^. params . edit . changes [(u, List es)] = HM.toList cs @@ -153,11 +202,8 @@ main = hspec $ do mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) mainSymbol ^. containerName `shouldBe` Nothing - parsingSpec - data ApplyOneParams = AOP { file :: Uri , start_pos :: Position , hintTitle :: String } deriving (Generic, ToJSON) -