From bd2ac7da01645dc111a6912be661bc13b7f9340f Mon Sep 17 00:00:00 2001 From: jneira Date: Wed, 10 Jul 2019 12:35:05 +0200 Subject: [PATCH] Exit the server and its listener properly --- src/Language/Haskell/LSP/Test.hs | 21 +++++++++++-------- src/Language/Haskell/LSP/Test/Replay.hs | 1 + src/Language/Haskell/LSP/Test/Session.hs | 26 ++++++++---------------- 3 files changed, 22 insertions(+), 26 deletions(-) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index c4b90fb..7e87fcb 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -37,8 +37,9 @@ module Language.Haskell.LSP.Test , module Language.Haskell.LSP.Test.Parsing -- * Utilities -- | Quick helper functions for common tasks. - -- ** Initialization + -- ** Lifecycle , initializeResponse + , exitServer -- ** Documents , openDoc , openDoc' @@ -149,7 +150,7 @@ runSessionWithConfig config serverExe caps rootDir session = do (Just TraceOff) Nothing withServer serverExe (logStdErr config) $ \serverIn serverOut _ -> - runSessionWithHandles serverIn serverOut (\h c -> listenServer h c) config caps rootDir $ do + runSessionWithHandles serverIn serverOut listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls initRspMsg <- request Initialize initializeParams :: Session InitializeResponse @@ -157,7 +158,6 @@ runSessionWithConfig config serverExe caps rootDir session = do initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification Initialized InitializedParams case lspConfig config of @@ -168,11 +168,8 @@ runSessionWithConfig config serverExe caps rootDir session = do result <- session return result where - -- | Listens to the server output, makes sure it matches the record and - -- signals any semaphores - -- Note that on Windows, we cannot kill a thread stuck in getNextMessage. - -- So we have to wait for the exit notification to kill the process first - -- and then getNextMessage will fail. + -- | Listens to the server output until the shutdown ack, + -- makes sure it matches the record and signals any semaphores listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do msgBytes <- getNextMessage serverOut @@ -182,7 +179,9 @@ runSessionWithConfig config serverExe caps rootDir session = do let msg = decodeFromServerMsg reqMap msgBytes writeChan (messageChan context) (ServerMessage msg) - listenServer serverOut context + case msg of + (RspShutdown _) -> return () + _ -> listenServer serverOut context -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text @@ -576,3 +575,7 @@ getCodeLenses tId = do rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse case getResponseResult rsp of List res -> pure res + +-- | Exit the server after request its shutdown +exitServer :: Session() +exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index b2d54a3..7d10763 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -65,6 +65,7 @@ replaySession serverExe sessionDir = do def fullCaps sessionDir + exitServer (sendMessages clientMsgs reqSema rspSema) takeMVar passSema killThread sessionThread diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index ae8ba1e..1777f15 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -48,7 +48,6 @@ import Data.Conduit as Conduit import Data.Conduit.Parser as Parser import Data.Default import Data.Foldable -import Data.IORef import Data.List import qualified Data.Map as Map import qualified Data.Text as T @@ -191,12 +190,10 @@ runSessionWithHandles :: Handle -- ^ Server in -> SessionConfig -> ClientCapabilities -> FilePath -- ^ Root directory + -> Session () -- ^ To exit Server -> Session a -> IO a -runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do - -- We use this IORef to make exception non-fatal when the server is supposed to shutdown. - - exitOk <- newIORef False +runSessionWithHandles serverIn serverOut serverHandler config caps rootDir exitServer session = do absRootDir <- canonicalizePath rootDir @@ -215,15 +212,13 @@ runSessionWithHandles serverIn serverOut serverHandler config caps rootDir sessi let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps initState = SessionState (IdInt 0) mempty mempty 0 False Nothing - errorHandler ex = do x <- readIORef exitOk - unless x $ throwTo mainThreadId (ex :: SessionException) - launchServerHandler = forkIO $ catch (serverHandler serverOut context) errorHandler - (result, _) <- bracket - launchServerHandler - (\tid -> do runSession context initState sendExitMessage - killThread tid - atomicWriteIORef exitOk True) - (const $ runSession context initState session) + runSession' = runSession context initState + + errorHandler = throwTo mainThreadId :: SessionException -> IO() + serverLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler + serverFinalizer tid = runSession' exitServer >> killThread tid + + (result, _) <- bracket serverLauncher serverFinalizer (const $ runSession' session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -310,9 +305,6 @@ sendMessage msg = do logMsg LogClient msg liftIO $ B.hPut h (addHeader $ encode msg) -sendExitMessage :: (MonadIO m, HasReader SessionContext m) => m () -sendExitMessage = sendMessage (NotificationMessage "2.0" Exit ExitParams) - -- | Execute a block f that will throw a 'Timeout' exception -- after duration seconds. This will override the global timeout -- for waiting for messages to arrive defined in 'SessionConfig'. -- 2.30.2