From 16873edb44e066f4258bc406c4f0dbdef572c4f1 Mon Sep 17 00:00:00 2001 From: Neil Mitchell <35463327+neil-da@users.noreply.github.com> Date: Fri, 28 Jun 2019 12:47:45 +0100 Subject: [PATCH] hie-core Logging and exceptions (#1933) * Rename reportSeriousError to reportInternalError * Stop using logError for logging things that are warnings to the user, not errors by us * Rename logError * Sort the log fields properly * Delete tagAction from Logger * Strip down the pure logger * Delete unused pieces of the logger * A quick check suggests the call stack will be useful in approximately none of the callers of logging, so just remove it * When reporting an internal error, give as much detail as we can * Change our logger to be based on Priority values * HLint fixes * Rename makeNopLogger * In hie-core say what level of message you are setting * Delete the unused makeOneLogger * Make sure we can show messages floating around * If a notification/response handler throws an exception, report it upwards * Remove reportInternalError in favour of a general logging mechanism * Add missing dependencies * Just call fail for a dodgy error report * Add a FIXME * Make missing modules just an error --- BUILD.bazel | 1 + exe/Main.hs | 4 +- hie-core.cabal | 1 + src/Development/IDE/Core/Shake.hs | 12 +++--- src/Development/IDE/LSP/LanguageServer.hs | 28 ++++++++++--- src/Development/IDE/LSP/Server.hs | 4 +- src/Development/IDE/Types/Logger.hs | 50 ++++++++++++++++------- 7 files changed, 71 insertions(+), 29 deletions(-) diff --git a/BUILD.bazel b/BUILD.bazel index 61fc1638..01068786 100644 --- a/BUILD.bazel +++ b/BUILD.bazel @@ -24,6 +24,7 @@ depends = [ "prettyprinter", "prettyprinter-ansi-terminal", "rope-utf16-splay", + "safe-exceptions", "sorted-list", "shake", "stm", diff --git a/exe/Main.hs b/exe/Main.hs index f9a56643..3817de62 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -22,6 +22,7 @@ import Development.IDE.Types.Location import Development.IDE.Types.Diagnostics import Development.IDE.Types.Options import Development.IDE.Types.Logger +import qualified Data.Text as T import qualified Data.Text.IO as T import Language.Haskell.LSP.Messages import Development.IDE.LSP.LanguageServer @@ -52,7 +53,8 @@ main = do -- lock to avoid overlapping output on stdout lock <- newLock - let logger = makeOneLogger $ withLock lock . T.putStrLn + let logger = Logger $ \pri msg -> withLock lock $ + T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg whenJust argsCwd setCurrentDirectory diff --git a/hie-core.cabal b/hie-core.cabal index 82e8eecc..b5e8dcfd 100644 --- a/hie-core.cabal +++ b/hie-core.cabal @@ -111,6 +111,7 @@ executable hie-core directory, optparse-applicative, hie-bios, + safe-exceptions, shake, data-default, ghc-paths, diff --git a/src/Development/IDE/Core/Shake.hs b/src/Development/IDE/Core/Shake.hs index 87b1ce07..64318749 100644 --- a/src/Development/IDE/Core/Shake.hs +++ b/src/Development/IDE/Core/Shake.hs @@ -32,12 +32,12 @@ module Development.IDE.Core.Shake( use_, uses_, define, defineEarlyCutoff, getDiagnostics, unsafeClearDiagnostics, - reportSeriousError, IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction, garbageCollect, setPriority, sendEvent, ideLogger, + actionLogger, FileVersion(..) ) where @@ -307,11 +307,6 @@ uses_ key files = do Nothing -> liftIO $ throwIO BadDependency Just v -> return v -reportSeriousError :: String -> Action () -reportSeriousError t = do - ShakeExtras{logger} <- getShakeExtras - liftIO $ logSeriousError logger $ T.pack t - -- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency -- which short-circuits the rest of the action @@ -420,6 +415,11 @@ sendEvent e = do ideLogger :: IdeState -> Logger ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger +actionLogger :: Action Logger +actionLogger = do + ShakeExtras{logger} <- getShakeExtras + return logger + data GetModificationTime = GetModificationTime deriving (Eq, Show, Generic) diff --git a/src/Development/IDE/LSP/LanguageServer.hs b/src/Development/IDE/LSP/LanguageServer.hs index ea8338b0..55200a83 100644 --- a/src/Development/IDE/LSP/LanguageServer.hs +++ b/src/Development/IDE/LSP/LanguageServer.hs @@ -17,8 +17,10 @@ import qualified Language.Haskell.LSP.Core as LSP import Control.Concurrent.Chan import Control.Concurrent.Extra import Control.Concurrent.Async +import Control.Exception.Safe import Data.Default import Data.Maybe +import qualified Data.Text as T import GHC.IO.Handle (hDuplicate, hDuplicateTo) import System.IO import Control.Monad.Extra @@ -27,6 +29,7 @@ import Development.IDE.LSP.Definition import Development.IDE.LSP.Hover import Development.IDE.LSP.Notifications import Development.IDE.Core.Service +import Development.IDE.Types.Logger import Development.IDE.Core.FileStore import Language.Haskell.LSP.Core (LspFuncs(..)) import Language.Haskell.LSP.Messages @@ -89,10 +92,23 @@ runLanguageServer options userHandlers getIdeState = do _ <- flip forkFinally (const exitClientMsg) $ forever $ do msg <- readChan clientMsgChan case msg of - Notification NotificationMessage{_params} act -> act ide _params - Response RequestMessage{_id, _params} wrap act -> do - res <- act ide _params - sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing + Notification x@NotificationMessage{_params} act -> do + catch (act ide _params) $ \(e :: SomeException) -> + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on notification, please report!\n" ++ + "Message: " ++ show x ++ "\n" ++ + "Exception: " ++ show e + Response x@RequestMessage{_id, _params} wrap act -> + catch (do + res <- act ide _params + sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) (Just res) Nothing + ) $ \(e :: SomeException) -> do + logError (ideLogger ide) $ T.pack $ + "Unexpected exception on request, please report!\n" ++ + "Message: " ++ show x ++ "\n" ++ + "Exception: " ++ show e + sendFunc $ wrap $ ResponseMessage "2.0" (responseId _id) Nothing $ + Just $ ResponseError InternalError (T.pack $ show e) Nothing pure Nothing @@ -109,8 +125,8 @@ setHandlersIgnore = PartialHandlers $ \_ x -> return x -- | A message that we need to deal with - the pieces are split up with existentials to gain additional type safety -- and defer precise processing until later (allows us to keep at a higher level of abstraction slightly longer) data Message - = forall m req resp . Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (IdeState -> req -> IO resp) - | forall m req . Notification (NotificationMessage m req) (IdeState -> req -> IO ()) + = forall m req resp . (Show m, Show req) => Response (RequestMessage m req resp) (ResponseMessage resp -> FromServerMessage) (IdeState -> req -> IO resp) + | forall m req . (Show m, Show req) => Notification (NotificationMessage m req) (IdeState -> req -> IO ()) modifyOptions :: LSP.Options -> LSP.Options diff --git a/src/Development/IDE/LSP/Server.hs b/src/Development/IDE/LSP/Server.hs index 82ea3ac2..4b7fe22f 100644 --- a/src/Development/IDE/LSP/Server.hs +++ b/src/Development/IDE/LSP/Server.hs @@ -18,11 +18,11 @@ import Development.IDE.Core.Service data WithMessage = WithMessage - {withResponse :: forall m req resp . + {withResponse :: forall m req resp . (Show m, Show req) => (ResponseMessage resp -> LSP.FromServerMessage) -> -- how to wrap a response (IdeState -> req -> IO resp) -> -- actual work Maybe (LSP.Handler (RequestMessage m req resp)) - ,withNotification :: forall m req . + ,withNotification :: forall m req . (Show m, Show req) => Maybe (LSP.Handler (NotificationMessage m req)) -> -- old notification handler (IdeState -> req -> IO ()) -> -- actual work Maybe (LSP.Handler (NotificationMessage m req)) diff --git a/src/Development/IDE/Types/Logger.hs b/src/Development/IDE/Types/Logger.hs index da78f986..940915f9 100644 --- a/src/Development/IDE/Types/Logger.hs +++ b/src/Development/IDE/Types/Logger.hs @@ -6,23 +6,45 @@ -- concrete choice of logging framework so users can plug in whatever -- framework they want to. module Development.IDE.Types.Logger - ( Logger(..) - , makeOneLogger - , makeNopLogger + ( Priority(..) + , Logger(..) + , logError, logWarning, logInfo, logDebug + , noLogging ) where import qualified Data.Text as T -import GHC.Stack -data Logger = Logger { - logSeriousError :: HasCallStack => T.Text -> IO () - , logInfo :: HasCallStack => T.Text -> IO () - , logDebug :: HasCallStack => T.Text -> IO () - , logWarning :: HasCallStack => T.Text -> IO () - } -makeNopLogger :: Logger -makeNopLogger = makeOneLogger $ const $ pure () +data Priority +-- Don't change the ordering of this type or you will mess up the Ord +-- instance + = Debug -- ^ Verbose debug logging. + | Info -- ^ Useful information in case an error has to be understood. + | Warning + -- ^ These error messages should not occur in a expected usage, and + -- should be investigated. + | Error -- ^ Such log messages must never occur in expected usage. + deriving (Eq, Show, Ord, Enum, Bounded) -makeOneLogger :: (HasCallStack => T.Text -> IO ()) -> Logger -makeOneLogger x = Logger x x x x + +-- | Note that this is logging actions _of the program_, not of the user. +-- You shouldn't call warning/error if the user has caused an error, only +-- if our code has gone wrong and is itself erroneous (e.g. we threw an exception). +data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} + + +logError :: Logger -> T.Text -> IO () +logError x = logPriority x Error + +logWarning :: Logger -> T.Text -> IO () +logWarning x = logPriority x Warning + +logInfo :: Logger -> T.Text -> IO () +logInfo x = logPriority x Info + +logDebug :: Logger -> T.Text -> IO () +logDebug x = logPriority x Debug + + +noLogging :: Logger +noLogging = Logger $ \_ _ -> return ()