From edd544e24005468dfba38cd5292397f4c6ba9643 Mon Sep 17 00:00:00 2001 From: jneira Date: Fri, 17 Dec 2021 11:41:19 +0100 Subject: [PATCH] Revert "Send unhandled exceptions to the user (#2484)" This reverts commit 0211f75c96402dda53be69473714134244763d95. --- ghcide/src/Development/IDE/Core/Rules.hs | 3 + .../src/Development/IDE/LSP/LanguageServer.hs | 106 +++++++----------- 2 files changed, 46 insertions(+), 63 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 14ff4a29fa..756edad54c 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -150,6 +150,9 @@ 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/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 6d910a56d2..2aa725d33d 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -38,12 +38,8 @@ 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 @@ -58,16 +54,11 @@ 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 server will be canceled when it's full. + -- LSP loop 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 @@ -102,7 +93,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan [ ideHandlers , cancelHandler cancelRequest , exitHandler exit - , shutdownHandler stopReactorLoop + , shutdownHandler ] -- Cancel requests are special since they need to be handled -- out of order to be useful. Existing handlers are run afterwards. @@ -111,23 +102,25 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan let serverDefinition = LSP.ServerDefinition { LSP.onConfigurationChange = onConfigurationChange , LSP.defaultConfig = defaultConfig - , LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan + , LSP.doInitialize = handleInit 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 $ untilMVar clientMsgVar $ - void $ LSP.runServerWithHandles + void $ waitAnyCancel =<< traverse async + [ void $ LSP.runServerWithHandles inH outH serverDefinition + , void $ readMVar clientMsgVar + ] where handleInit - :: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage + :: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage -> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)) - handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do + handleInit 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,71 +138,58 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan registerIdeConfiguration (shakeExtras ide) initConfig let handleServerException (Left e) = do - logError logger $ + logError (ideLogger ide) $ T.pack $ "Fatal error in server thread: " <> show e - sendErrorMessage e exitClientMsg - 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 - + handleServerException _ = pure () 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 - exceptionInHandler e - k $ ResponseError InternalError (T.pack $ show e) Nothing - _ <- flip forkFinally handleServerException $ untilMVar lifetime $ runWithDb logger dbLoc $ \hiedb hieChan -> do + _ <- 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 -> handle exceptionInHandler act - ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + 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 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 :: IO () -> LSP.Handlers (ServerM c) -shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do +shutdownHandler :: LSP.Handlers (ServerM c) +shutdownHandler = LSP.requestHandler SShutdown $ \_ resp -> do (_, ide) <- ask - liftIO $ logDebug (ideLogger ide) "Received shutdown message" - -- stop the reactor to free up the hiedb connection - liftIO stopReactor + liftIO $ logDebug (ideLogger ide) "Received exit message" -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide resp $ Right Empty