Handle errors

This commit is contained in:
Eugen Wissner 2021-08-30 06:51:24 +02:00
parent 2dafb00a16
commit f808d0664f

View File

@ -2,9 +2,10 @@
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 ExplicitForAll #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Language.GraphQL.Executor
@ -16,16 +17,21 @@ module Language.GraphQL.Executor
, executeRequest
) where
import Control.Monad.Catch
( Exception(..)
, MonadCatch(..)
, MonadThrow(..)
, SomeException(..)
)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), local, runReader)
import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT, tell)
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full
import qualified Data.Aeson as Aeson
import Data.Bifunctor (first)
import Data.Foldable (find)
import Data.Functor ((<&>))
import Data.Functor.Identity (Identity)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
@ -38,6 +44,7 @@ import Data.Sequence (Seq, (><))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (cast)
import qualified Language.GraphQL.Execute.Coerce as Coerce
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
@ -48,15 +55,15 @@ import qualified Language.GraphQL.Type.Internal as Type.Internal
import Language.GraphQL.Type.Schema (Schema, Type)
import qualified Language.GraphQL.Type.Schema as Schema
data Replacement = Replacement
data Replacement m = Replacement
{ variableValues :: Type.Subs
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, visitedFragments :: HashSet Full.Name
, types :: HashMap Full.Name (Type IO)
, types :: HashMap Full.Name (Type m)
}
newtype TransformT m a = TransformT
{ runTransformT :: ReaderT Replacement m a
{ runTransformT :: ReaderT (Replacement m) m a
}
instance Functor m => Functor (TransformT m) where
@ -72,7 +79,87 @@ instance Monad m => Monad (TransformT m) where
instance MonadTrans TransformT where
lift = TransformT . lift
type Transform = TransformT Identity
instance MonadThrow m => MonadThrow (TransformT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (TransformT m) where
catch (TransformT stack) handler =
TransformT $ catch stack $ runTransformT . handler
newtype ExecutorT m a = ExecutorT
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT [Error] m) a
}
instance Functor m => Functor (ExecutorT m) where
fmap f = ExecutorT . fmap f . runExecutorT
instance Applicative m => Applicative (ExecutorT m) where
pure = ExecutorT . pure
ExecutorT f <*> ExecutorT x = ExecutorT $ f <*> x
instance Monad m => Monad (ExecutorT m) where
ExecutorT x >>= f = ExecutorT $ x >>= runExecutorT . f
instance MonadTrans ExecutorT where
lift = ExecutorT . lift . lift
instance MonadThrow m => MonadThrow (ExecutorT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (ExecutorT m) where
catch (ExecutorT stack) handler =
ExecutorT $ catch stack $ runExecutorT . handler
data GraphQLException = forall e. Exception e => GraphQLException e
instance Show GraphQLException where
show (GraphQLException e) = show e
instance Exception GraphQLException
graphQLExceptionToException :: Exception e => e -> SomeException
graphQLExceptionToException = toException . GraphQLException
graphQLExceptionFromException :: Exception e => SomeException -> Maybe e
graphQLExceptionFromException e = do
GraphQLException graphqlException <- fromException e
cast graphqlException
data ResolverException = forall e. Exception e => ResolverException e
instance Show ResolverException where
show (ResolverException e) = show e
instance Exception ResolverException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
data FieldError
= ArgumentTypeError
| MissingArgumentError
| EnumCompletionError
| InterfaceCompletionError
| UnionCompletionError
| ValueCompletionError
| ResultCoercionError
| NullResultError
instance Show FieldError where
show ArgumentTypeError = "Invalid argument type."
show MissingArgumentError = "Required argument not specified."
show EnumCompletionError = "Enum value completion failed."
show InterfaceCompletionError = "Interface value completion failed."
show UnionCompletionError = "Union value completion failed."
show ValueCompletionError = "Value completion failed."
show ResultCoercionError = "Result coercion failed."
show NullResultError = "Non-Nullable field resolver returned Null."
newtype FieldException = FieldException FieldError
deriving Show
instance Exception FieldException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
data Segment = Segment String | Index Int
@ -82,8 +169,8 @@ data Error = Error
, path :: [Segment]
}
data Response = Response
{ data' :: Aeson.Object
data Response a = Response
{ data' :: a
, errors :: [Error]
}
@ -93,7 +180,7 @@ data QueryError
| CoercionError Full.VariableDefinition
| UnknownInputType Full.VariableDefinition
asks :: forall a. (Replacement -> a) -> Transform a
asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
asks = TransformT . Reader.asks
queryError :: QueryError -> Error
@ -125,49 +212,32 @@ queryError (UnknownInputType variableDefinition) =
]
in Error{ message = queryErrorMessage, locations = [location], path = [] }
respondWithQueryError :: QueryError -> Response
respondWithQueryError = Response mempty . pure . queryError
data Operation m = Operation Full.OperationType (Seq (Selection m))
-- operationName selectionSet location
data Operation = Operation
Full.OperationType
Type.Subs
SelectionSet
data Selection m
= FieldSelection (Field m)
| FragmentSelection (Fragment m)
type SelectionSet = Seq Selection
data Selection
= FieldSelection Field
| FragmentSelection Fragment
data Argument = Argument Full.Name (Full.Node Input) Full.Location
data Field = Field
data Field m = Field
(Maybe Full.Name)
Full.Name
[Argument]
SelectionSet
(HashMap Full.Name (Full.Node Input))
(Seq (Selection m))
Full.Location
data Fragment = Fragment
(Type.Internal.CompositeType IO) SelectionSet Full.Location
data Fragment m = Fragment
(Type.Internal.CompositeType m) (Seq (Selection m)) Full.Location
data Input
= Variable Full.Name
= Variable Type.Value
| Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
| Enum Full.Name
| List [Full.Node Input]
| Object [ObjectField]
data ObjectField = ObjectField
{ name :: Full.Name
, value :: Full.Node Input
, location :: Full.Location
}
| List [Input]
| Object (HashMap Full.Name Input)
document :: Full.Document
-> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
@ -181,26 +251,24 @@ document = foldr filterOperation ([], HashMap.empty)
HashMap.insert fragmentName fragmentDefinition <$> accumulator
filterOperation _ accumulator = accumulator -- Type system definitions.
transform :: Full.OperationDefinition -> Transform Operation
transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
transform (Full.OperationDefinition operationType _ _ _ selectionSet' _) = do
coercedVariableValues <- asks variableValues
transformedSelections <- selectionSet selectionSet'
pure $ Operation operationType coercedVariableValues transformedSelections
pure $ Operation operationType transformedSelections
transform (Full.SelectionSet selectionSet' _) = do
coercedVariableValues <- asks variableValues
transformedSelections <- selectionSet selectionSet'
pure $ Operation Full.Query coercedVariableValues transformedSelections
pure $ Operation Full.Query transformedSelections
selectionSet :: Full.SelectionSet -> Transform SelectionSet
selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
selectionSet = selectionSetOpt . NonEmpty.toList
selectionSetOpt :: Full.SelectionSetOpt -> Transform SelectionSet
selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))
selectionSetOpt = foldM go Seq.empty
where
go accumulatedSelections currentSelection =
selection currentSelection <&> (accumulatedSelections ><)
selection :: Full.Selection -> Transform SelectionSet
selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))
selection (Full.FieldSelection field') =
maybeToSelectionSet FieldSelection $ field field'
selection (Full.FragmentSpreadSelection fragmentSpread') =
@ -208,17 +276,19 @@ selection (Full.FragmentSpreadSelection fragmentSpread') =
selection (Full.InlineFragmentSelection inlineFragment') =
either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
maybeToSelectionSet :: forall a
. (a -> Selection)
-> Transform (Maybe a)
-> Transform SelectionSet
maybeToSelectionSet :: Monad m
=> forall a
. (a -> Selection m)
-> TransformT m (Maybe a)
-> TransformT m (Seq (Selection m))
maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType)
directives :: [Full.Directive] -> Transform (Maybe [Type.Directive])
directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Type.Directive])
directives = fmap Type.selection . traverse directive
inlineFragment :: Full.InlineFragment
-> Transform (Either SelectionSet Fragment)
inlineFragment :: Monad m
=> Full.InlineFragment
-> TransformT m (Either (Seq (Selection m)) (Fragment m))
inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
| Just typeCondition <- maybeCondition = do
transformedSelections <- selectionSet selectionSet'
@ -237,7 +307,7 @@ inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' loc
then Left transformedSelections
else Left Seq.empty
fragmentSpread :: Full.FragmentSpread -> Transform (Maybe Fragment)
fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))
fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
transformedDirectives <- directives directives'
visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
@ -263,10 +333,11 @@ fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
fragmentInserter replacement@Replacement{ visitedFragments } = replacement
{ visitedFragments = HashSet.insert spreadName visitedFragments }
field :: Full.Field -> Transform (Maybe Field)
field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))
field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
transformedSelections <- selectionSetOpt selectionSet'
transformedDirectives <- directives directives'
transformedArguments <- arguments arguments'
let transformedField = Field
alias'
name'
@ -274,24 +345,25 @@ field (Full.Field alias' name' arguments' directives' selectionSet' location') =
transformedSelections
location'
pure $ transformedDirectives >> pure transformedField
arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))
arguments = foldM go HashMap.empty
where
transformedArguments = argument <$> arguments'
go accumulator (Full.Argument name' valueNode _) = do
argumentValue <- node valueNode
pure $ insertIfGiven name' argumentValue accumulator
argument :: Full.Argument -> Argument
argument (Full.Argument name' valueNode location') =
Argument name' (node valueNode) location'
directive :: Full.Directive -> Transform Type.Directive
directive (Full.Directive name' arguments _)
directive :: Monad m => Full.Directive -> TransformT m Type.Directive
directive (Full.Directive name' arguments' _)
= Type.Directive name'
. Type.Arguments
<$> foldM go HashMap.empty arguments
<$> foldM go HashMap.empty arguments'
where
go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
transformedValue <- directiveValue node'
pure $ HashMap.insert argumentName transformedValue accumulator
directiveValue :: Full.Value -> Transform Type.Value
directiveValue :: Monad m => Full.Value -> TransformT m Type.Value
directiveValue = \case
(Full.Variable name') -> asks
$ HashMap.lookupDefault Type.Null name'
@ -311,47 +383,58 @@ directiveValue = \case
transformedValue <- directiveNode value
pure $ HashMap.insert name transformedValue accumulator
variableValue :: Full.Value -> Input
variableValue (Full.Variable name') = Variable name'
variableValue (Full.Int integer) = Int integer
variableValue (Full.Float double) = Float double
variableValue (Full.String string) = String string
variableValue (Full.Boolean boolean) = Boolean boolean
variableValue Full.Null = Null
variableValue (Full.Enum enum) = Enum enum
variableValue (Full.List list) = List $ node <$> list
variableValue (Full.Object objectFields) = Object $ objectField <$> objectFields
input :: Monad m => Full.Value -> TransformT m (Maybe Input)
input (Full.Variable name') =
asks (HashMap.lookup name' . variableValues) <&> fmap Variable
input (Full.Int integer) = pure $ Just $ Int integer
input (Full.Float double) = pure $ Just $ Float double
input (Full.String string) = pure $ Just $ String string
input (Full.Boolean boolean) = pure $ Just $ Boolean boolean
input Full.Null = pure $ Just Null
input (Full.Enum enum) = pure $ Just $ Enum enum
input (Full.List list) = Just . List
<$> traverse (fmap (fromMaybe Null) . input . Full.node) list
input (Full.Object objectFields) = Just . Object
<$> foldM objectField HashMap.empty objectFields
where
objectField :: Full.ObjectField Full.Value -> ObjectField
objectField Full.ObjectField{..} = ObjectField
{ name = name
, value = node value
, location = location
}
objectField accumulator Full.ObjectField{..} = do
objectFieldValue <- fmap Full.node <$> node value
pure $ insertIfGiven name objectFieldValue accumulator
node :: Full.Node Full.Value -> Full.Node Input
node Full.Node{node = node', ..} = Full.Node (variableValue node') location
insertIfGiven :: forall a
. Full.Name
-> Maybe a
-> HashMap Full.Name a
-> HashMap Full.Name a
insertIfGiven name (Just v) = HashMap.insert name v
insertIfGiven _ _ = id
executeRequest :: Schema IO
node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
node Full.Node{node = node', ..} =
traverse Full.Node <$> input node' <*> pure location
executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b)
=> Schema m
-> Full.Document
-> Maybe String
-> Aeson.Object
-> Aeson.Object
-> IO Response
executeRequest schema sourceDocument operationName variableValues initialValue =
-> HashMap Full.Name b
-> m (Response a)
executeRequest schema sourceDocument operationName variableValues = do
operationAndVariables <- sequence buildOperation
case operationAndVariables of
Left queryError' -> pure $ respondWithQueryError queryError'
Left queryError' -> pure
$ Response Coerce.null $ pure $ queryError queryError'
Right operation
| Operation Full.Query coercedVariables topSelections <- operation ->
executeQuery topSelections schema coercedVariables initialValue
| Operation Full.Mutation corecedVariables topSelections <- operation ->
executeMutation topSelections schema corecedVariables initialValue
| Operation Full.Subscription coercedVariables topSelections <- operation ->
subscribe topSelections schema coercedVariables initialValue
| Operation Full.Query topSelections <- operation ->
executeQuery topSelections schema
| Operation Full.Mutation topSelections <- operation ->
executeMutation topSelections schema
| Operation Full.Subscription topSelections <- operation ->
subscribe topSelections schema
where
schemaTypes = Schema.types schema
(operationDefinitions, fragmentDefinitions') = document sourceDocument
operationAndVariables = do
buildOperation = do
operationDefinition <- getOperation operationDefinitions operationName
coercedVariableValues <- coerceVariableValues
schemaTypes
@ -363,8 +446,7 @@ executeRequest schema sourceDocument operationName variableValues initialValue =
, visitedFragments = mempty
, types = schemaTypes
}
pure
$ flip runReader replacement
pure $ flip runReaderT replacement
$ runTransformT
$ transform operationDefinition
@ -379,77 +461,246 @@ getOperation operations (Just givenOperationName)
findOperationByName _ = False
getOperation _ _ = Left OperationNameRequired
executeQuery :: SelectionSet
-> Schema IO
-> Type.Subs
-> Aeson.Object
-> IO Response
executeQuery topSelections schema coercedVariables initialValue =
executeQuery :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Schema m
-> m (Response a)
executeQuery topSelections schema = do
let queryType = Schema.query schema
_data = executeSelectionSet topSelections queryType initialValue coercedVariables
in pure $ Response mempty mempty
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
$ executeSelectionSet topSelections queryType Type.Null []
pure $ Response data' errors
executeMutation :: forall m
. SelectionSet
executeMutation :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Schema m
-> Type.Subs
-> Aeson.Object
-> IO Response
executeMutation _operation _schema _coercedVariableValues _initialValue =
pure $ Response mempty mempty
-> m (Response a)
executeMutation topSelections schema
| Just mutationType <- Schema.mutation schema = do
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
$ executeSelectionSet topSelections mutationType Type.Null []
pure $ Response data' errors
| otherwise = pure $ Response Coerce.null
[Error "Schema doesn't define a mutation type." [] []]
subscribe :: forall m
. SelectionSet
-- TODO: Subscribe.
subscribe :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Schema m
-> Type.Subs
-> Aeson.Object
-> IO Response
subscribe _operation _schema _coercedVariableValues _initialValue =
pure $ Response mempty mempty
-> m (Response a)
subscribe _operation _schema =
pure $ Response Coerce.null mempty
executeSelectionSet
:: SelectionSet
-> Out.ObjectType IO
-> Aeson.Object
-> Type.Subs
-> Aeson.Object
executeSelectionSet selections objectType objectValue variableValues =
executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Out.ObjectType m
-> Type.Value
-> [Segment]
-> ExecutorT m a
executeSelectionSet selections objectType objectValue errorPath = do
let groupedFieldSet = collectFields objectType selections
in OrderedMap.foldlWithKey' go mempty groupedFieldSet
resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet
coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues
where
Out.ObjectType _ _ _ resolvers = objectType
executeField' fields resolver =
executeField objectType objectValue fields resolver variableValues
go resultMap responseKey fields@(Field _ fieldName _ _ _ :| _) =
case HashMap.lookup fieldName resolvers of
Just resolver ->
let responseValue = executeField' fields resolver
in HashMap.insert responseKey responseValue resultMap
Nothing -> resultMap
executeField objectValue fields resolver errorPath
Out.ObjectType _ _ _ resolvers = objectType
go fields@(Field _ fieldName _ _ _ :| _) =
traverse (executeField' fields) $ HashMap.lookup fieldName resolvers
executeField :: Out.ObjectType IO
-> Aeson.Object
-> NonEmpty Field
-> Out.Resolver IO
-> Type.Subs
-> Aeson.Value
executeField _objectType _objectValue fields fieldType _variableValues =
let _field'@(Field _ _fieldName inputArguments _ _) :| _ = fields
Out.Field _ _ argumentTypes = resolverField fieldType
_argumentValues = coerceArgumentValues argumentTypes inputArguments
in Aeson.Null
fieldsSegment :: forall m. NonEmpty (Field m) -> Segment
fieldsSegment (Field alias fieldName _ _ _ :| _) =
Segment (Text.unpack $ fromMaybe fieldName alias)
executeField :: (MonadCatch m, Coerce.Serialize a)
=> Type.Value
-> NonEmpty (Field m)
-> Out.Resolver m
-> [Segment]
-> ExecutorT m a
executeField objectValue fields resolver errorPath =
let Field _ fieldName inputArguments _ fieldLocation :| _ = fields
in catch (go fieldName inputArguments) $ exceptionHandler fieldLocation
where
resolverField (Out.ValueResolver resolverField' _) = resolverField'
resolverField (Out.EventStreamResolver resolverField' _ _) = resolverField'
exceptionHandler :: (MonadCatch m, Coerce.Serialize a)
=> Full.Location
-> GraphQLException
-> ExecutorT m a
exceptionHandler fieldLocation e =
let newError = Error (displayException e) [fieldLocation] errorPath
in ExecutorT (lift $ tell [newError]) >> pure Coerce.null
go fieldName inputArguments = do
let (Out.Field _ fieldType argumentTypes, resolveFunction) =
resolverField resolver
argumentValues <- coerceArgumentValues argumentTypes inputArguments
resolvedValue <-
resolveFieldValue resolveFunction objectValue fieldName argumentValues
completeValue fieldType fields errorPath resolvedValue
resolverField (Out.ValueResolver resolverField' resolveFunction) =
(resolverField', resolveFunction)
resolverField (Out.EventStreamResolver resolverField' resolveFunction _) =
(resolverField', resolveFunction)
coerceArgumentValues :: HashMap Full.Name In.Argument
-> [Argument]
-> Either [Full.Location] Type.Subs
coerceArgumentValues _argumentDefinitions _argumentNodes = pure mempty
resolveFieldValue :: MonadCatch m
=> Out.Resolve m
-> Type.Value
-> Full.Name
-> Type.Subs
-> ExecutorT m Type.Value
resolveFieldValue resolver objectValue _fieldName argumentValues =
lift $ runReaderT resolver context
where
context = Type.Context
{ Type.arguments = Type.Arguments argumentValues
, Type.values = objectValue
}
collectFields :: Out.ObjectType IO
-> SelectionSet
-> OrderedMap (NonEmpty Field)
resolveAbstractType :: Monad m
=> Type.Internal.AbstractType m
-> Type.Subs
-> ExecutorT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- ExecutorT ask
case HashMap.lookup typeName types' of
Just (Type.Internal.ObjectType objectType) ->
if Type.Internal.instanceOf objectType abstractType
then pure $ Just objectType
else pure Nothing
_ -> pure Nothing
| otherwise = pure Nothing
completeValue :: (MonadCatch m, Coerce.Serialize a)
=> Out.Type m
-> NonEmpty (Field m)
-> [Segment]
-> Type.Value
-> ExecutorT m a
completeValue outputType _ _ Type.Null
| Out.isNonNullType outputType = throwFieldError NullResultError
| otherwise = pure Coerce.null
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
= foldM go (0, []) list >>= coerceResult outputType . Coerce.List . snd
where
go (index, accumulator) listItem = do
let updatedPath = Index index : errorPath
completedValue <- completeValue listType fields updatedPath listItem
pure (index + 1, completedValue : accumulator)
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
coerceResult outputType $ Coerce.Int int
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
coerceResult outputType $ Coerce.Boolean boolean
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) =
coerceResult outputType $ Coerce.Float float
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) =
coerceResult outputType $ Coerce.String string
completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
then coerceResult outputType $ Coerce.Enum enum
else throwFieldError EnumCompletionError
completeValue (Out.ObjectBaseType objectType) fields errorPath result
= executeSelectionSet (mergeSelectionSets fields) objectType result
$ fieldsSegment fields : errorPath
completeValue (Out.InterfaceBaseType interfaceType) fields errorPath result
| Type.Object objectMap <- result = do
let abstractType = Type.Internal.AbstractInterfaceType interfaceType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType
-> executeSelectionSet (mergeSelectionSets fields) objectType result
$ fieldsSegment fields : errorPath
Nothing -> throwFieldError InterfaceCompletionError
completeValue (Out.UnionBaseType unionType) fields errorPath result
| Type.Object objectMap <- result = do
let abstractType = Type.Internal.AbstractUnionType unionType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType
-> executeSelectionSet (mergeSelectionSets fields) objectType result
$ fieldsSegment fields : errorPath
Nothing -> throwFieldError UnionCompletionError
completeValue _ _ _ _ = throwFieldError ValueCompletionError
coerceResult :: (MonadCatch m, Coerce.Serialize a)
=> Out.Type m
-> Coerce.Output a
-> ExecutorT m a
coerceResult outputType result
| Just serialized <- Coerce.serialize outputType result = pure serialized
| otherwise = throwFieldError ResultCoercionError
mergeSelectionSets :: MonadCatch m
=> NonEmpty (Field m)
-> Seq (Selection m)
mergeSelectionSets = foldr forEach mempty
where
forEach (Field _ _ _ fieldSelectionSet _) selectionSet' =
selectionSet' <> fieldSelectionSet
throwFieldError :: MonadCatch m => FieldError -> m a
throwFieldError = throwM . FieldException
coerceArgumentValues :: MonadCatch m
=> HashMap Full.Name In.Argument
-> HashMap Full.Name (Full.Node Input)
-> ExecutorT m Type.Subs
coerceArgumentValues argumentDefinitions argumentValues =
HashMap.foldrWithKey c pure argumentDefinitions mempty
where
c argumentName argumentType pure' resultMap =
forEach argumentName argumentType resultMap >>= pure'
forEach :: MonadCatch m
=> Full.Name
-> In.Argument
-> Type.Subs
-> m Type.Subs
forEach argumentName (In.Argument _ variableType defaultValue) resultMap = do
let matchedMap
= matchFieldValues' argumentName variableType defaultValue
$ Just resultMap
in case matchedMap of
Just matchedValues -> pure matchedValues
Nothing
| Just _ <- HashMap.lookup argumentName argumentValues ->
throwFieldError ArgumentTypeError
| otherwise -> throwFieldError MissingArgumentError
matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue
$ Full.node <$> argumentValues
coerceArgumentValue inputType (Int integer) =
Coerce.coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Boolean boolean) =
Coerce.coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (String string) =
Coerce.coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Float float) =
Coerce.coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Enum enum) =
Coerce.coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Null
| In.isNonNullType inputType = Nothing
| otherwise = Coerce.coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (List list) =
let coerceItem = coerceArgumentValue inputType
in Type.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
| In.InputObjectType _ _ inputFields <- inputType =
let go = forEachField object
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
in Type.Object <$> resultMap
coerceArgumentValue _ (Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) =
Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
-> OrderedMap (NonEmpty (Field m))
collectFields objectType = foldl forEach OrderedMap.empty
where
forEach groupedFields (FieldSelection fieldSelection) =
@ -464,11 +715,10 @@ collectFields objectType = foldl forEach OrderedMap.empty
in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
coerceVariableValues :: Coerce.VariableValue a
=> forall m
. HashMap Full.Name (Schema.Type m)
coerceVariableValues :: (Monad m, Coerce.VariableValue b)
=> HashMap Full.Name (Schema.Type m)
-> Full.OperationDefinition
-> HashMap Full.Name a
-> HashMap Full.Name b
-> Either QueryError Type.Subs
coerceVariableValues types operationDefinition' variableValues
| Full.OperationDefinition _ _ variableDefinitions _ _ _ <-