diff options
| -rw-r--r-- | src/Language/GraphQL/Execute.hs | 60 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ExecuteSpec.hs | 5 |
2 files changed, 55 insertions, 10 deletions
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 3321152..8741ab5 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -2,11 +2,13 @@ v. 2.0. If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. -} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module Language.GraphQL.Execute ( Error(..) @@ -20,9 +22,11 @@ import Conduit (mapMC, (.|)) import Control.Arrow (left) import Control.Monad.Catch ( Exception(..) + , Handler(..) , MonadCatch(..) , MonadThrow(..) , SomeException(..) + , catches ) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT) @@ -38,6 +42,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Int (Int32) +import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromMaybe, isJust) @@ -46,6 +51,7 @@ import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text import Data.Typeable (cast) +import GHC.Records (HasField(..)) import qualified Language.GraphQL.Execute.Coerce as Coerce import Language.GraphQL.Execute.OrderedMap (OrderedMap) import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap @@ -61,6 +67,7 @@ import Language.GraphQL.Error , Path(..) , ResponseEventStream ) +import Numeric (showFloat) data Replacement m = Replacement { variableValues :: Type.Subs @@ -171,7 +178,8 @@ instance Exception ValueCompletionException where toException = graphQLExceptionToException fromException = graphQLExceptionFromException -data InputCoercionException = InputCoercionException String In.Type (Maybe (Full.Node Input)) +data InputCoercionException = + InputCoercionException String In.Type (Maybe (Full.Node Input)) instance Show InputCoercionException where show (InputCoercionException argumentName argumentType Nothing) = concat @@ -260,7 +268,28 @@ data Input | Enum Full.Name | List [Input] | Object (HashMap Full.Name Input) - deriving Show + deriving Eq + +instance Show Input where + showList = mappend . showList' + where + showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]" + show (Int integer) = show integer + show (Float float') = showFloat float' mempty + show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text + show (Boolean boolean') = show boolean' + show Null = "null" + show (Enum name) = Text.unpack name + show (List list) = show list + show (Object fields) = unwords + [ "{" + , intercalate ", " (HashMap.foldrWithKey showObject [] fields) + , "}" + ] + where + showObject key value accumulator = + concat [Text.unpack key, ": ", show value] : accumulator + show variableValue = show variableValue document :: Full.Document -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition) @@ -372,8 +401,9 @@ field (Full.Field alias' name' arguments' directives' selectionSet' location') = arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input)) arguments = foldM go HashMap.empty where - go accumulator (Full.Argument name' valueNode _) = do - argumentValue <- node valueNode + go accumulator (Full.Argument name' valueNode argumentLocation) = do + let replaceLocation = flip Full.Node argumentLocation . Full.node + argumentValue <- fmap replaceLocation <$> node valueNode pure $ insertIfGiven name' argumentValue accumulator directive :: Monad m => Full.Directive -> TransformT m Type.Directive @@ -555,14 +585,28 @@ executeField :: (MonadCatch m, Coerce.Serialize a) -> ExecutorT m a executeField objectValue fields resolver errorPath = let Field _ fieldName inputArguments _ fieldLocation :| _ = fields - in catch (go fieldName inputArguments) $ exceptionHandler fieldLocation + in catches (go fieldName inputArguments) + [ Handler (inputCoercionHandler fieldLocation) + , Handler (graphqlExceptionHandler fieldLocation) + ] where - exceptionHandler :: (MonadCatch m, Coerce.Serialize a) + inputCoercionHandler :: (MonadCatch m, Coerce.Serialize a) + => Full.Location + -> InputCoercionException + -> ExecutorT m a + inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = + let argumentLocation = getField @"location" valueNode + in exceptionHandler argumentLocation $ displayException e + inputCoercionHandler fieldLocation e = + exceptionHandler fieldLocation $ displayException e + graphqlExceptionHandler :: (MonadCatch m, Coerce.Serialize a) => Full.Location -> GraphQLException -> ExecutorT m a - exceptionHandler fieldLocation e = - let newError = Error (Text.pack $ displayException e) [fieldLocation] + graphqlExceptionHandler fieldLocation e = + exceptionHandler fieldLocation $ displayException e + exceptionHandler errorLocation exceptionText = + let newError = Error (Text.pack exceptionText) [errorLocation] $ reverse $ fieldsSegment fields : errorPath in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index fd10787..daa816d 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -285,9 +285,10 @@ spec = [ "philosopher" .= Aeson.Null ] executionErrors = pure $ Error - { message = "Argument coercing failed." + { message = + "Argument \"id\" has invalid type. Expected type ID, found: True." , locations = [Location 1 15] - , path = [] + , path = [Segment "philosopher"] } expected = Response data'' executionErrors Right (Right actual) = either (pure . parseError) execute' |