From 493d20ada6e48a8987e00a5ec92a1b31fe3c9b8c Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Thu, 21 Jun 2018 12:24:50 +0100 Subject: [PATCH] Add unexpected message exception --- haskell-lsp-test.cabal | 1 + src/Language/Haskell/LSP/Test/Exceptions.hs | 11 ++++++- src/Language/Haskell/LSP/Test/Parsing.hs | 35 +++++++++++---------- src/Language/Haskell/LSP/Test/Session.hs | 30 ++++++++++++++++-- test/Test.hs | 21 +++++++++++-- 5 files changed, 75 insertions(+), 23 deletions(-) diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index d6f8a4d..c593f6e 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -30,6 +30,7 @@ library , directory , filepath , lens + , mtl , parser-combinators , process >= 1.6.3 , text diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index deea111..a25c802 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -1,10 +1,19 @@ module Language.Haskell.LSP.Test.Exceptions where import Control.Exception +import Language.Haskell.LSP.Messages data SessionException = TimeoutException - deriving Show + | UnexpectedMessageException String FromServerMessage + instance Exception SessionException +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 + 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 9e6bdd5..fdc2e95 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Parsing where import Control.Applicative @@ -22,56 +22,57 @@ satisfy :: (MonadIO m, MonadSessionConfig m) => (a -> Bool) -> ConduitParser a m satisfy pred = do timeout <- timeout <$> lift sessionConfig tId <- liftIO myThreadId - liftIO $ forkIO $ do + timeoutThread <- liftIO $ forkIO $ do threadDelay (timeout * 1000000) throwTo tId TimeoutException x <- await + liftIO $ killThread timeoutThread if pred x then return x else empty -- | Matches if the message is a notification. anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage -anyNotification = satisfy isServerNotification +anyNotification = named "Any notification" $ satisfy isServerNotification notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) -notification = do +notification = named "Notification" $ do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a) x <- satisfy (isJust . parser) - return $ decodeMsg $ encodeMsg x + return $ castMsg x -- | Matches if the message is a request. anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage -anyRequest = satisfy isServerRequest +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 = do +request = named "Request" $ do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b) x <- satisfy (isJust . parser) - return $ decodeMsg $ encodeMsg x + return $ castMsg x -- | Matches if the message is a response. anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage -anyResponse = satisfy isServerResponse +anyResponse = named "Any response" $ satisfy isServerResponse response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) -response = do +response = named "Response" $ do let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) x <- satisfy (isJust . parser) - return $ decodeMsg $ encodeMsg x + return $ castMsg x + +-- | A stupid method for getting out the inner message. +castMsg :: FromJSON a => FromServerMessage -> a +castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg -- | A version of encode that encodes FromServerMessages as if they -- weren't wrapped. encodeMsg :: FromServerMessage -> B.ByteString encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) -decodeMsg :: FromJSON a => B.ByteString -> a -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 :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage -loggingNotification = satisfy shouldSkip +loggingNotification = named "Logging notification" $ satisfy shouldSkip where shouldSkip (NotLogMessage _) = True shouldSkip (NotShowMessage _) = True @@ -79,7 +80,7 @@ loggingNotification = satisfy shouldSkip shouldSkip _ = False publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification -publishDiagnosticsNotification = do +publishDiagnosticsNotification = named "Publish diagnostics notification" $ do NotPublishDiagnostics diags <- satisfy test return diags where test (NotPublishDiagnostics _) = True diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index a427137..ee6d871 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -16,21 +16,23 @@ module Language.Haskell.LSP.Test.Session where import Control.Concurrent hiding (yield) +import Control.Exception import Control.Lens hiding (List) import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Class +import Control.Monad.Except import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader (ask) import Control.Monad.Trans.State (StateT, runStateT) import qualified Control.Monad.Trans.State as State (get, put, modify) import qualified Data.ByteString.Lazy.Char8 as B import Data.Aeson -import Data.Conduit +import Data.Conduit hiding (await) import Data.Conduit.Parser import Data.Default import Data.Foldable import Data.List +import qualified Data.Text as T import qualified Data.HashMap.Strict as HashMap import Language.Haskell.LSP.Messages import Language.Haskell.LSP.TH.ClientCapabilities @@ -38,6 +40,7 @@ import Language.Haskell.LSP.Types 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.Directory import System.IO @@ -92,7 +95,28 @@ type SessionProcessor = ConduitT FromServerMessage FromServerMessage (StateT Ses 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 + where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler) + handler e@(Unexpected "ConduitParser.empty") = do + + -- 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 + 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 get :: Monad m => ParserStateReader a s r m s get = lift State.get diff --git a/test/Test.hs b/test/Test.hs index d9ecf21..c8d6072 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -11,6 +11,7 @@ import Control.Concurrent import Control.Monad.IO.Class 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 @@ -55,17 +56,33 @@ main = hspec $ do conf = def { capabilities = caps } runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return () - it "times out" $ + describe "exceptions" $ do + it "throw on time 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 + it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do loggingNotification liftIO $ threadDelay 5 + it "throw when there's an unexpected message" $ + let msgExc (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True + msgExc _ = False + in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` msgExc + + it "throw when there's an unexpected message 2" $ + let msgExc (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True + msgExc _ = False + sesh = do + doc <- openDoc "Desktop/simple.hs" "haskell" + sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) + skipMany anyNotification + response :: Session RenameResponse -- the wrong type + in runSession "hie --lsp" "test/data/renamePass" sesh + `shouldThrow` msgExc describe "replay session" $ do it "passes a test" $ -- 2.30.2