Skip to content

Commit 6968b80

Browse files
pepeiborrapepeiborra
committed
Revert "Revert "Send unhandled exceptions to the user (#2484)" (#2497)"
This reverts commit 5d2189c.
1 parent 5d2189c commit 6968b80

File tree

2 files changed

+63
-46
lines changed

2 files changed

+63
-46
lines changed

‎ghcide/src/Development/IDE/Core/Rules.hs‎

Lines changed: 0 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -150,9 +150,6 @@ import Ide.Types (DynFlagsModificat
150150
PluginId)
151151
import Control.Concurrent.STM.Stats (atomically)
152152
import Language.LSP.Server (LspT)
153-
import System.Environment (getExecutablePath)
154-
import System.Process.Extra (readProcessWithExitCode)
155-
import Text.Read (readMaybe)
156153
import System.Info.Extra (isMac)
157154
import HIE.Bios.Ghc.Gap (hostIsDynamic)
158155

‎ghcide/src/Development/IDE/LSP/LanguageServer.hs‎

Lines changed: 63 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -38,8 +38,12 @@ import Development.IDE.Core.Tracing
3838
import Development.IDE.LSP.HoverDefinition
3939
import Development.IDE.Types.Logger
4040

41+
import Control.Monad.IO.Unlift (MonadUnliftIO)
4142
import System.IO.Unsafe (unsafeInterleaveIO)
4243

44+
issueTrackerUrl :: T.Text
45+
issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues"
46+
4347
runLanguageServer
4448
:: forall config. (Show config)
4549
=> LSP.Options
@@ -54,11 +58,16 @@ runLanguageServer
5458
runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChange userHandlers getIdeState = do
5559

5660
-- This MVar becomes full when the server thread exits or we receive exit message from client.
57-
-- LSP loop will be canceled when it's full.
61+
-- LSP server will be canceled when it's full.
5862
clientMsgVar <- newEmptyMVar
5963
-- Forcefully exit
6064
let exit = void $ tryPutMVar clientMsgVar ()
6165

66+
-- An MVar to control the lifetime of the reactor loop.
67+
-- The loop will be stopped and resources freed when it's full
68+
reactorLifetime <- newEmptyMVar
69+
let stopReactorLoop = void $ tryPutMVar reactorLifetime ()
70+
6271
-- The set of requests ids that we have received but not finished processing
6372
pendingRequests <- newTVarIO Set.empty
6473
-- The set of requests that have been cancelled and are also in pendingRequests
@@ -93,7 +102,7 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
93102
[ ideHandlers
94103
, cancelHandler cancelRequest
95104
, exitHandler exit
96-
, shutdownHandler
105+
, shutdownHandler stopReactorLoop
97106
]
98107
-- Cancel requests are special since they need to be handled
99108
-- out of order to be useful. Existing handlers are run afterwards.
@@ -102,25 +111,23 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
102111
let serverDefinition = LSP.ServerDefinition
103112
{ LSP.onConfigurationChange = onConfigurationChange
104113
, LSP.defaultConfig = defaultConfig
105-
, LSP.doInitialize = handleInit exit clearReqId waitForCancel clientMsgChan
114+
, LSP.doInitialize = handleInit reactorLifetime exit clearReqId waitForCancel clientMsgChan
106115
, LSP.staticHandlers = asyncHandlers
107116
, LSP.interpretHandler = \(env, st) -> LSP.Iso (LSP.runLspT env . flip runReaderT (clientMsgChan,st)) liftIO
108117
, LSP.options = modifyOptions options
109118
}
110119

111-
void $ waitAnyCancel =<< traverse async
112-
[ void $ LSP.runServerWithHandles
120+
void $ untilMVar clientMsgVar $
121+
void $ LSP.runServerWithHandles
113122
inH
114123
outH
115124
serverDefinition
116-
, void $ readMVar clientMsgVar
117-
]
118125

119126
where
120127
handleInit
121-
:: IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
128+
:: MVar () -> IO () -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> Chan ReactorMessage
122129
-> LSP.LanguageContextEnv config -> RequestMessage Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState))
123-
handleInit exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
130+
handleInit lifetime exitClientMsg clearReqId waitForCancel clientMsgChan env (RequestMessage _ _ m params) = otTracedHandler "Initialize" (show m) $ \sp -> do
124131
traceWithSpan sp params
125132
let root = LSP.resRootPath env
126133
dir <- maybe getCurrentDirectory return root
@@ -138,58 +145,71 @@ runLanguageServer options inH outH getHieDbLoc defaultConfig onConfigurationChan
138145
registerIdeConfiguration (shakeExtras ide) initConfig
139146

140147
let handleServerException (Left e) = do
141-
logError (ideLogger ide) $
148+
logError logger $
142149
T.pack $ "Fatal error in server thread: " <> show e
150+
sendErrorMessage e
143151
exitClientMsg
144-
handleServerException _ = pure ()
152+
handleServerException (Right _) = pure ()
153+
154+
sendErrorMessage (e :: SomeException) = do
155+
LSP.runLspT env $ LSP.sendNotification SWindowShowMessage $
156+
ShowMessageParams MtError $ T.unlines
157+
[ "Unhandled exception, please [report](" <> issueTrackerUrl <> "): "
158+
, T.pack(show e)
159+
]
160+
161+
exceptionInHandler e = do
162+
logError logger $ T.pack $
163+
"Unexpected exception, please report!\n" ++
164+
"Exception: " ++ show e
165+
sendErrorMessage e
166+
145167
logger = ideLogger ide
146-
_ <- flip forkFinally handleServerException $ runWithDb logger dbLoc $ \hiedb hieChan -> do
168+
169+
checkCancelled _id act k =
170+
flip finally (clearReqId _id) $
171+
catch (do
172+
-- We could optimize this by first checking if the id
173+
-- is in the cancelled set. However, this is unlikely to be a
174+
-- bottleneck and the additional check might hide
175+
-- issues with async exceptions that need to be fixed.
176+
cancelOrRes <- race (waitForCancel _id) act
177+
case cancelOrRes of
178+
Left () -> do
179+
logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id
180+
k $ ResponseError RequestCancelled "" Nothing
181+
Right res -> pure res
182+
) $ \(e :: SomeException) -> do
183+
exceptionInHandler e
184+
k $ ResponseError InternalError (T.pack $ show e) Nothing
185+
_ <- flip forkFinally handleServerException $ untilMVar lifetime $ runWithDb logger dbLoc $ \hiedb hieChan -> do
147186
putMVar dbMVar (hiedb,hieChan)
148187
forever $ do
149188
msg <- readChan clientMsgChan
150189
-- We dispatch notifications synchronously and requests asynchronously
151190
-- This is to ensure that all file edits and config changes are applied before a request is handled
152191
case msg of
153-
ReactorNotification act -> do
154-
catch act $ \(e :: SomeException) ->
155-
logError (ideLogger ide) $ T.pack $
156-
"Unexpected exception on notification, please report!\n" ++
157-
"Exception: " ++ show e
158-
ReactorRequest _id act k -> void $ async $
159-
checkCancelled ide clearReqId waitForCancel _id act k
192+
ReactorNotification act -> handle exceptionInHandler act
193+
ReactorRequest _id act k -> void $ async $ checkCancelled _id act k
160194
pure $ Right (env,ide)
161195

162-
checkCancelled
163-
:: IdeState -> (SomeLspId -> IO ()) -> (SomeLspId -> IO ()) -> SomeLspId
164-
-> IO () -> (ResponseError -> IO ()) -> IO ()
165-
checkCancelled ide clearReqId waitForCancel _id act k =
166-
flip finally (clearReqId _id) $
167-
catch (do
168-
-- We could optimize this by first checking if the id
169-
-- is in the cancelled set. However, this is unlikely to be a
170-
-- bottleneck and the additional check might hide
171-
-- issues with async exceptions that need to be fixed.
172-
cancelOrRes <- race (waitForCancel _id) act
173-
case cancelOrRes of
174-
Left () -> do
175-
logDebug (ideLogger ide) $ T.pack $ "Cancelled request " <> show _id
176-
k $ ResponseError RequestCancelled "" Nothing
177-
Right res -> pure res
178-
) $ \(e :: SomeException) -> do
179-
logError (ideLogger ide) $ T.pack $
180-
"Unexpected exception on request, please report!\n" ++
181-
"Exception: " ++ show e
182-
k $ ResponseError InternalError (T.pack $ show e) Nothing
183196

197+
-- | Runs the action until it ends or until the given MVar is put.
198+
-- Rethrows any exceptions.
199+
untilMVar :: MonadUnliftIO m => MVar () -> m () -> m ()
200+
untilMVar mvar io = void $
201+
waitAnyCancel =<< traverse async [ io , readMVar mvar ]
184202

185203
cancelHandler :: (SomeLspId -> IO ()) -> LSP.Handlers (ServerM c)
186204
cancelHandler cancelRequest = LSP.notificationHandler SCancelRequest $ \NotificationMessage{_params=CancelParams{_id}} ->
187205
liftIO $ cancelRequest (SomeLspId _id)
188206

189-
shutdownHandler :: LSP.Handlers (ServerM c)
190-
shutdownHandler = LSP.requestHandler SShutdown $ \_ resp -> do
207+
shutdownHandler :: IO () -> LSP.Handlers (ServerM c)
208+
shutdownHandler stopReactor = LSP.requestHandler SShutdown $ \_ resp -> do
191209
(_, ide) <- ask
192-
liftIO $ logDebug (ideLogger ide) "Received exit message"
210+
liftIO $ logDebug (ideLogger ide) "Received shutdown message"
211+
-- stop the reactor to free up the hiedb connection
212+
liftIO stopReactor
193213
-- flush out the Shake session to record a Shake profile if applicable
194214
liftIO $ shakeShut ide
195215
resp $ Right Empty

0 commit comments

Comments
 (0)