mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-08-17 04:20:37 +03:00
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
This commit is contained in:
parent
510bd51e46
commit
73652d7515
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
Loading…
Reference in New Issue
Block a user