Skip to content

Commit

Permalink
Various PluginError PR suggestions I missed earlier (#3737)
Browse files Browse the repository at this point in the history
  • Loading branch information
@joyfulmantis
joyfulmantis authored Jul 31, 2023
1 parent 8d7555c commit ec1e6c1
Show file tree
Hide file tree
Showing 6 changed files with 116 additions and 248 deletions.
8 changes: 4 additions & 4 deletions ghcide/src/Development/IDE/Core/Shake.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -964,7 +964,7 @@ useWithStale key file = runIdentity <$> usesWithStale key (Identity file)
-- |Request a Rule result, it not available return the last computed result
-- which may be stale.
--
-- Throws an `BadDependency` IO exception which is caught by the rule system if
-- Throws an `BadDependency` exception which is caught by the rule system if
-- none available.
--
-- WARNING: Not suitable for PluginHandlers. Use `useWithStaleE` instead.
Expand All @@ -974,7 +974,7 @@ useWithStale_ key file = runIdentity <$> usesWithStale_ key (Identity file)

-- |Plural version of 'useWithStale_'
--
-- Throws an `BadDependency` IO exception which is caught by the rule system if
-- Throws an `BadDependency` exception which is caught by the rule system if
-- none available.
--
-- WARNING: Not suitable for PluginHandlers.
Expand Down Expand Up @@ -1053,7 +1053,7 @@ useNoFile key = use key emptyFilePath

-- Requests a rule if available.
--
-- Throws an `BadDependency` IO exception which is caught by the rule system if
-- Throws an `BadDependency` exception which is caught by the rule system if
-- none available.
--
-- WARNING: Not suitable for PluginHandlers. Use `useE` instead.
Expand All @@ -1065,7 +1065,7 @@ useNoFile_ key = use_ key emptyFilePath

-- |Plural version of `use_`
--
-- Throws an `BadDependency` IO exception which is caught by the rule system if
-- Throws an `BadDependency` exception which is caught by the rule system if
-- none available.
--
-- WARNING: Not suitable for PluginHandlers. Use `usesE` instead.
Expand Down
47 changes: 24 additions & 23 deletions ghcide/src/Development/IDE/Plugin/HLS.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,7 @@
module Development.IDE.Plugin.HLS
(
asGhcIdePlugin
, toResponseError
, Log(..)
) where

Expand Down Expand Up @@ -80,11 +81,17 @@ prettyResponseError err = errorCode <> ":" <+> errorBody
errorCode = pretty $ show $ err ^. L.code
errorBody = pretty $ err ^. L.message

pluginNotEnabled :: SMethod m -> [(PluginId, b, a)] -> Text
pluginNotEnabled method availPlugins =
"No plugin enabled for " <> T.pack (show method) <> ", potentially available: "
<> (T.intercalate ", " $ map (\(PluginId plid, _, _) -> plid) availPlugins)

noPluginEnabled :: Recorder (WithPriority Log) -> SMethod m -> [PluginId] -> IO (Either ResponseError c)
noPluginEnabled recorder m fs' = do
logWith recorder Warning (LogNoPluginForMethod $ Some m)
let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing
msg = pluginNotEnabled m fs'
return $ Left err
where pluginNotEnabled :: SMethod m -> [PluginId] -> Text
pluginNotEnabled method availPlugins =
"No plugin enabled for " <> T.pack (show method) <> ", potentially available: "
<> (T.intercalate ", " $ map (\(PluginId plid) -> plid) availPlugins)

pluginDoesntExist :: PluginId -> Text
pluginDoesntExist (PluginId pid) = "Plugin " <> pid <> " doesn't exist"

Expand Down Expand Up @@ -113,13 +120,6 @@ logAndReturnError recorder p errCode msg = do
logWith recorder Warning $ LogResponseError p err
pure $ Left err

-- | Logs the provider error before returning it to the caller
logAndReturnError' :: Recorder (WithPriority Log) -> (LSPErrorCodes |? ErrorCodes) -> Log -> LSP.LspT Config IO (Either ResponseError a)
logAndReturnError' recorder errCode msg = do
let err = ResponseError errCode (fromString $ show msg) Nothing
logWith recorder Warning $ msg
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) =
Expand Down Expand Up @@ -219,8 +219,15 @@ executeCommandHandlers recorder ecs = requestHandler SMethod_WorkspaceExecuteCom
Just (PluginCommand _ _ f) -> case A.fromJSON arg of
A.Error err -> logAndReturnError recorder p (InR ErrorCodes_InvalidParams) (failedToParseArgs com p err arg)
A.Success a -> do
(first (toResponseError . (p,)) <$> runExceptT (f ide a)) `catchAny` -- See Note [Exception handling in plugins]
(\e -> logAndReturnError' recorder (InR ErrorCodes_InternalError) (ExceptionInPlugin p (Some SMethod_WorkspaceApplyEdit) e))
res <- runExceptT (f ide a) `catchAny` -- See Note [Exception handling in plugins]
(\e -> pure $ Left $ PluginInternalError (exceptionInPlugin p SMethod_WorkspaceExecuteCommand e))
case res of
(Left (PluginRequestRefused _)) ->
liftIO $ noPluginEnabled recorder SMethod_WorkspaceExecuteCommand (fst <$> ecs)
(Left pluginErr) -> do
liftIO $ logErrors recorder [(p, pluginErr)]
pure $ Left $ toResponseError (p, pluginErr)
(Right result) -> pure $ Right result

-- ---------------------------------------------------------------------

Expand All @@ -242,7 +249,7 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
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 -> liftIO $ noPluginEnabled m fs'
Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')
Just fs -> do
let handlers = fmap (\(plid,_,handler) -> (plid,handler)) fs
es <- runConcurrently exceptionInPlugin m handlers ide params
Expand All @@ -255,16 +262,11 @@ extensiblePlugins recorder xs = mempty { P.pluginHandlers = handlers }
noRefused (_, _) = True
filteredErrs = filter noRefused errs
case nonEmpty filteredErrs of
Nothing -> liftIO $ noPluginEnabled m fs'
Nothing -> liftIO $ noPluginEnabled recorder m ((\(x, _, _) -> x) <$> fs')
Just xs -> pure $ Left $ combineErrors xs
Just xs -> do
pure $ Right $ combineResponses m config caps params xs
noPluginEnabled :: SMethod m -> [(PluginId, b, a)] -> IO (Either ResponseError c)
noPluginEnabled m fs' = do
logWith recorder Warning (LogNoPluginForMethod $ Some m)
let err = ResponseError (InR ErrorCodes_MethodNotFound) msg Nothing
msg = pluginNotEnabled m fs'
return $ Left err


-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -313,7 +315,6 @@ combineErrors :: NonEmpty (PluginId, PluginError) -> ResponseError
combineErrors (x NE.:| []) = toResponseError x
combineErrors xs = toResponseError $ NE.last $ NE.sortWith (toPriority . snd) xs


toResponseError :: (PluginId, PluginError) -> ResponseError
toResponseError (PluginId plId, err) =
ResponseError (toErrorCode err) (plId <> ": " <> tPretty err) Nothing
Expand Down
125 changes: 34 additions & 91 deletions ghcide/test/exe/ExceptionTests.hs
View file
Original file line number Diff line number Diff line change
@@ -1,9 +1,8 @@

module ExceptionTests (tests) where

import Control.Concurrent.Async
import Control.Exception (ArithException (DivideByZero),
finally, throwIO)
throwIO)
import Control.Lens
import Control.Monad.Error.Class (MonadError (throwError))
import Control.Monad.IO.Class (liftIO)
Expand All @@ -12,6 +11,7 @@ import Data.Text as T
import Development.IDE.Core.Shake (IdeState (..))
import qualified Development.IDE.LSP.Notifications as Notifications
import qualified Development.IDE.Main as IDE
import Development.IDE.Plugin.HLS (toResponseError)
import Development.IDE.Plugin.Test as Test
import Development.IDE.Types.Options
import GHC.Base (coerce)
Expand All @@ -30,8 +30,6 @@ import Language.LSP.Protocol.Types hiding
mkRange)
import Language.LSP.Test
import LogType (Log (..))
import System.Directory
import System.Process.Extra (createPipe)
import Test.Tasty
import Test.Tasty.HUnit
import TestUtils
Expand All @@ -50,7 +48,6 @@ tests recorder logger = do
pure (InL [])
]
}]

testIde recorder (testingLite recorder logger plugins) $ do
doc <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
Expand All @@ -60,6 +57,7 @@ tests recorder logger = do
liftIO $ assertBool "We caught an error, but it wasn't ours!"
(T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)
_ -> liftIO $ assertFailure $ show lens

, testCase "Commands" $ do
let pluginId = "command-exception"
commandId = CommandId "exception"
Expand All @@ -71,7 +69,6 @@ tests recorder logger = do
pure (InR Null)
]
}]

testIde recorder (testingLite recorder logger plugins) $ do
_ <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
Expand All @@ -83,6 +80,7 @@ tests recorder logger = do
liftIO $ assertBool "We caught an error, but it wasn't ours!"
(T.isInfixOf "divide by zero" _message && T.isInfixOf (coerce pluginId) _message)
_ -> liftIO $ assertFailure $ show res

, testCase "Notification Handlers" $ do
let pluginId = "notification-exception"
plugins = pluginDescToIdePlugins $
Expand All @@ -95,101 +93,24 @@ tests recorder logger = do
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
pure (InL [])
]
}
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]

}]
testIde recorder (testingLite recorder logger plugins) $ do
doc <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
case lens of
Right (InL []) ->
-- We don't get error responses from notification handlers, so
-- we can only make sure that the server is still responding
pure ()
_ -> liftIO $ assertFailure $ "We should have had an empty list" <> show lens]

, testGroup "Testing PluginError order..."
[ testCase "InternalError over InvalidParams" $ do
let pluginId = "internal-error-order"
plugins = pluginDescToIdePlugins $
[ (defaultPluginDescriptor pluginId)
{ pluginHandlers = mconcat
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ PluginInternalError "error test"
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ PluginInvalidParams "error test"
]
}
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]

testIde recorder (testingLite recorder logger plugins) $ do
doc <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
case lens of
Left (ResponseError {_code = InR ErrorCodes_InternalError, _message}) ->
liftIO $ assertBool "We caught an error, but it wasn't ours!"
(T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
_ -> liftIO $ assertFailure $ show lens
, testCase "InvalidParams over InvalidUserState" $ do
let pluginId = "invalid-params-order"
plugins = pluginDescToIdePlugins $
[ (defaultPluginDescriptor pluginId)
{ pluginHandlers = mconcat
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ PluginInvalidParams "error test"
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ PluginInvalidUserState "error test"
]
}
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]

testIde recorder (testingLite recorder logger plugins) $ do
doc <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
case lens of
Left (ResponseError {_code = InR ErrorCodes_InvalidParams, _message}) ->
liftIO $ assertBool "We caught an error, but it wasn't ours!"
(T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
_ -> liftIO $ assertFailure $ show lens
, testCase "InvalidUserState over RequestRefused" $ do
let pluginId = "invalid-user-state-order"
plugins = pluginDescToIdePlugins $
[ (defaultPluginDescriptor pluginId)
{ pluginHandlers = mconcat
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ PluginInvalidUserState "error test"
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ PluginRequestRefused "error test"
]
}
, Notifications.descriptor (cmapWithPrio LogNotifications recorder) "ghcide-core"]

testIde recorder (testingLite recorder logger plugins) $ do
doc <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
case lens of
Left (ResponseError {_code = InL LSPErrorCodes_RequestFailed, _message}) ->
liftIO $ assertBool "We caught an error, but it wasn't ours!"
(T.isInfixOf "error test" _message && T.isInfixOf (coerce pluginId) _message)
_ -> liftIO $ assertFailure $ show lens
]]

testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO ()
testIde recorder arguments session = do
config <- getConfigFromEnv
cwd <- getCurrentDirectory
(hInRead, hInWrite) <- createPipe
(hOutRead, hOutWrite) <- createPipe
let projDir = "."
let server = IDE.defaultMain (cmapWithPrio LogIDEMain recorder) arguments
{ IDE.argsHandleIn = pure hInRead
, IDE.argsHandleOut = pure hOutWrite
}

flip finally (setCurrentDirectory cwd) $ withAsync server $ \_ ->
runSessionWithHandles hInWrite hOutRead config lspTestCaps projDir session
[ pluginOrderTestCase recorder logger "InternalError over InvalidParams" PluginInternalError PluginInvalidParams
, pluginOrderTestCase recorder logger "InvalidParams over InvalidUserState" PluginInvalidParams PluginInvalidUserState
, pluginOrderTestCase recorder logger "InvalidUserState over RequestRefused" PluginInvalidUserState PluginRequestRefused
]
]

testingLite :: Recorder (WithPriority Log) -> Logger -> IdePlugins IdeState -> IDE.Arguments
testingLite recorder logger plugins =
Expand All @@ -210,3 +131,25 @@ testingLite recorder logger plugins =
{ IDE.argsHlsPlugins = hlsPlugins
, IDE.argsIdeOptions = ideOptions
}

pluginOrderTestCase :: Recorder (WithPriority Log) -> Logger -> TestName -> (T.Text -> PluginError) -> (T.Text -> PluginError) -> TestTree
pluginOrderTestCase recorder logger msg err1 err2 =
testCase msg $ do
let pluginId = "error-order-test"
plugins = pluginDescToIdePlugins $
[ (defaultPluginDescriptor pluginId)
{ pluginHandlers = mconcat
[ mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ err1 "error test"
,mkPluginHandler SMethod_TextDocumentCodeLens $ \_ _ _-> do
throwError $ err2 "error test"
]
}]
testIde recorder (testingLite recorder logger plugins) $ do
doc <- createDoc "A.hs" "haskell" "module A where"
waitForProgressDone
(view L.result -> lens) <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
case lens of
Left re | toResponseError (pluginId, err1 "error test") == re -> pure ()
| otherwise -> liftIO $ assertFailure "We caught an error, but it wasn't ours!"
_ -> liftIO $ assertFailure $ show lens
Loading

0 comments on commit ec1e6c1

Please sign in to comment.