From 73652d7515879c20577e0494bdc615105905f6fe Mon Sep 17 00:00:00 2001 From: Nick Suchecki <40047416+drsooch@users.noreply.github.com> Date: Fri, 1 Jul 2022 18:52:51 -0400 Subject: [PATCH] Log response errors returned from Plugins (#2988) * Log ResponseErrors when returned from Plugins * Log from Plugins * Create 'logAndReturnError' that will log any failures in plugins * Missed opportunity to use logAndReturnError * Revert throwPluginError to throwE This reverts a change made previously to try to make pluginErrors have a common error format. This will be updated in the near future. * Warning -> Error * Fix Functional Test for Plugin Response Error * Add orphan instances for * Revert back to Warning * Update log format in test suite --- ghcide/src/Development/IDE/Plugin/HLS.hs | 85 +++++++++++------- ghcide/src/Development/IDE/Types/Logger.hs | 89 +++++++++++-------- hls-plugin-api/src/Ide/PluginUtils.hs | 6 +- .../src/Ide/Plugin/AlternateNumberFormat.hs | 1 - .../src/Ide/Plugin/CallHierarchy/Internal.hs | 4 +- test/functional/Format.hs | 2 +- 6 files changed, 109 insertions(+), 78 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/HLS.hs b/ghcide/src/Development/IDE/Plugin/HLS.hs index 1959dd8dc..5a2f0a38a 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS.hs @@ -10,6 +10,7 @@ module Development.IDE.Plugin.HLS ) where import Control.Exception (SomeException) +import Control.Lens ((^.)) import Control.Monad import qualified Data.Aeson as J import Data.Bifunctor @@ -21,6 +22,7 @@ import qualified Data.List as List import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) import qualified Data.Map as Map import Data.String +import Data.Text (Text) import qualified Data.Text as T import Development.IDE.Core.Shake hiding (Log) import Development.IDE.Core.Tracing @@ -33,9 +35,10 @@ import Ide.Plugin.Config import Ide.PluginUtils (getClientConfig) import Ide.Types as HLS import qualified Language.LSP.Server as LSP -import Language.LSP.VFS import Language.LSP.Types import qualified Language.LSP.Types as J +import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.VFS import Text.Regex.TDFA.Text () import UnliftIO (MonadUnliftIO) import UnliftIO.Async (forConcurrently) @@ -44,20 +47,48 @@ import UnliftIO.Exception (catchAny) -- --------------------------------------------------------------------- -- -data Log - = LogNoEnabledPlugins - deriving Show +data Log = LogPluginError ResponseError + deriving Show instance Pretty Log where pretty = \case - LogNoEnabledPlugins -> - "extensibleNotificationPlugins no enabled plugins" + LogPluginError err -> prettyResponseError err + +-- various error message specific builders +prettyResponseError :: ResponseError -> Doc a +prettyResponseError err = errorCode <> ":" <+> errorBody + where + errorCode = pretty $ show $ err ^. LSP.code + errorBody = pretty $ err ^. LSP.message + +pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text +pluginNotEnabled method availPlugins = "No plugin enabled for " <> T.pack (show method) <> ", available:\n" <> T.pack (unlines $ map (\(plid,_,_) -> show plid) availPlugins) + +pluginDoesntExist :: PluginId -> Text +pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist" + +commandDoesntExist :: CommandId -> PluginId -> [PluginCommand ideState] -> Text +commandDoesntExist (CommandId com) (PluginId pid) legalCmds = "Command " <> com <> " isn't defined for plugin " <> pid <> ". Legal commands are:\n" <> T.pack (unlines $ map (show . commandId) legalCmds) + +failedToParseArgs :: CommandId -- ^ command that failed to parse + -> PluginId -- ^ Plugin that created the command + -> String -- ^ The JSON Error message + -> J.Value -- ^ The Argument Values + -> Text +failedToParseArgs (CommandId com) (PluginId pid) err arg = "Error while parsing args for " <> com <> " in plugin " <> pid <> ": " <> T.pack err <> "\narg = " <> T.pack (show arg) + +-- | Build a ResponseError and log it before returning to the caller +logAndReturnError :: Recorder (WithPriority Log) -> ErrorCode -> Text -> LSP.LspT Config IO (Either ResponseError a) +logAndReturnError recorder errCode msg = do + let err = ResponseError errCode msg Nothing + logWith recorder Warning $ LogPluginError err + pure $ Left err -- | Map a set of plugins to the underlying ghcide engine. asGhcIdePlugin :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Plugin Config asGhcIdePlugin recorder (IdePlugins ls) = mkPlugin rulesPlugins HLS.pluginRules <> - mkPlugin executeCommandPlugins HLS.pluginCommands <> + mkPlugin (executeCommandPlugins recorder) HLS.pluginCommands <> mkPlugin (extensiblePlugins recorder) id <> mkPlugin (extensibleNotificationPlugins recorder) id <> mkPlugin dynFlagsPlugins HLS.pluginModifyDynflags @@ -91,11 +122,11 @@ dynFlagsPlugins rs = mempty -- --------------------------------------------------------------------- -executeCommandPlugins :: [(PluginId, [PluginCommand IdeState])] -> Plugin Config -executeCommandPlugins ecs = mempty { P.pluginHandlers = executeCommandHandlers ecs } +executeCommandPlugins :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> Plugin Config +executeCommandPlugins recorder ecs = mempty { P.pluginHandlers = executeCommandHandlers recorder ecs } -executeCommandHandlers :: [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) -executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd +executeCommandHandlers :: Recorder (WithPriority Log) -> [(PluginId, [PluginCommand IdeState])] -> LSP.Handlers (ServerM Config) +executeCommandHandlers recorder ecs = requestHandler SWorkspaceExecuteCommand execCmd where pluginMap = Map.fromList ecs @@ -134,21 +165,15 @@ executeCommandHandlers ecs = requestHandler SWorkspaceExecuteCommand execCmd Just (plugin, cmd) -> runPluginCommand ide plugin cmd cmdParams -- Couldn't parse the command identifier - _ -> return $ Left $ ResponseError InvalidParams "Invalid command identifier" Nothing + _ -> logAndReturnError recorder InvalidParams "Invalid command Identifier" - runPluginCommand ide p@(PluginId p') com@(CommandId com') arg = + runPluginCommand ide p com arg = case Map.lookup p pluginMap of - Nothing -> return - (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing) + Nothing -> logAndReturnError recorder InvalidRequest (pluginDoesntExist p) Just xs -> case List.find ((com ==) . commandId) xs of - Nothing -> return $ Left $ - ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' - <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing + Nothing -> logAndReturnError recorder InvalidRequest (commandDoesntExist com p xs) Just (PluginCommand _ _ f) -> case J.fromJSON arg of - J.Error err -> return $ Left $ - ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' - <> ": " <> T.pack err - <> "\narg = " <> T.pack (show arg)) Nothing + J.Error err -> logAndReturnError recorder InvalidParams (failedToParseArgs com p err arg) J.Success a -> f ide a -- --------------------------------------------------------------------- @@ -169,19 +194,15 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers } config <- Ide.PluginUtils.getClientConfig -- Only run plugins that are allowed to run on this request let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' + -- Clients generally don't display ResponseErrors so instead we log any that we come across case nonEmpty fs of - Nothing -> do - logWith recorder Info LogNoEnabledPlugins - pure $ Left $ ResponseError InvalidRequest - ( "No plugin enabled for " <> T.pack (show m) - <> ", available: " <> T.pack (show $ map (\(plid,_,_) -> plid) fs) - ) - Nothing + Nothing -> logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs') Just fs -> do let msg e pid = "Exception in plugin " <> T.pack (show pid) <> "while processing " <> T.pack (show m) <> ": " <> T.pack (show e) handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs es <- runConcurrently msg (show m) handlers ide params let (errs,succs) = partitionEithers $ toList es + unless (null errs) $ forM_ errs $ \err -> logWith recorder Error $ LogPluginError err case nonEmpty succs of Nothing -> pure $ Left $ combineErrors errs Just xs -> do @@ -206,9 +227,7 @@ extensibleNotificationPlugins recorder xs = mempty { P.pluginHandlers = handlers -- Only run plugins that are allowed to run on this request let fs = filter (\(_, desc, _) -> pluginEnabled m params desc config) fs' case nonEmpty fs of - Nothing -> do - logWith recorder Info LogNoEnabledPlugins - pure () + Nothing -> void $ logAndReturnError recorder InvalidRequest (pluginNotEnabled m fs') Just fs -> do -- We run the notifications in order, so the core ghcide provider -- (which restarts the shake process) hopefully comes last @@ -227,7 +246,7 @@ runConcurrently -> m (NonEmpty (Either ResponseError d)) runConcurrently msg method fs a b = fmap join $ forConcurrently fs $ \(pid,f) -> otTracedProvider pid (fromString method) $ do f a b - `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) + `catchAny` (\e -> pure $ pure $ Left $ ResponseError InternalError (msg e pid) Nothing) combineErrors :: [ResponseError] -> ResponseError combineErrors [x] = x diff --git a/ghcide/src/Development/IDE/Types/Logger.hs b/ghcide/src/Development/IDE/Types/Logger.hs index a858a5f52..667370720 100644 --- a/ghcide/src/Development/IDE/Types/Logger.hs +++ b/ghcide/src/Development/IDE/Types/Logger.hs @@ -29,48 +29,63 @@ module Development.IDE.Types.Logger , renderStrict ) where -import Control.Concurrent (myThreadId) -import Control.Concurrent.Extra (Lock, newLock, withLock) -import Control.Concurrent.STM (atomically, - newTVarIO, writeTVar, readTVarIO, newTBQueueIO, flushTBQueue, writeTBQueue, isFullTBQueue) -import Control.Exception (IOException) -import Control.Monad (forM_, when, (>=>), unless) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Foldable (for_) -import Data.Functor.Contravariant (Contravariant (contramap)) -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Time (defaultTimeLocale, formatTime, - getCurrentTime) -import GHC.Stack (CallStack, HasCallStack, - SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), - callStack, getCallStack, - withFrozenCallStack) +import Control.Concurrent (myThreadId) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import Control.Concurrent.STM (atomically, + flushTBQueue, + isFullTBQueue, + newTBQueueIO, newTVarIO, + readTVarIO, + writeTBQueue, writeTVar) +import Control.Exception (IOException) +import Control.Monad (forM_, unless, when, + (>=>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Foldable (for_) +import Data.Functor.Contravariant (Contravariant (contramap)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Time (defaultTimeLocale, + formatTime, + getCurrentTime) +import GHC.Stack (CallStack, HasCallStack, + SrcLoc (SrcLoc, srcLocModule, srcLocStartCol, srcLocStartLine), + callStack, getCallStack, + withFrozenCallStack) import Language.LSP.Server -import qualified Language.LSP.Server as LSP -import Language.LSP.Types (LogMessageParams (..), - MessageType (..), - SMethod (SWindowLogMessage, SWindowShowMessage), - ShowMessageParams (..)) +import qualified Language.LSP.Server as LSP +import Language.LSP.Types (LogMessageParams (..), + MessageType (..), + ResponseError, + SMethod (SWindowLogMessage, SWindowShowMessage), + ShowMessageParams (..)) #if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter as PrettyPrinterModule -import Prettyprinter.Render.Text (renderStrict) +import Prettyprinter as PrettyPrinterModule +import Prettyprinter.Render.Text (renderStrict) #else -import Data.Text.Prettyprint.Doc as PrettyPrinterModule +import Data.Text.Prettyprint.Doc as PrettyPrinterModule import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) #endif -import System.IO (Handle, IOMode (AppendMode), - hClose, hFlush, hSetEncoding, - openFile, stderr, utf8) -import qualified System.Log.Formatter as HSL -import qualified System.Log.Handler as HSL -import qualified System.Log.Handler.Simple as HSL -import qualified System.Log.Logger as HsLogger -import UnliftIO (MonadUnliftIO, displayException, - finally, try) +import Control.Lens ((^.)) +import Ide.Types (CommandId (CommandId), + PluginId (PluginId)) +import Language.LSP.Types.Lens (HasCode (code), + HasMessage (message)) +import System.IO (Handle, + IOMode (AppendMode), + hClose, hFlush, + hSetEncoding, openFile, + stderr, utf8) +import qualified System.Log.Formatter as HSL +import qualified System.Log.Handler as HSL +import qualified System.Log.Handler.Simple as HSL +import qualified System.Log.Logger as HsLogger +import UnliftIO (MonadUnliftIO, + displayException, + finally, try) data Priority -- Don't change the ordering of this type or you will mess up the Ord diff --git a/hls-plugin-api/src/Ide/PluginUtils.hs b/hls-plugin-api/src/Ide/PluginUtils.hs index 19303516a..c5bb881b5 100644 --- a/hls-plugin-api/src/Ide/PluginUtils.hs +++ b/hls-plugin-api/src/Ide/PluginUtils.hs @@ -253,10 +253,8 @@ getNormalizedFilePath (PluginId plId) uri = handleMaybe errMsg errMsg = T.unpack $ "Error(" <> plId <> "): converting " <> getUri uri <> " to NormalizedFilePath" -- --------------------------------------------------------------------- -throwPluginError :: Monad m => PluginId -> String -> String -> ExceptT String m b -throwPluginError (PluginId who) what where' = throwE msg - where - msg = (T.unpack who) <> " failed with " <> what <> " at " <> where' +throwPluginError :: Monad m => String -> ExceptT String m b +throwPluginError = throwE handleMaybe :: Monad m => e -> Maybe b -> ExceptT e m b handleMaybe msg = maybe (throwE msg) return diff --git a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs index e240ee297..530ced8f7 100644 --- a/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs +++ b/plugins/hls-alternate-number-format-plugin/src/Ide/Plugin/AlternateNumberFormat.hs @@ -97,7 +97,6 @@ codeActionHandler state plId (CodeActionParams _ _ docId currRange _) = pluginRe literalPairs = map (\lit -> (lit, alternateFormat lit)) litsInRange -- make a code action for every literal and its' alternates (then flatten the result) actions = concatMap (\(lit, alts) -> map (mkCodeAction nfp lit enabledExtensions pragma) alts) literalPairs - pure $ List actions where inCurrentRange :: Literal -> Bool diff --git a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs index 0a4b1de41..ed6ad5e53 100644 --- a/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs +++ b/plugins/hls-call-hierarchy-plugin/src/Ide/Plugin/CallHierarchy/Internal.hs @@ -203,7 +203,7 @@ incomingCalls state pluginId param = pluginResponse $ do mergeIncomingCalls case calls of Just x -> pure $ Just $ List x - Nothing -> throwPluginError callHierarchyId "Internal Error" "incomingCalls" + Nothing -> throwPluginError "incomingCalls - Internal Error" where mkCallHierarchyIncomingCall :: Vertex -> Action (Maybe CallHierarchyIncomingCall) mkCallHierarchyIncomingCall = mkCallHierarchyCall CallHierarchyIncomingCall @@ -224,7 +224,7 @@ outgoingCalls state pluginId param = pluginResponse $ do mergeOutgoingCalls case calls of Just x -> pure $ Just $ List x - Nothing -> throwPluginError callHierarchyId "Internal Error" "outgoingCalls" + Nothing -> throwPluginError "outgoingCalls - Internal Error" where mkCallHierarchyOutgoingCall :: Vertex -> Action (Maybe CallHierarchyOutgoingCall) mkCallHierarchyOutgoingCall = mkCallHierarchyCall CallHierarchyOutgoingCall diff --git a/test/functional/Format.hs b/test/functional/Format.hs index 43e936684..af90fc7a9 100644 --- a/test/functional/Format.hs +++ b/test/functional/Format.hs @@ -47,7 +47,7 @@ providerTests = testGroup "formatting provider" [ testCase "respects none" $ runSessionWithConfig (formatConfig "none") hlsCommand fullCaps "test/testdata/format" $ do doc <- openDoc "Format.hs" "haskell" resp <- request STextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing) - liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available: []" Nothing) + liftIO $ resp ^. LSP.result @?= Left (ResponseError InvalidRequest "No plugin enabled for STextDocumentFormatting, available:\nPluginId \"floskell\"\nPluginId \"fourmolu\"\nPluginId \"ormolu\"\nPluginId \"stylish-haskell\"\nPluginId \"brittany\"\n" Nothing) , requiresOrmoluPlugin . requiresFloskellPlugin $ testCase "can change on the fly" $ runSession hlsCommand fullCaps "test/testdata/format" $ do formattedOrmolu <- liftIO $ T.readFile "test/testdata/format/Format.ormolu.formatted.hs"