Unhandled exceptions fixed

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)
 

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

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