From 83ae7af0da095c6cce34e5e2f308f5db4281269e Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 13 Dec 2021 20:48:54 +0000 Subject: [PATCH 1/5] Send unhandled exceptions to the user --- .../src/Development/IDE/LSP/LanguageServer.hs | 61 ++++++++++--------- 1 file changed, 32 insertions(+), 29 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2aa725d33d..59b224c908 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -40,6 +40,8 @@ import Development.IDE.Types.Logger import System.IO.Unsafe (unsafeInterleaveIO) +issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" + runLanguageServer :: forall config. (Show config) => LSP.Options @@ -138,11 +140,38 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - logError (ideLogger ide) $ + logError logger $ T.pack $ "Fatal error in server thread: " <> show e exitClientMsg handleServerException _ = pure () + + uncaughtError (e :: SomeException) = do + logError logger $ T.pack $ + "Unexpected exception on notification, please report!\n" ++ + "Exception: " ++ show e + LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtError $ T.unlines + [ "Unhandled error, please [report](" <> issueTrackerUrl <> "): " + , T.pack(show e) + ] logger = ideLogger ide + + checkCancelled _id act k = + flip finally (clearReqId _id) $ + catch (do + -- We could optimize this by first checking if the id + -- is in the cancelled set. However, this is unlikely to be a + -- bottleneck and the additional check might hide + -- issues with async exceptions that need to be fixed. + cancelOrRes <- race (waitForCancel _id) act + case cancelOrRes of + Left () -> do + logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id + k $ ResponseError RequestCancelled "" Nothing + Right res -> pure res + ) $ \(e :: SomeException) -> do + uncaughtError e + k $ ResponseError InternalError (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) forever $ do @@ -150,36 +179,10 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan -- We dispatch notifications synchronously and requests asynchronously -- This is to ensure that all file edits and config changes are applied before a request is handled case msg of - ReactorNotification act -> do - catch act $ \(e :: SomeException) -> - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on notification, please report!\n" ++ - "Exception: " ++ show e - ReactorRequest _id act k -> void $ async $ - checkCancelled ide clearReqId waitForCancel _id act k + ReactorNotification act -> handle uncaughtError act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k pure $ Right (env,ide) - checkCancelled - :: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId - -> IO () -> (ResponseError -> IO ()) -> IO () - checkCancelled ide clearReqId waitForCancel _id act k = - flip finally (clearReqId _id) $ - catch (do - -- We could optimize this by first checking if the id - -- is in the cancelled set. However, this is unlikely to be a - -- bottleneck and the additional check might hide - -- issues with async exceptions that need to be fixed. - cancelOrRes <- race (waitForCancel _id) act - case cancelOrRes of - Left () -> do - logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id - k $ ResponseError RequestCancelled "" Nothing - Right res -> pure res - ) $ \(e :: SomeException) -> do - logError (ideLogger ide) $ T.pack $ - "Unexpected exception on request, please report!\n" ++ - "Exception: " ++ show e - k $ ResponseError InternalError (T.pack $ show e) Nothing cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) From 90a4b140ac47063f2230a2f84678b6f827f63c0a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Mon, 13 Dec 2021 23:14:14 +0000 Subject: [PATCH 2/5] send message in server exception too --- .../src/Development/IDE/LSP/LanguageServer.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 59b224c908..5a965bbba5 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -142,18 +142,23 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan let handleServerException (Left e) = do logError logger $ T.pack $ "Fatal error in server thread: " <> show e + sendErrorMessage e exitClientMsg handleServerException _ = pure () - uncaughtError (e :: SomeException) = do - logError logger $ T.pack $ - "Unexpected exception on notification, please report!\n" ++ - "Exception: " ++ show e + sendErrorMessage (e :: SomeException) = do LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $ ShowMessageParams MtError $ T.unlines - [ "Unhandled error, please [report](" <> issueTrackerUrl <> "): " + [ "Unhandled exception, please [report](" <> issueTrackerUrl <> "): " , T.pack(show e) ] + + exceptionInHandler e = do + logError logger $ T.pack $ + "Unexpected exception, please report!\n" ++ + "Exception: " ++ show e + sendErrorMessage e + logger = ideLogger ide checkCancelled _id act k = @@ -170,7 +175,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan k $ ResponseError RequestCancelled "" Nothing Right res -> pure res ) $ \(e :: SomeException) -> do - uncaughtError e + exceptionInHandler e k $ ResponseError InternalError (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) @@ -179,7 +184,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan -- We dispatch notifications synchronously and requests asynchronously -- This is to ensure that all file edits and config changes are applied before a request is handled case msg of - ReactorNotification act -> handle uncaughtError act + ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k pure $ Right (env,ide) From 8479178c245827b7c85407f6edf89b13f8b835f1 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 16 Dec 2021 09:58:46 +0000 Subject: [PATCH 3/5] add missing signature --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 5a965bbba5..46a99b5e91 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -40,6 +40,7 @@ import Development.IDE.Types.Logger import System.IO.Unsafe (unsafeInterleaveIO) +issueTrackerUrl :: T.Text issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" runLanguageServer From 870df2119acd01c7e6d204d7486015893c727218 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 16 Dec 2021 09:54:46 +0000 Subject: [PATCH 4/5] fix redundant imports --- ghcide/src/Development/IDE/Core/Rules.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 756edad54c..14ff4a29fa 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -150,9 +150,6 @@ import Ide.Types (DynFlagsModificat PluginId) import Control.Concurrent.STM.Stats (atomically) import Language.LSP.Server (LspT) -import System.Environment (getExecutablePath) -import System.Process.Extra (readProcessWithExitCode) -import Text.Read (readMaybe) import System.Info.Extra (isMac) import HIE.Bios.Ghc.Gap (hostIsDynamic) From a0441564ea0bd6d6a23615a968328fddfb571419 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Thu, 16 Dec 2021 10:28:04 +0000 Subject: [PATCH 5/5] Release hiedb on shutdown --- .../src/Development/IDE/LSP/LanguageServer.hs | 39 ++++++++++++------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 46a99b5e91..6d910a56d2 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -38,6 +38,7 @@ import Development.IDE.Core.Tracing import Development.IDE.LSP.HoverDefinition import Development.IDE.Types.Logger +import Control.Monad.IO.Unlift (MonadUnliftIO) import System.IO.Unsafe (unsafeInterleaveIO) issueTrackerUrl :: T.Text @@ -57,11 +58,16 @@ runLanguageServer runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do -- This MVar becomes full when the server thread exits or we receive exit message from client. - -- LSP loop will be canceled when it's full. + -- LSP server will be canceled when it's full. clientMsgVar <- newEmptyMVar -- Forcefully exit let exit = void $ tryPutMVar clientMsgVar () + -- An MVar to control the lifetime of the reactor loop. + -- The loop will be stopped and resources freed when it's full + reactorLifetime <- newEmptyMVar + let stopReactorLoop = void $ tryPutMVar reactorLifetime () + -- The set of requests ids that we have received but not finished processing pendingRequests <- newTVarIO Set.empty -- The set of requests that have been cancelled and are also in pendingRequests @@ -96,7 +102,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan [ ideHandlers , cancelHandler cancelRequest , exitHandler exit - , shutdownHandler + , shutdownHandler stopReactorLoop ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. @@ -105,25 +111,23 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan let serverDefinition = LSP.ServerDefinition { LSP.onConfigurationChange = onConfigurationChange , LSP.defaultConfig = defaultConfig - , LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan + , LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan , LSP.staticHandlers = asyncHandlers , LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO , LSP.options = modifyOptions options } - void $ waitAnyCancel =<< traverse async - [ void $ LSP.runServerWithHandles + void $ untilMVar clientMsgVar $ + void $ LSP.runServerWithHandles inH outH serverDefinition - , void $ readMVar clientMsgVar - ] where handleInit - :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage + :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) - handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do traceWithSpan sp params let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root @@ -145,7 +149,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan T.pack $ "Fatal error in server thread: " <> show e sendErrorMessage e exitClientMsg - handleServerException _ = pure () + handleServerException (Right _) = pure () sendErrorMessage (e :: SomeException) = do LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $ @@ -178,7 +182,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan ) $ \(e :: SomeException) -> do exceptionInHandler e k $ ResponseError InternalError (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do + _ <- flip forkFinally handleServerException $ untilMVar lifetime $ runWithDb logger dbLoc $ \hiedb hieChan -> do putMVar dbMVar (hiedb,hieChan) forever $ do msg <- readChan clientMsgChan @@ -190,15 +194,22 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan pure $ Right (env,ide) +-- | Runs the action until it ends or until the given MVar is put. +-- Rethrows any exceptions. +untilMVar :: MonadUnliftIO m => MVar () -> m () -> m () +untilMVar mvar io = void $ + waitAnyCancel =<< traverse async [ io , readMVar mvar ] cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c) cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} -> liftIO $ cancelRequest (SomeLspId _id) -shutdownHandler :: LSP.Handlers (ServerM c) -shutdownHandler = LSP.requestHandler SShutdown $ \_ resp -> do +shutdownHandler :: IO () -> LSP.Handlers (ServerM c) +shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do (_, ide) <- ask - liftIO $ logDebug (ideLogger ide) "Received exit message" + liftIO $ logDebug (ideLogger ide) "Received shutdown message" + -- stop the reactor to free up the hiedb connection + liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide resp $ Right Empty