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/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 2aa725d33d..6d910a56d2 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,71 @@ 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 + + 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 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 + ReactorNotification act -> handle exceptionInHandler 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 +-- | 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