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
- `Validate.Validation.Rule` constructors:
- `SelectionRule`
- `FieldRule`
- `FragmentRule`
- `FragmentSpreadRule`
- `ArgumentsRule`
@ -47,6 +46,7 @@ and this project adheres to
- `noUndefinedVariablesRule`
- `noUnusedVariablesRule`
- `uniqueInputFieldNamesRule`
- `fieldsOnCorrectTypeRule`
- `AST.Document.Field`.
- `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`.

View File

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

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
module Language.GraphQL.Type.Internal
( AbstractType(..)
@ -12,10 +13,12 @@ module Language.GraphQL.Type.Internal
, instanceOf
, lookupInputType
, lookupTypeCondition
, lookupTypeField
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In
@ -55,41 +58,41 @@ collectReferencedTypes schema =
getField (Out.ValueResolver field _) = field
getField (Out.EventStreamResolver field _ _) = field
traverseInputType (In.InputObjectBaseType objectType) =
let (In.InputObjectType typeName _ inputFields) = objectType
let In.InputObjectType typeName _ inputFields = objectType
element = InputObjectType objectType
traverser = flip (foldr visitInputFields) inputFields
in collect traverser typeName element
traverseInputType (In.ListBaseType listType) =
traverseInputType listType
traverseInputType (In.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType
let Definition.ScalarType typeName _ = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseInputType (In.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType
let Definition.EnumType typeName _ _ = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseOutputType (Out.ObjectBaseType objectType) =
traverseObjectType objectType
traverseOutputType (Out.InterfaceBaseType interfaceType) =
traverseInterfaceType interfaceType
traverseOutputType (Out.UnionBaseType unionType) =
let (Out.UnionType typeName _ types) = unionType
let Out.UnionType typeName _ types = unionType
traverser = flip (foldr traverseObjectType) types
in collect traverser typeName (UnionType unionType)
traverseOutputType (Out.ListBaseType listType) =
traverseOutputType listType
traverseOutputType (Out.ScalarBaseType scalarType) =
let (Definition.ScalarType typeName _) = scalarType
let Definition.ScalarType typeName _ = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseOutputType (Out.EnumBaseType enumType) =
let (Definition.EnumType typeName _ _) = enumType
let Definition.EnumType typeName _ _ = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes =
let (Out.ObjectType typeName _ interfaces fields) = objectType
let Out.ObjectType typeName _ interfaces fields = objectType
element = ObjectType objectType
traverser = polymorphicTraverser interfaces (getField <$> fields)
in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
let Out.InterfaceType typeName _ interfaces fields = interfaceType
element = InterfaceType interfaceType
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
@ -161,3 +164,21 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
= In.NonNullListType
<$> 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
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | GraphQL validator.
module Language.GraphQL.Validate
@ -16,14 +16,21 @@ import Control.Monad (join)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (toList)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema(..))
import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Rules
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
-- list is empty, the document is valid.
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
@ -37,16 +44,20 @@ document schema' rules' document' =
}
reader = do
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 (DefinitionRule rule) definition' accumulator =
definition :: Rule m
-> Validation m
-> Definition
-> Seq (RuleT m)
-> Seq (RuleT m)
definition (DefinitionRule rule) _ definition' accumulator =
accumulator |> rule definition'
definition rule (ExecutableDefinition executableDefinition') accumulator =
accumulator >< executableDefinition rule executableDefinition'
definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator =
definition rule context (ExecutableDefinition definition') accumulator =
accumulator >< executableDefinition rule context definition'
definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
accumulator >< typeSystemDefinition rule typeSystemDefinition'
definition rule (TypeSystemExtension extension _) accumulator =
definition rule _ (TypeSystemExtension extension _) accumulator =
accumulator >< typeSystemExtension rule extension
typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
@ -82,11 +93,14 @@ schemaExtension rule = \case
SchemaOperationExtension directives' _ -> directives rule directives'
SchemaDirectivesExtension directives' -> directives rule directives'
executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m)
executableDefinition rule (DefinitionOperation operation) =
operationDefinition rule operation
executableDefinition rule (DefinitionFragment fragment) =
fragmentDefinition rule fragment
executableDefinition :: Rule m
-> Validation m
-> ExecutableDefinition
-> Seq (RuleT m)
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 = \case
@ -124,58 +138,101 @@ inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
directives rule directives'
operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m)
operationDefinition rule operation
operationDefinition :: Rule m
-> Validation m
-> OperationDefinition
-> Seq (RuleT m)
operationDefinition rule context operation
| OperationDefinitionRule operationRule <- rule =
pure $ operationRule operation
| VariablesRule variablesRule <- rule
, OperationDefinition _ _ variables _ _ _ <- operation
= Seq.fromList (variableDefinition rule <$> variables)
|> variablesRule variables
| SelectionSet selections _ <- operation = selectionSet rule selections
| OperationDefinition _ _ _ directives' selections _ <- operation =
selectionSet rule selections >< directives rule directives'
| SelectionSet selections _ <- operation =
selectionSet types' rule (getRootType Query) selections
| 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 (ValueRule _ rule) (VariableDefinition _ _ value _) =
maybe (lift mempty) rule value
variableDefinition _ _ = lift mempty
fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m)
fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' =
pure $ rule fragmentDefinition'
fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _)
| FragmentRule definitionRule _ <- rule =
applyToChildren |> definitionRule fragmentDefinition'
| otherwise = applyToChildren
fragmentDefinition :: forall m
. Rule m
-> Validation m
-> FragmentDefinition
-> Seq (RuleT m)
fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
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
applyToChildren = selectionSet rule selections
types' = types context
applyToChildren typeCondition directives' selections
= selectionSet types' rule (lookupType' typeCondition) selections
>< directives rule directives'
lookupType' = flip lookupType types'
selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m)
selectionSet = foldMap . selection
lookupType :: forall m
. 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)
selection rule selection'
selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
selectionSet types' rule = foldMap . selection types' rule
selection :: forall m. ApplyRule m Selection
selection types' rule objectType selection'
| SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule selection'
applyToChildren |> selectionRule objectType selection'
| otherwise = applyToChildren
where
applyToChildren =
case selection' of
FieldSelection field' -> field rule field'
FieldSelection field' -> field types' rule objectType field'
InlineFragmentSelection inlineFragment' ->
inlineFragment rule inlineFragment'
inlineFragment types' rule objectType inlineFragment'
FragmentSpreadSelection fragmentSpread' ->
fragmentSpread rule fragmentSpread'
field :: Rule m -> Field -> Seq (RuleT m)
field rule field'@(Field _ _ arguments' directives' selections _)
| FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
| ArgumentsRule fieldRule _ <- rule = applyToChildren |> fieldRule field'
| otherwise = applyToChildren
field :: forall m. ApplyRule m Field
field types' rule objectType field' = go field'
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'
>< arguments rule arguments'
@ -186,13 +243,18 @@ argument :: Rule m -> Argument -> RuleT m
argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
argument _ _ = lift mempty
inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m)
inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _)
| FragmentRule _ fragmentRule <- rule =
applyToChildren |> fragmentRule inlineFragment'
| otherwise = applyToChildren
inlineFragment :: forall m. ApplyRule m InlineFragment
inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
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'
fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)

View File

@ -10,6 +10,7 @@
-- | This module contains default rules defined in the GraphQL specification.
module Language.GraphQL.Validate.Rules
( executableDefinitionsRule
, fieldsOnCorrectTypeRule
, fragmentsOnCompositeTypesRule
, fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule
@ -40,14 +41,16 @@ import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn)
import Data.Maybe (mapMaybe)
import Data.Maybe (isJust, mapMaybe)
import Data.Ord (comparing)
import Data.Sequence (Seq(..))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST.Document
import qualified Language.GraphQL.Type.Definition as Definition
import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation
@ -63,6 +66,8 @@ specifiedRules =
, singleFieldSubscriptionsRule
, loneAnonymousOperationRule
, uniqueOperationNamesRule
-- Fields
, fieldsOnCorrectTypeRule
-- Arguments.
, uniqueArgumentNamesRule
-- Fragments.
@ -297,7 +302,7 @@ isSpreadTarget _ _ = False
-- for both named and inline fragments. If they are not defined in the schema,
-- the query does not validate.
fragmentSpreadTypeExistenceRule :: forall m. Rule m
fragmentSpreadTypeExistenceRule = SelectionRule $ \case
fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
FragmentSpreadSelection fragmentSelection
| FragmentSpread fragmentName _ location <- fragmentSelection -> do
ast' <- asks ast
@ -672,3 +677,36 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
<> filterFieldDuplicates fields
constGo (ConstList values) = foldMap constGo values
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.Sequence (Seq)
import Language.GraphQL.AST.Document
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema)
import qualified Language.GraphQL.Type.Schema as Schema
@ -37,10 +38,9 @@ data Rule m
= DefinitionRule (Definition -> RuleT m)
| OperationDefinitionRule (OperationDefinition -> 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)
| FragmentSpreadRule (FragmentSpread -> RuleT m)
| FieldRule (Field -> RuleT m)
| ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
| DirectivesRule ([Directive] -> RuleT m)
| VariablesRule ([VariableDefinition] -> RuleT m)

View File

@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
( spec
) where
import Data.Sequence (Seq(..))
import qualified Data.Sequence as Seq
import Data.Foldable (toList)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
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.Out as Out
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.RawString.QQ (r)
@ -30,11 +29,17 @@ schema = Schema
}
queryType :: ObjectType IO
queryType = ObjectType "Query" Nothing []
$ HashMap.singleton "dog" dogResolver
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("dog", dogResolver)
, ("findDog", findDogResolver)
]
where
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
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 "DogCommand" Nothing $ HashMap.fromList
@ -72,6 +77,12 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
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 "Sentient" Nothing []
$ HashMap.singleton "name"
@ -114,39 +125,14 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
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 "CatOrDog" Nothing [catType, dogType]
-}
validate :: Text -> Seq Error
validate :: Text -> [Error]
validate queryString =
case parse AST.document "" queryString of
Left _ -> Seq.empty
Right ast -> document schema specifiedRules ast
Left _ -> []
Right ast -> toList $ document schema specifiedRules ast
spec :: Spec
spec =
@ -169,7 +155,7 @@ spec =
"Definition must be OperationDefinition or FragmentDefinition."
, locations = [AST.Location 9 15]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldContain` [expected]
it "rejects multiple subscription root fields" $
let queryString = [r|
@ -186,7 +172,7 @@ spec =
"Subscription sub must select only one top level field."
, 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" $
let queryString = [r|
@ -207,7 +193,7 @@ spec =
"Subscription sub must select only one top level field."
, locations = [AST.Location 2 15]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldContain` [expected]
it "rejects multiple anonymous operations" $
let queryString = [r|
@ -230,7 +216,7 @@ spec =
"This anonymous operation must be the only defined operation."
, locations = [AST.Location 2 15]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldBe` [expected]
it "rejects operations with the same name" $
let queryString = [r|
@ -251,7 +237,7 @@ spec =
"There can be only one operation named \"dogOperation\"."
, 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" $
let queryString = [r|
@ -276,7 +262,7 @@ spec =
"There can be only one fragment named \"fragmentOne\"."
, 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" $
let queryString = [r|
@ -291,7 +277,7 @@ spec =
"Fragment target \"undefinedFragment\" is undefined."
, 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" $
let queryString = [r|
@ -310,7 +296,7 @@ spec =
\\"NotInSchema\" which doesn't exist in the schema."
, locations = [AST.Location 4 19]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldBe` [expected]
it "rejects inline fragments without a target" $
let queryString = [r|
@ -326,7 +312,7 @@ spec =
\which doesn't exist in the schema."
, locations = [AST.Location 3 17]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldBe` [expected]
it "rejects fragments on scalar types" $
let queryString = [r|
@ -345,7 +331,7 @@ spec =
\\"Int\"."
, locations = [AST.Location 7 15]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldContain` [expected]
it "rejects inline fragments on scalar types" $
let queryString = [r|
@ -361,7 +347,7 @@ spec =
\\"Boolean\"."
, locations = [AST.Location 3 17]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldContain` [expected]
it "rejects unused fragments" $
let queryString = [r|
@ -380,7 +366,7 @@ spec =
"Fragment \"nameFragment\" is never used."
, locations = [AST.Location 2 15]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldBe` [expected]
it "rejects spreads that form cycles" $
let queryString = [r|
@ -412,7 +398,7 @@ spec =
\nameFragment)."
, 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
let queryString = [r|
@ -427,20 +413,22 @@ spec =
"There can be only one argument named \"atOtherHomes\"."
, 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
let queryString = [r|
query ($foo: Boolean = true, $bar: Boolean = false) {
field @skip(if: $foo) @skip(if: $bar)
dog @skip(if: $foo) @skip(if: $bar) {
name
}
}
|]
expected = Error
{ message =
"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" $
let queryString = [r|
@ -455,7 +443,7 @@ spec =
"There can be only one variable named \"atOtherHomes\"."
, 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" $
let queryString = [r|
@ -470,7 +458,7 @@ spec =
"Variable \"$dog\" cannot be non-input type \"Dog\"."
, locations = [AST.Location 2 34]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldBe` [expected]
it "rejects undefined variables" $
let queryString = [r|
@ -491,7 +479,7 @@ spec =
\\"variableIsNotDefinedUsedInSingleFragment\"."
, locations = [AST.Location 9 46]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldBe` [expected]
it "rejects unused variables" $
let queryString = [r|
@ -507,7 +495,7 @@ spec =
\\"variableUnused\"."
, locations = [AST.Location 2 36]
}
in validate queryString `shouldBe` Seq.singleton expected
in validate queryString `shouldBe` [expected]
it "rejects duplicate fields in input objects" $
let queryString = [r|
@ -520,4 +508,4 @@ spec =
"There can be only one input field named \"name\"."
, 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
let sourceQuery = [r|{
garment {
circumference
... {
size
}
}
}|]
actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery
actual <- graphql (toSchema "circumference" circumference) sourceQuery
let expected = HashMap.singleton "data"
$ Aeson.object
[ "garment" .= Aeson.object
[ "circumference" .= (60 :: Int)
, "size" .= ("L" :: Text)
]
]
in actual `shouldResolveTo` expected
it "evaluates fragments on Query" $ do

View File

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