From c0d8a3b642bfe07f25e13ebe08e899056f8ee10b Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 19 Dec 2021 17:36:58 +0000 Subject: [PATCH] Unhandled exceptions fixed (#2504) * Revert "Revert "Send unhandled exceptions to the user (#2484)" (#2497)" This reverts commit 5d2189c6fb3a90fc5d614674f5b9e4421e05280d. * Log when reactor thread exits * log shakeSessionInit * Do not assume that the build has been initialized --- ghcide/src/Development/IDE/Core/Rules.hs | 3 - ghcide/src/Development/IDE/Core/Shake.hs | 10 +- .../src/Development/IDE/LSP/LanguageServer.hs | 120 +++++++++++------- 3 files changed, 77 insertions(+), 56 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) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index fa4b18a67b..0dda58478e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -154,7 +154,7 @@ import Data.Aeson (toJSON) import qualified Data.ByteString.Char8 as BS8 import Data.Coerce (coerce) import Data.Default -import Data.Foldable (toList) +import Data.Foldable (for_, toList) import Data.HashSet (HashSet) import qualified Data.HashSet as HSet import Data.String (fromString) @@ -583,15 +583,17 @@ startTelemetry db extras@ShakeExtras{..} -- | Must be called in the 'Initialized' handler and only once shakeSessionInit :: IdeState -> IO () -shakeSessionInit IdeState{..} = do +shakeSessionInit ide@IdeState{..} = do initSession <- newSession shakeExtras shakeDb [] "shakeSessionInit" putMVar shakeSession initSession + logDebug (ideLogger ide) "Shake session initialized" shakeShut :: IdeState -> IO () -shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do +shakeShut IdeState{..} = do + runner <- tryReadMVar shakeSession -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. - void $ cancelShakeSession runner + for_ runner cancelShakeSession void $ shakeDatabaseProfile shakeDb shakeClose progressStop $ progress shakeExtras diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2aa725d33d..ec2cf3f484 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -38,8 +38,12 @@ 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 +issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues" + runLanguageServer :: forall config. (Show config) => LSP.Options @@ -54,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 @@ -93,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. @@ -102,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 @@ -138,58 +145,73 @@ 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 + sendErrorMessage e exitClientMsg - handleServerException _ = pure () + handleServerException (Right _) = pure () + + sendErrorMessage (e :: SomeException) = do + LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $ + ShowMessageParams MtError $ T.unlines + [ "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 - _ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do - putMVar dbMVar (hiedb,hieChan) - forever $ do - msg <- readChan clientMsgChan - -- 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 + + 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 + exceptionInHandler e + k $ ResponseError InternalError (T.pack $ show e) Nothing + _ <- flip forkFinally handleServerException $ do + untilMVar lifetime $ runWithDb logger dbLoc $ \hiedb hieChan -> do + putMVar dbMVar (hiedb,hieChan) + forever $ do + msg <- readChan clientMsgChan + -- 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 exceptionInHandler act + ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + logInfo logger "Reactor thread stopped" 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 +-- | 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