Validate field selections on composite types

This commit is contained in:
Eugen Wissner 2020-09-25 21:57:25 +02:00
parent 9bfa2aa7e8
commit 3373c94895
10 changed files with 295 additions and 174 deletions

View File

@ -27,7 +27,6 @@ and this project adheres to
### Added ### Added
- `Validate.Validation.Rule` constructors: - `Validate.Validation.Rule` constructors:
- `SelectionRule` - `SelectionRule`
- `FieldRule`
- `FragmentRule` - `FragmentRule`
- `FragmentSpreadRule` - `FragmentSpreadRule`
- `ArgumentsRule` - `ArgumentsRule`
@ -47,6 +46,7 @@ and this project adheres to
- `noUndefinedVariablesRule` - `noUndefinedVariablesRule`
- `noUnusedVariablesRule` - `noUnusedVariablesRule`
- `uniqueInputFieldNamesRule` - `uniqueInputFieldNamesRule`
- `fieldsOnCorrectTypeRule`
- `AST.Document.Field`. - `AST.Document.Field`.
- `AST.Document.FragmentSpread`. - `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`. - `AST.Document.InlineFragment`.

View File

@ -124,7 +124,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers in if HashMap.member enum enumMembers
then coerceResult outputType $ Enum enum then coerceResult outputType $ Enum enum
else addErrMsg "Value completion failed." else addErrMsg "Enum value completion failed."
completeValue (Out.ObjectBaseType objectType) fields result = completeValue (Out.ObjectBaseType objectType) fields result =
executeSelectionSet result objectType $ mergeSelectionSets fields executeSelectionSet result objectType $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result completeValue (Out.InterfaceBaseType interfaceType) fields result
@ -134,7 +134,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
case concreteType of case concreteType of
Just objectType -> executeSelectionSet result objectType Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields $ mergeSelectionSets fields
Nothing -> addErrMsg "Value completion failed." Nothing -> addErrMsg "Interface value completion failed."
completeValue (Out.UnionBaseType unionType) fields result completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do | Type.Object objectMap <- result = do
let abstractType = AbstractUnionType unionType let abstractType = AbstractUnionType unionType
@ -142,7 +142,7 @@ completeValue (Out.UnionBaseType unionType) fields result
case concreteType of case concreteType of
Just objectType -> executeSelectionSet result objectType Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields $ mergeSelectionSets fields
Nothing -> addErrMsg "Value completion failed." Nothing -> addErrMsg "Union value completion failed."
completeValue _ _ _ = addErrMsg "Value completion failed." completeValue _ _ _ = addErrMsg "Value completion failed."
mergeSelectionSets :: MonadCatch m mergeSelectionSets :: MonadCatch m

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
module Language.GraphQL.Type.Internal module Language.GraphQL.Type.Internal
( AbstractType(..) ( AbstractType(..)
@ -12,10 +13,12 @@ module Language.GraphQL.Type.Internal
, instanceOf , instanceOf
, lookupInputType , lookupInputType
, lookupTypeCondition , lookupTypeCondition
, lookupTypeField
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
@ -55,41 +58,41 @@ collectReferencedTypes schema =
getField (Out.ValueResolver field _) = field getField (Out.ValueResolver field _) = field
getField (Out.EventStreamResolver field _ _) = field getField (Out.EventStreamResolver field _ _) = field
traverseInputType (In.InputObjectBaseType objectType) = traverseInputType (In.InputObjectBaseType objectType) =
let (In.InputObjectType typeName _ inputFields) = objectType let In.InputObjectType typeName _ inputFields = objectType
element = InputObjectType objectType element = InputObjectType objectType
traverser = flip (foldr visitInputFields) inputFields traverser = flip (foldr visitInputFields) inputFields
in collect traverser typeName element in collect traverser typeName element
traverseInputType (In.ListBaseType listType) = traverseInputType (In.ListBaseType listType) =
traverseInputType listType traverseInputType listType
traverseInputType (In.ScalarBaseType scalarType) = traverseInputType (In.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType let Definition.ScalarType typeName _ = scalarType
in collect Prelude.id typeName (ScalarType scalarType) in collect Prelude.id typeName (ScalarType scalarType)
traverseInputType (In.EnumBaseType enumType) = traverseInputType (In.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType let Definition.EnumType typeName _ _ = enumType
in collect Prelude.id typeName (EnumType enumType) in collect Prelude.id typeName (EnumType enumType)
traverseOutputType (Out.ObjectBaseType objectType) = traverseOutputType (Out.ObjectBaseType objectType) =
traverseObjectType objectType traverseObjectType objectType
traverseOutputType (Out.InterfaceBaseType interfaceType) = traverseOutputType (Out.InterfaceBaseType interfaceType) =
traverseInterfaceType interfaceType traverseInterfaceType interfaceType
traverseOutputType (Out.UnionBaseType unionType) = traverseOutputType (Out.UnionBaseType unionType) =
let (Out.UnionType typeName _ types) = unionType let Out.UnionType typeName _ types = unionType
traverser = flip (foldr traverseObjectType) types traverser = flip (foldr traverseObjectType) types
in collect traverser typeName (UnionType unionType) in collect traverser typeName (UnionType unionType)
traverseOutputType (Out.ListBaseType listType) = traverseOutputType (Out.ListBaseType listType) =
traverseOutputType listType traverseOutputType listType
traverseOutputType (Out.ScalarBaseType scalarType) = traverseOutputType (Out.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType let Definition.ScalarType typeName _ = scalarType
in collect Prelude.id typeName (ScalarType scalarType) in collect Prelude.id typeName (ScalarType scalarType)
traverseOutputType (Out.EnumBaseType enumType) = traverseOutputType (Out.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType let Definition.EnumType typeName _ _ = enumType
in collect Prelude.id typeName (EnumType enumType) in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes = traverseObjectType objectType foundTypes =
let (Out.ObjectType typeName _ interfaces fields) = objectType let Out.ObjectType typeName _ interfaces fields = objectType
element = ObjectType objectType element = ObjectType objectType
traverser = polymorphicTraverser interfaces (getField <$> fields) traverser = polymorphicTraverser interfaces (getField <$> fields)
in collect traverser typeName element foundTypes in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes = traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType let Out.InterfaceType typeName _ interfaces fields = interfaceType
element = InterfaceType interfaceType element = InterfaceType interfaceType
traverser = polymorphicTraverser interfaces fields traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes in collect traverser typeName element foundTypes
@ -161,3 +164,21 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
= In.NonNullListType = In.NonNullListType
<$> lookupInputType nonNull types <$> lookupInputType nonNull types
lookupTypeField :: forall a. Text -> Out.Type a -> Maybe (Out.Type a)
lookupTypeField fieldName = \case
Out.ObjectBaseType objectType ->
objectChild objectType
Out.InterfaceBaseType interfaceType ->
interfaceChild interfaceType
Out.ListBaseType listType -> lookupTypeField fieldName listType
_ -> Nothing
where
objectChild (Out.ObjectType _ _ _ resolvers) =
resolverType <$> HashMap.lookup fieldName resolvers
interfaceChild (Out.InterfaceType _ _ _ fields) =
fieldType <$> HashMap.lookup fieldName fields
resolverType (Out.ValueResolver objectField _) = fieldType objectField
resolverType (Out.EventStreamResolver objectField _ _) =
fieldType objectField
fieldType (Out.Field _ type' _) = type'

View File

@ -2,8 +2,8 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can 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/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | GraphQL validator. -- | GraphQL validator.
module Language.GraphQL.Validate module Language.GraphQL.Validate
@ -16,14 +16,21 @@ import Control.Monad (join)
import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq(..), (><), (|>)) import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema(..)) import Language.GraphQL.Type.Schema (Schema(..))
import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Rules import Language.GraphQL.Validate.Rules
import Language.GraphQL.Validate.Validation import Language.GraphQL.Validate.Validation
type ApplyRule m a =
HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m)
-- | Validates a document and returns a list of found errors. If the returned -- | Validates a document and returns a list of found errors. If the returned
-- list is empty, the document is valid. -- list is empty, the document is valid.
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
@ -37,16 +44,20 @@ document schema' rules' document' =
} }
reader = do reader = do
rule' <- lift $ Seq.fromList rules' rule' <- lift $ Seq.fromList rules'
join $ lift $ foldr (definition rule') Seq.empty document' join $ lift $ foldr (definition rule' context) Seq.empty document'
definition :: Rule m -> Definition -> Seq (RuleT m) -> Seq (RuleT m) definition :: Rule m
definition (DefinitionRule rule) definition' accumulator = -> Validation m
-> Definition
-> Seq (RuleT m)
-> Seq (RuleT m)
definition (DefinitionRule rule) _ definition' accumulator =
accumulator |> rule definition' accumulator |> rule definition'
definition rule (ExecutableDefinition executableDefinition') accumulator = definition rule context (ExecutableDefinition definition') accumulator =
accumulator >< executableDefinition rule executableDefinition' accumulator >< executableDefinition rule context definition'
definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator = definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
accumulator >< typeSystemDefinition rule typeSystemDefinition' accumulator >< typeSystemDefinition rule typeSystemDefinition'
definition rule (TypeSystemExtension extension _) accumulator = definition rule _ (TypeSystemExtension extension _) accumulator =
accumulator >< typeSystemExtension rule extension accumulator >< typeSystemExtension rule extension
typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m) typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
@ -82,11 +93,14 @@ schemaExtension rule = \case
SchemaOperationExtension directives' _ -> directives rule directives' SchemaOperationExtension directives' _ -> directives rule directives'
SchemaDirectivesExtension directives' -> directives rule directives' SchemaDirectivesExtension directives' -> directives rule directives'
executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m) executableDefinition :: Rule m
executableDefinition rule (DefinitionOperation operation) = -> Validation m
operationDefinition rule operation -> ExecutableDefinition
executableDefinition rule (DefinitionFragment fragment) = -> Seq (RuleT m)
fragmentDefinition rule fragment executableDefinition rule context (DefinitionOperation operation) =
operationDefinition rule context operation
executableDefinition rule context (DefinitionFragment fragment) =
fragmentDefinition rule context fragment
typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m) typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m)
typeSystemDefinition rule = \case typeSystemDefinition rule = \case
@ -124,58 +138,101 @@ inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') = inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
directives rule directives' directives rule directives'
operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m) operationDefinition :: Rule m
operationDefinition rule operation -> Validation m
-> OperationDefinition
-> Seq (RuleT m)
operationDefinition rule context operation
| OperationDefinitionRule operationRule <- rule = | OperationDefinitionRule operationRule <- rule =
pure $ operationRule operation pure $ operationRule operation
| VariablesRule variablesRule <- rule | VariablesRule variablesRule <- rule
, OperationDefinition _ _ variables _ _ _ <- operation , OperationDefinition _ _ variables _ _ _ <- operation
= Seq.fromList (variableDefinition rule <$> variables) = Seq.fromList (variableDefinition rule <$> variables)
|> variablesRule variables |> variablesRule variables
| SelectionSet selections _ <- operation = selectionSet rule selections | SelectionSet selections _ <- operation =
| OperationDefinition _ _ _ directives' selections _ <- operation = selectionSet types' rule (getRootType Query) selections
selectionSet rule selections >< directives rule directives' | OperationDefinition operationType _ _ directives' selections _ <- operation
= selectionSet types' rule (getRootType operationType) selections
>< directives rule directives'
where
types' = types context
getRootType Query = Just $ Out.NamedObjectType $ query $ schema context
getRootType Mutation = Out.NamedObjectType <$> mutation (schema context)
getRootType Subscription =
Out.NamedObjectType <$> subscription (schema context)
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
typeToOut (Schema.ObjectType objectType) =
Just $ Out.NamedObjectType objectType
typeToOut (Schema.InterfaceType interfaceType) =
Just $ Out.NamedInterfaceType interfaceType
typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType
typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
typeToOut _ = Nothing
variableDefinition :: Rule m -> VariableDefinition -> RuleT m variableDefinition :: Rule m -> VariableDefinition -> RuleT m
variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) = variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
maybe (lift mempty) rule value maybe (lift mempty) rule value
variableDefinition _ _ = lift mempty variableDefinition _ _ = lift mempty
fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m) fragmentDefinition :: forall m
fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' = . Rule m
pure $ rule fragmentDefinition' -> Validation m
fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _) -> FragmentDefinition
| FragmentRule definitionRule _ <- rule = -> Seq (RuleT m)
applyToChildren |> definitionRule fragmentDefinition' fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
| otherwise = applyToChildren pure $ rule definition'
fragmentDefinition rule context definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
, FragmentRule definitionRule _ <- rule
= applyToChildren typeCondition directives' selections
|> definitionRule definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
= applyToChildren typeCondition directives' selections
where where
applyToChildren = selectionSet rule selections types' = types context
applyToChildren typeCondition directives' selections
= selectionSet types' rule (lookupType' typeCondition) selections
>< directives rule directives' >< directives rule directives'
lookupType' = flip lookupType types'
selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m) lookupType :: forall m
selectionSet = foldMap . selection . TypeCondition
-> HashMap Name (Schema.Type m)
-> Maybe (Out.Type m)
lookupType typeCondition types' = HashMap.lookup typeCondition types'
>>= typeToOut
selection :: Rule m -> Selection -> Seq (RuleT m) selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
selection rule selection' selectionSet types' rule = foldMap . selection types' rule
selection :: forall m. ApplyRule m Selection
selection types' rule objectType selection'
| SelectionRule selectionRule <- rule = | SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule selection' applyToChildren |> selectionRule objectType selection'
| otherwise = applyToChildren | otherwise = applyToChildren
where where
applyToChildren = applyToChildren =
case selection' of case selection' of
FieldSelection field' -> field rule field' FieldSelection field' -> field types' rule objectType field'
InlineFragmentSelection inlineFragment' -> InlineFragmentSelection inlineFragment' ->
inlineFragment rule inlineFragment' inlineFragment types' rule objectType inlineFragment'
FragmentSpreadSelection fragmentSpread' -> FragmentSpreadSelection fragmentSpread' ->
fragmentSpread rule fragmentSpread' fragmentSpread rule fragmentSpread'
field :: Rule m -> Field -> Seq (RuleT m) field :: forall m. ApplyRule m Field
field rule field'@(Field _ _ arguments' directives' selections _) field types' rule objectType field' = go field'
| FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
| ArgumentsRule fieldRule _ <- rule = applyToChildren |> fieldRule field'
| otherwise = applyToChildren
where where
applyToChildren = selectionSet rule selections go (Field _ fieldName arguments' directives' selections _)
| ArgumentsRule fieldRule _ <- rule
= applyToChildren fieldName arguments' directives' selections
|> fieldRule field'
| otherwise =
applyToChildren fieldName arguments' directives' selections
applyToChildren fieldName arguments' directives' selections =
let child = objectType >>= lookupTypeField fieldName
in selectionSet types' rule child selections
>< directives rule directives' >< directives rule directives'
>< arguments rule arguments' >< arguments rule arguments'
@ -186,13 +243,18 @@ argument :: Rule m -> Argument -> RuleT m
argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
argument _ _ = lift mempty argument _ _ = lift mempty
inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m) inlineFragment :: forall m. ApplyRule m InlineFragment
inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _) inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
| FragmentRule _ fragmentRule <- rule =
applyToChildren |> fragmentRule inlineFragment'
| otherwise = applyToChildren
where where
applyToChildren = selectionSet rule selections go (InlineFragment optionalType directives' selections _)
| FragmentRule _ fragmentRule <- rule
= applyToChildren (refineTarget optionalType) directives' selections
|> fragmentRule inlineFragment'
| otherwise = applyToChildren (refineTarget optionalType) directives' selections
refineTarget (Just typeCondition) = lookupType typeCondition types'
refineTarget Nothing = objectType
applyToChildren objectType' directives' selections
= selectionSet types' rule objectType' selections
>< directives rule directives' >< directives rule directives'
fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m) fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)

View File

@ -10,6 +10,7 @@
-- | This module contains default rules defined in the GraphQL specification. -- | This module contains default rules defined in the GraphQL specification.
module Language.GraphQL.Validate.Rules module Language.GraphQL.Validate.Rules
( executableDefinitionsRule ( executableDefinitionsRule
, fieldsOnCorrectTypeRule
, fragmentsOnCompositeTypesRule , fragmentsOnCompositeTypesRule
, fragmentSpreadTargetDefinedRule , fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule , fragmentSpreadTypeExistenceRule
@ -40,14 +41,16 @@ import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet) import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn) import Data.List (groupBy, sortBy, sortOn)
import Data.Maybe (mapMaybe) import Data.Maybe (isJust, mapMaybe)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Sequence (Seq(..)) import Data.Sequence (Seq(..))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import qualified Language.GraphQL.Type.Definition as Definition
import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation import Language.GraphQL.Validate.Validation
@ -63,6 +66,8 @@ specifiedRules =
, singleFieldSubscriptionsRule , singleFieldSubscriptionsRule
, loneAnonymousOperationRule , loneAnonymousOperationRule
, uniqueOperationNamesRule , uniqueOperationNamesRule
-- Fields
, fieldsOnCorrectTypeRule
-- Arguments. -- Arguments.
, uniqueArgumentNamesRule , uniqueArgumentNamesRule
-- Fragments. -- Fragments.
@ -297,7 +302,7 @@ isSpreadTarget _ _ = False
-- for both named and inline fragments. If they are not defined in the schema, -- for both named and inline fragments. If they are not defined in the schema,
-- the query does not validate. -- the query does not validate.
fragmentSpreadTypeExistenceRule :: forall m. Rule m fragmentSpreadTypeExistenceRule :: forall m. Rule m
fragmentSpreadTypeExistenceRule = SelectionRule $ \case fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
FragmentSpreadSelection fragmentSelection FragmentSpreadSelection fragmentSelection
| FragmentSpread fragmentName _ location <- fragmentSelection -> do | FragmentSpread fragmentName _ location <- fragmentSelection -> do
ast' <- asks ast ast' <- asks ast
@ -672,3 +677,36 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
<> filterFieldDuplicates fields <> filterFieldDuplicates fields
constGo (ConstList values) = foldMap constGo values constGo (ConstList values) = foldMap constGo values
constGo _ = mempty constGo _ = mempty
-- | The target field of a field selection must be defined on the scoped type of
-- the selection set. There are no limitations on alias names.
fieldsOnCorrectTypeRule :: forall m. Rule m
fieldsOnCorrectTypeRule = SelectionRule go
where
go (Just objectType) (FieldSelection fieldSelection) =
fieldRule objectType fieldSelection
go _ _ = lift mempty
fieldRule objectType (Field _ fieldName _ _ _ location)
| isJust (lookupTypeField fieldName objectType) = lift mempty
| otherwise = pure $ Error
{ message = errorMessage fieldName objectType
, locations = [location]
}
errorMessage fieldName objectType = concat
[ "Cannot query field \""
, Text.unpack fieldName
, "\" on type \""
, Text.unpack $ outputTypeName objectType
, "\"."
]
outputTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
typeName
outputTypeName (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) =
typeName
outputTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =
typeName
outputTypeName (Out.ScalarBaseType (Definition.ScalarType typeName _)) =
typeName
outputTypeName (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
typeName
outputTypeName (Out.ListBaseType wrappedType) = outputTypeName wrappedType

View File

@ -14,6 +14,7 @@ import Control.Monad.Trans.Reader (ReaderT)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq) import Data.Sequence (Seq)
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema) import Language.GraphQL.Type.Schema (Schema)
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
@ -37,10 +38,9 @@ data Rule m
= DefinitionRule (Definition -> RuleT m) = DefinitionRule (Definition -> RuleT m)
| OperationDefinitionRule (OperationDefinition -> RuleT m) | OperationDefinitionRule (OperationDefinition -> RuleT m)
| FragmentDefinitionRule (FragmentDefinition -> RuleT m) | FragmentDefinitionRule (FragmentDefinition -> RuleT m)
| SelectionRule (Selection -> RuleT m) | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
| FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m) | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
| FragmentSpreadRule (FragmentSpread -> RuleT m) | FragmentSpreadRule (FragmentSpread -> RuleT m)
| FieldRule (Field -> RuleT m)
| ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m) | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
| DirectivesRule ([Directive] -> RuleT m) | DirectivesRule ([Directive] -> RuleT m)
| VariablesRule ([VariableDefinition] -> RuleT m) | VariablesRule ([VariableDefinition] -> RuleT m)

View File

@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
( spec ( spec
) where ) where
import Data.Sequence (Seq(..)) import Data.Foldable (toList)
import qualified Data.Sequence as Seq
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text) import Data.Text (Text)
import qualified Language.GraphQL.AST as AST import qualified Language.GraphQL.AST as AST
@ -18,7 +17,7 @@ import Language.GraphQL.Type
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Validate import Language.GraphQL.Validate
import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
@ -30,11 +29,17 @@ schema = Schema
} }
queryType :: ObjectType IO queryType :: ObjectType IO
queryType = ObjectType "Query" Nothing [] queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
$ HashMap.singleton "dog" dogResolver [ ("dog", dogResolver)
, ("findDog", findDogResolver)
]
where where
dogField = Field Nothing (Out.NamedObjectType dogType) mempty dogField = Field Nothing (Out.NamedObjectType dogType) mempty
dogResolver = ValueResolver dogField $ pure Null dogResolver = ValueResolver dogField $ pure Null
findDogArguments = HashMap.singleton "complex"
$ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
findDogResolver = ValueResolver findDogField $ pure Null
dogCommandType :: EnumType dogCommandType :: EnumType
dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
@ -72,6 +77,12 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
ownerResolver = ValueResolver ownerField $ pure Null ownerResolver = ValueResolver ownerField $ pure Null
dogDataType :: InputObjectType
dogDataType = InputObjectType "DogData" Nothing
$ HashMap.singleton "name" nameInputField
where
nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
sentientType :: InterfaceType IO sentientType :: InterfaceType IO
sentientType = InterfaceType "Sentient" Nothing [] sentientType = InterfaceType "Sentient" Nothing []
$ HashMap.singleton "name" $ HashMap.singleton "name"
@ -114,39 +125,14 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
petsResolver = ValueResolver petsField $ pure $ List [] petsResolver = ValueResolver petsField $ pure $ List []
{- {-
catCommandType :: EnumType
catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
[ ("JUMP", EnumValue Nothing)
]
catType :: ObjectType IO
catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
[ ("name", nameResolver)
, ("nickname", nicknameResolver)
, ("doesKnowCommand", doesKnowCommandResolver)
, ("meowVolume", meowVolumeResolver)
]
where
nameField = Field Nothing (Out.NonNullScalarType string) mempty
nameResolver = ValueResolver nameField $ pure "Name"
nicknameField = Field Nothing (Out.NamedScalarType string) mempty
nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
$ HashMap.singleton "catCommand"
$ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
doesKnowCommandResolver = ValueResolver doesKnowCommandField
$ pure $ Boolean True
meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2
catOrDogType :: UnionType IO catOrDogType :: UnionType IO
catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType] catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
-} -}
validate :: Text -> Seq Error validate :: Text -> [Error]
validate queryString = validate queryString =
case parse AST.document "" queryString of case parse AST.document "" queryString of
Left _ -> Seq.empty Left _ -> []
Right ast -> document schema specifiedRules ast Right ast -> toList $ document schema specifiedRules ast
spec :: Spec spec :: Spec
spec = spec =
@ -169,7 +155,7 @@ spec =
"Definition must be OperationDefinition or FragmentDefinition." "Definition must be OperationDefinition or FragmentDefinition."
, locations = [AST.Location 9 15] , locations = [AST.Location 9 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldContain` [expected]
it "rejects multiple subscription root fields" $ it "rejects multiple subscription root fields" $
let queryString = [r| let queryString = [r|
@ -186,7 +172,7 @@ spec =
"Subscription sub must select only one top level field." "Subscription sub must select only one top level field."
, locations = [AST.Location 2 15] , locations = [AST.Location 2 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldContain` [expected]
it "rejects multiple subscription root fields coming from a fragment" $ it "rejects multiple subscription root fields coming from a fragment" $
let queryString = [r| let queryString = [r|
@ -207,7 +193,7 @@ spec =
"Subscription sub must select only one top level field." "Subscription sub must select only one top level field."
, locations = [AST.Location 2 15] , locations = [AST.Location 2 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldContain` [expected]
it "rejects multiple anonymous operations" $ it "rejects multiple anonymous operations" $
let queryString = [r| let queryString = [r|
@ -230,7 +216,7 @@ spec =
"This anonymous operation must be the only defined operation." "This anonymous operation must be the only defined operation."
, locations = [AST.Location 2 15] , locations = [AST.Location 2 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects operations with the same name" $ it "rejects operations with the same name" $
let queryString = [r| let queryString = [r|
@ -251,7 +237,7 @@ spec =
"There can be only one operation named \"dogOperation\"." "There can be only one operation named \"dogOperation\"."
, locations = [AST.Location 2 15, AST.Location 8 15] , locations = [AST.Location 2 15, AST.Location 8 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects fragments with the same name" $ it "rejects fragments with the same name" $
let queryString = [r| let queryString = [r|
@ -276,7 +262,7 @@ spec =
"There can be only one fragment named \"fragmentOne\"." "There can be only one fragment named \"fragmentOne\"."
, locations = [AST.Location 8 15, AST.Location 12 15] , locations = [AST.Location 8 15, AST.Location 12 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects the fragment spread without a target" $ it "rejects the fragment spread without a target" $
let queryString = [r| let queryString = [r|
@ -291,7 +277,7 @@ spec =
"Fragment target \"undefinedFragment\" is undefined." "Fragment target \"undefinedFragment\" is undefined."
, locations = [AST.Location 4 19] , locations = [AST.Location 4 19]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects fragment spreads without an unknown target type" $ it "rejects fragment spreads without an unknown target type" $
let queryString = [r| let queryString = [r|
@ -310,7 +296,7 @@ spec =
\\"NotInSchema\" which doesn't exist in the schema." \\"NotInSchema\" which doesn't exist in the schema."
, locations = [AST.Location 4 19] , locations = [AST.Location 4 19]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects inline fragments without a target" $ it "rejects inline fragments without a target" $
let queryString = [r| let queryString = [r|
@ -326,7 +312,7 @@ spec =
\which doesn't exist in the schema." \which doesn't exist in the schema."
, locations = [AST.Location 3 17] , locations = [AST.Location 3 17]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects fragments on scalar types" $ it "rejects fragments on scalar types" $
let queryString = [r| let queryString = [r|
@ -345,7 +331,7 @@ spec =
\\"Int\"." \\"Int\"."
, locations = [AST.Location 7 15] , locations = [AST.Location 7 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldContain` [expected]
it "rejects inline fragments on scalar types" $ it "rejects inline fragments on scalar types" $
let queryString = [r| let queryString = [r|
@ -361,7 +347,7 @@ spec =
\\"Boolean\"." \\"Boolean\"."
, locations = [AST.Location 3 17] , locations = [AST.Location 3 17]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldContain` [expected]
it "rejects unused fragments" $ it "rejects unused fragments" $
let queryString = [r| let queryString = [r|
@ -380,7 +366,7 @@ spec =
"Fragment \"nameFragment\" is never used." "Fragment \"nameFragment\" is never used."
, locations = [AST.Location 2 15] , locations = [AST.Location 2 15]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects spreads that form cycles" $ it "rejects spreads that form cycles" $
let queryString = [r| let queryString = [r|
@ -412,7 +398,7 @@ spec =
\nameFragment)." \nameFragment)."
, locations = [AST.Location 7 15] , locations = [AST.Location 7 15]
} }
in validate queryString `shouldBe` Seq.fromList [error1, error2] in validate queryString `shouldBe` [error1, error2]
it "rejects duplicate field arguments" $ do it "rejects duplicate field arguments" $ do
let queryString = [r| let queryString = [r|
@ -427,20 +413,22 @@ spec =
"There can be only one argument named \"atOtherHomes\"." "There can be only one argument named \"atOtherHomes\"."
, locations = [AST.Location 4 34, AST.Location 4 54] , locations = [AST.Location 4 34, AST.Location 4 54]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects more than one directive per location" $ do it "rejects more than one directive per location" $ do
let queryString = [r| let queryString = [r|
query ($foo: Boolean = true, $bar: Boolean = false) { query ($foo: Boolean = true, $bar: Boolean = false) {
field @skip(if: $foo) @skip(if: $bar) dog @skip(if: $foo) @skip(if: $bar) {
name
}
} }
|] |]
expected = Error expected = Error
{ message = { message =
"There can be only one directive named \"skip\"." "There can be only one directive named \"skip\"."
, locations = [AST.Location 3 23, AST.Location 3 39] , locations = [AST.Location 3 21, AST.Location 3 37]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects duplicate variables" $ it "rejects duplicate variables" $
let queryString = [r| let queryString = [r|
@ -455,7 +443,7 @@ spec =
"There can be only one variable named \"atOtherHomes\"." "There can be only one variable named \"atOtherHomes\"."
, locations = [AST.Location 2 39, AST.Location 2 63] , locations = [AST.Location 2 39, AST.Location 2 63]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects non-input types as variables" $ it "rejects non-input types as variables" $
let queryString = [r| let queryString = [r|
@ -470,7 +458,7 @@ spec =
"Variable \"$dog\" cannot be non-input type \"Dog\"." "Variable \"$dog\" cannot be non-input type \"Dog\"."
, locations = [AST.Location 2 34] , locations = [AST.Location 2 34]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects undefined variables" $ it "rejects undefined variables" $
let queryString = [r| let queryString = [r|
@ -491,7 +479,7 @@ spec =
\\"variableIsNotDefinedUsedInSingleFragment\"." \\"variableIsNotDefinedUsedInSingleFragment\"."
, locations = [AST.Location 9 46] , locations = [AST.Location 9 46]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects unused variables" $ it "rejects unused variables" $
let queryString = [r| let queryString = [r|
@ -507,7 +495,7 @@ spec =
\\"variableUnused\"." \\"variableUnused\"."
, locations = [AST.Location 2 36] , locations = [AST.Location 2 36]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]
it "rejects duplicate fields in input objects" $ it "rejects duplicate fields in input objects" $
let queryString = [r| let queryString = [r|
@ -520,4 +508,4 @@ spec =
"There can be only one input field named \"name\"." "There can be only one input field named \"name\"."
, locations = [AST.Location 3 36, AST.Location 3 50] , locations = [AST.Location 3 36, AST.Location 3 50]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` [expected]

View File

@ -108,21 +108,17 @@ spec = do
it "embeds inline fragments without type" $ do it "embeds inline fragments without type" $ do
let sourceQuery = [r|{ let sourceQuery = [r|{
garment {
circumference circumference
... { ... {
size size
} }
}
}|] }|]
actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery actual <- graphql (toSchema "circumference" circumference) sourceQuery
let expected = HashMap.singleton "data" let expected = HashMap.singleton "data"
$ Aeson.object $ Aeson.object
[ "garment" .= Aeson.object
[ "circumference" .= (60 :: Int) [ "circumference" .= (60 :: Int)
, "size" .= ("L" :: Text) , "size" .= ("L" :: Text)
] ]
]
in actual `shouldResolveTo` expected in actual `shouldResolveTo` expected
it "evaluates fragments on Query" $ do it "evaluates fragments on Query" $ do

View File

@ -41,72 +41,88 @@ schema = Schema
droidFieldResolver = ValueResolver droidField droid droidFieldResolver = ValueResolver droidField droid
heroObject :: Out.ObjectType (Either SomeException) heroObject :: Out.ObjectType (Either SomeException)
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList heroObject = Out.ObjectType "Human" Nothing [characterType] $ HashMap.fromList
[ ("id", idFieldType) [ ("id", idFieldType)
, ("name", nameFieldType) , ("name", nameFieldType)
, ("friends", friendsFieldType) , ("friends", friendsFieldResolver)
, ("appearsIn", appearsInField) , ("appearsIn", appearsInFieldResolver)
, ("homePlanet", homePlanetFieldType) , ("homePlanet", homePlanetFieldType)
, ("secretBackstory", secretBackstoryFieldType) , ("secretBackstory", secretBackstoryFieldResolver)
, ("__typename", typenameFieldType) , ("__typename", typenameFieldResolver)
] ]
where where
homePlanetFieldType homePlanetFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty) = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "homePlanet" $ defaultResolver "homePlanet"
droidObject :: Out.ObjectType (Either SomeException) droidObject :: Out.ObjectType (Either SomeException)
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList droidObject = Out.ObjectType "Droid" Nothing [characterType] $ HashMap.fromList
[ ("id", idFieldType) [ ("id", idFieldType)
, ("name", nameFieldType) , ("name", nameFieldType)
, ("friends", friendsFieldType) , ("friends", friendsFieldResolver)
, ("appearsIn", appearsInField) , ("appearsIn", appearsInFieldResolver)
, ("primaryFunction", primaryFunctionFieldType) , ("primaryFunction", primaryFunctionFieldType)
, ("secretBackstory", secretBackstoryFieldType) , ("secretBackstory", secretBackstoryFieldResolver)
, ("__typename", typenameFieldType) , ("__typename", typenameFieldResolver)
] ]
where where
primaryFunctionFieldType primaryFunctionFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty) = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "primaryFunction" $ defaultResolver "primaryFunction"
typenameFieldType :: Resolver (Either SomeException) typenameFieldResolver :: Resolver (Either SomeException)
typenameFieldType typenameFieldResolver
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty) = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "__typename" $ defaultResolver "__typename"
idFieldType :: Resolver (Either SomeException) idFieldType :: Resolver (Either SomeException)
idFieldType idFieldType = ValueResolver idField $ defaultResolver "id"
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
$ idField "id"
nameFieldType :: Resolver (Either SomeException) nameFieldType :: Resolver (Either SomeException)
nameFieldType nameFieldType = ValueResolver nameField $ defaultResolver "name"
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "name"
friendsFieldType :: Resolver (Either SomeException) friendsFieldResolver :: Resolver (Either SomeException)
friendsFieldType friendsFieldResolver = ValueResolver friendsField $ defaultResolver "friends"
= ValueResolver (Out.Field Nothing fieldType mempty)
$ idField "friends" characterType :: InterfaceType (Either SomeException)
characterType = InterfaceType "Character" Nothing [] $ HashMap.fromList
[ ("id", idField)
, ("name", nameField)
, ("friends", friendsField)
, ("appearsIn", appearsInField)
, ("secretBackstory", secretBackstoryField)
]
idField :: Field (Either SomeException)
idField = Field Nothing (Out.NonNullScalarType id) mempty
nameField :: Field (Either SomeException)
nameField = Field Nothing (Out.NamedScalarType string) mempty
friendsField :: Field (Either SomeException)
friendsField = Field Nothing friendsFieldType mempty
where where
fieldType = Out.ListType $ Out.NamedObjectType droidObject friendsFieldType = Out.ListType (Out.NamedInterfaceType characterType)
appearsInField :: Resolver (Either SomeException) appearsInField :: Field (Either SomeException)
appearsInField appearsInField = Field appearsInDescription appearsInFieldType mempty
= ValueResolver (Out.Field (Just description) fieldType mempty)
$ idField "appearsIn"
where where
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum appearsInDescription = Just "Which movies they appear in."
description = "Which movies they appear in." appearsInFieldType = Out.ListType $ Out.NamedEnumType episodeEnum
secretBackstoryFieldType :: Resolver (Either SomeException) secretBackstoryField :: Field (Either SomeException)
secretBackstoryFieldType = ValueResolver field secretBackstory secretBackstoryField =
where Out.Field Nothing (Out.NamedScalarType string) mempty
field = Out.Field Nothing (Out.NamedScalarType string) mempty
idField :: Text -> Resolve (Either SomeException) appearsInFieldResolver :: Resolver (Either SomeException)
idField f = do appearsInFieldResolver = ValueResolver appearsInField
$ defaultResolver "appearsIn"
secretBackstoryFieldResolver :: Resolver (Either SomeException)
secretBackstoryFieldResolver = ValueResolver secretBackstoryField secretBackstory
defaultResolver :: Text -> Resolve (Either SomeException)
defaultResolver f = do
v <- asks values v <- asks values
let (Object v') = v let (Object v') = v
pure $ v' HashMap.! f pure $ v' HashMap.! f