From 43e8cb0c4edba118c6c985253ddf614fce120445 Mon Sep 17 00:00:00 2001 From: mangoiv Date: Wed, 16 Jul 2025 15:06:41 +0200 Subject: [PATCH 1/4] [fix] don't bake ide state mvar into setup and getIdeState This is the right thing to do because othewise it is not possible to create new ideStates in a single instance of the executable. This will be useful if the hls executable is supposed to talk to multiple clients and lives beyond a single client disconnecting. --- ghcide/src/Development/IDE/Main.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 872e957364..ad4a36327a 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -12,7 +12,7 @@ module Development.IDE.Main ) where import Control.Concurrent.Extra (withNumCapabilities) -import Control.Concurrent.MVar (newEmptyMVar, +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, tryReadMVar) import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Monad.Extra (concatMapM, unless, @@ -318,9 +318,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re ioT <- offsetTime logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) - ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState - getIdeState env rootPath withHieDb threadQueue = do + let getIdeState :: MVar IdeState -> LSP.LanguageContextEnv Config -> FilePath -> WithHieDb -> Shake.ThreadQueue -> IO IdeState + getIdeState ideStateVar env rootPath withHieDb threadQueue = do t <- ioT logWith recorder Info $ LogLspStartDuration t sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions rootPath (tLoaderQueue threadQueue) @@ -353,9 +352,9 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re putMVar ideStateVar ide pure ide - let setup = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) getIdeState + let setup ideStateVar = setupLSP (cmapWithPrio LogLanguageServer recorder) argsProjectRoot argsGetHieDbLoc (pluginHandlers plugins) (getIdeState ideStateVar) -- See Note [Client configuration in Rules] - onConfigChange cfg = do + onConfigChange ideStateVar cfg = do -- TODO: this is nuts, we're converting back to JSON just to get a fingerprint let cfgObj = J.toJSON cfg mide <- liftIO $ tryReadMVar ideStateVar @@ -368,7 +367,9 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re modifyClientSettings ide (const $ Just cfgObj) return [toNoFileKey Rules.GetClientSettings] - runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup + do + ideStateVar <- newEmptyMVar + runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig (onConfigChange ideStateVar) (setup ideStateVar) dumpSTMStats Check argFiles -> do let dir = argsProjectRoot From 66966570ac336259f9ad49ed0e1eec325b604d9e Mon Sep 17 00:00:00 2001 From: mangoiv Date: Wed, 16 Jul 2025 15:08:56 +0200 Subject: [PATCH 2/4] [fix] don't throw hard errors when no shutdown message is handled Previously, when there was no shutdown message by a client and the client disconnected, resulting in the handlers to be GC'd the race that was supposed to free resources for the HieDB & co. would throw a hard error talking about the MVar being unreachable. We would like to instead finish gracefully because finishing the race as soon as the MVar was GC'd is the right thing to do anyway. --- exe/Wrapper.hs | 2 +- .../src/Development/IDE/LSP/LanguageServer.hs | 27 ++++++++++++------- 2 files changed, 18 insertions(+), 11 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 2c2401ab6a..63ca484245 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -300,7 +300,7 @@ launchErrorLSP recorder errorMsg = do [ exitHandler exit ] let interpretHandler (env, _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO - pure (doInitialize, asyncHandlers, interpretHandler) + pure (doInitialize, asyncHandlers, interpretHandler, [exit]) runLanguageServer (cmapWithPrio pretty recorder) (Main.argsLspOptions defaultArguments) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index cf7845ce08..e51b450bf3 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -34,6 +34,7 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Exception (BlockedIndefinitelyOnMVar (..)) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration @@ -94,14 +95,14 @@ runLanguageServer -> (MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)), LSP.Handlers (m config), - (LanguageContextEnv config, a) -> m config <~> IO)) + (LanguageContextEnv config, a) -> m config <~> IO, [IO ()])) -> IO () runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar - (doInitialize, staticHandlers, interpretHandler) <- setup clientMsgVar + (doInitialize, staticHandlers, interpretHandler, onExit) <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition { LSP.parseConfig = parseConfig @@ -118,13 +119,14 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog) lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) - void $ untilMVar clientMsgVar $ - void $ LSP.runServerWithHandles + untilMVar clientMsgVar $ + LSP.runServerWithHandles lspCologAction lspCologAction inH outH serverDefinition + `finally` sequence_ onExit setupLSP :: forall config err. @@ -136,7 +138,8 @@ setupLSP :: -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), - (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) + (LanguageContextEnv config, IdeState) -> ServerM config <~> IO, + [IO ()]) setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available @@ -184,7 +187,9 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - pure (doInitialize, asyncHandlers, interpretHandler) + let finalHandlers = [stopReactorLoop, exit] + + pure (doInitialize, asyncHandlers, interpretHandler, finalHandlers) handleInit @@ -265,11 +270,13 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) --- | Runs the action until it ends or until the given MVar is put. +-- | Runs the action until it ends or until the given MVar is put or the thread to fill the mvar is dropped, in which case the MVar will never be filled. +-- This happens when the thread that handles the shutdown notification dies. Ideally, this should not rely on the RTS detecting the blocked MVar +-- and instead *also* run the shutdown inf a finally block enclosing the handlers. In which case the BlockedIndefinitelyOnMVar Exception also wouldn't +-- be thrown. -- Rethrows any exceptions. -untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () -untilMVar mvar io = void $ - waitAnyCancel =<< traverse async [ io , readMVar mvar ] +untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () +untilMVar mvar io = race_ (readMVar mvar) io cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SMethod_CancelRequest $ \TNotificationMessage{_params=CancelParams{_id}} -> From f7fca52f19321e173e669079a00bc983e6b918d1 Mon Sep 17 00:00:00 2001 From: mangoiv Date: Mon, 4 Aug 2025 17:51:57 +0200 Subject: [PATCH 3/4] [chore] apply suggestions from code review by @fendor --- .../src/Development/IDE/LSP/LanguageServer.hs | 51 +++++++++++-------- 1 file changed, 29 insertions(+), 22 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e51b450bf3..0668095171 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -34,7 +34,6 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog -import Control.Exception (BlockedIndefinitelyOnMVar (..)) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Cont (evalContT) import Development.IDE.Core.IdeConfiguration @@ -82,6 +81,17 @@ instance Pretty Log where LogLspServer msg -> pretty msg LogServerShutdownMessage -> "Received shutdown message" +data Setup config m a + = MkSetup + { doInitialize :: LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)) + -- ^ the callback invoked when the language server receives the 'Method_Initialize' request + , staticHandlers :: LSP.Handlers m + -- ^ the statically known handlers of the lsp server + , interpretHandler :: (LanguageContextEnv config, a) -> m <~> IO + -- ^ how to interpret @m@ to 'IO' and how to lift 'IO' into @m@ + , onExit :: [IO ()] + -- ^ a list of 'IO' actions that clean up resources and must be run when the server shuts down + } runLanguageServer :: forall config a m. (Show config) @@ -91,18 +101,16 @@ runLanguageServer -> Handle -- output -> config -> (config -> Value -> Either T.Text config) - -> (config -> m config ()) - -> (MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) (LSP.LanguageContextEnv config, a)), - LSP.Handlers (m config), - (LanguageContextEnv config, a) -> m config <~> IO, [IO ()])) + -> (config -> m ()) + -> (MVar () -> IO (Setup config m a)) -> IO () runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigChange setup = do -- This MVar becomes full when the server thread exits or we receive exit message from client. -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar - (doInitialize, staticHandlers, interpretHandler, onExit) <- setup clientMsgVar + MkSetup + { doInitialize, staticHandlers, interpretHandler, onExit } <- setup clientMsgVar let serverDefinition = LSP.ServerDefinition { LSP.parseConfig = parseConfig @@ -116,30 +124,29 @@ runLanguageServer recorder options inH outH defaultConfig parseConfig onConfigCh , LSP.options = modifyOptions options } - let lspCologAction :: MonadIO m2 => Colog.LogAction m2 (Colog.WithSeverity LspServerLog) + let lspCologAction :: forall io. MonadIO io => Colog.LogAction io (Colog.WithSeverity LspServerLog) lspCologAction = toCologActionWithPrio (cmapWithPrio LogLspServer recorder) - untilMVar clientMsgVar $ + let runServer = LSP.runServerWithHandles lspCologAction lspCologAction inH outH serverDefinition - `finally` sequence_ onExit + + untilMVar clientMsgVar $ + runServer `finally` sequence_ onExit setupLSP :: - forall config err. + forall config. Recorder (WithPriority Log) -> FilePath -- ^ root directory, see Note [Root Directory] -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) -> (LSP.LanguageContextEnv config -> FilePath -> WithHieDb -> ThreadQueue -> IO IdeState) -> MVar () - -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), - LSP.Handlers (ServerM config), - (LanguageContextEnv config, IdeState) -> ServerM config <~> IO, - [IO ()]) + -> IO (Setup config (ServerM config) IdeState) setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available @@ -174,7 +181,7 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar cancelled <- readTVar cancelledRequests unless (reqId `Set.member` cancelled) retry - let asyncHandlers = mconcat + let staticHandlers = mconcat [ userHandlers , cancelHandler cancelRequest , exitHandler exit @@ -187,9 +194,9 @@ setupLSP recorder defaultRoot getHieDbLoc userHandlers getIdeState clientMsgVar let interpretHandler (env, st) = LSP.Iso (LSP.runLspT env . flip (runReaderT . unServerM) (clientMsgChan,st)) liftIO - let finalHandlers = [stopReactorLoop, exit] + let onExit = [stopReactorLoop, exit] - pure (doInitialize, asyncHandlers, interpretHandler, finalHandlers) + pure MkSetup {doInitialize, staticHandlers, interpretHandler, onExit} handleInit @@ -270,10 +277,10 @@ runWithWorkerThreads recorder dbLoc f = evalContT $ do (WithHieDbShield hiedb, threadQueue) <- runWithDb recorder dbLoc liftIO $ f hiedb (ThreadQueue threadQueue sessionRestartTQueue sessionLoaderTQueue) --- | Runs the action until it ends or until the given MVar is put or the thread to fill the mvar is dropped, in which case the MVar will never be filled. --- This happens when the thread that handles the shutdown notification dies. Ideally, this should not rely on the RTS detecting the blocked MVar --- and instead *also* run the shutdown inf a finally block enclosing the handlers. In which case the BlockedIndefinitelyOnMVar Exception also wouldn't --- be thrown. +-- | Runs the action until it ends or until the given MVar is put. +-- It is important, that the thread that puts the 'MVar' is not dropped before it puts the 'MVar' i.e. it should +-- occur as the final action in a 'finally' or 'bracket', because otherwise this thread will finish early (as soon +-- as the thread receives the BlockedIndefinitelyOnMVar exception) -- Rethrows any exceptions. untilMVar :: MonadUnliftIO m => MVar () -> m a -> m () untilMVar mvar io = race_ (readMVar mvar) io From 33e021f1564f8fe8820064c4f07710ca8d3b1bb8 Mon Sep 17 00:00:00 2001 From: mangoiv Date: Mon, 4 Aug 2025 17:51:57 +0200 Subject: [PATCH 4/4] [chore] apply suggestions from code review by @fendor --- exe/Wrapper.hs | 10 ++++++++-- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 1 + 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index 63ca484245..2fd885ffb3 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -38,7 +38,8 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT, import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T -import Development.IDE.LSP.LanguageServer (runLanguageServer) +import Development.IDE.LSP.LanguageServer (Setup (..), + runLanguageServer) import qualified Development.IDE.Main as Main import Ide.Logger (Doc, Pretty (pretty), Recorder, WithPriority, @@ -300,7 +301,12 @@ launchErrorLSP recorder errorMsg = do [ exitHandler exit ] let interpretHandler (env, _st) = LSP.Iso (LSP.runLspT env . unErrorLSPM) liftIO - pure (doInitialize, asyncHandlers, interpretHandler, [exit]) + pure MkSetup + { doInitialize + , staticHandlers = asyncHandlers + , interpretHandler + , onExit = [exit] + } runLanguageServer (cmapWithPrio pretty recorder) (Main.argsLspOptions defaultArguments) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 0668095171..918e024a4f 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -11,6 +11,7 @@ module Development.IDE.LSP.LanguageServer , Log(..) , ThreadQueue , runWithWorkerThreads + , Setup (..) ) where import Control.Concurrent.STM