OSS/graphql
1
1
Fork 1
Code Issues 4 Pull Requests Actions Releases 22 Wiki Activity

Validate field selections on composite types

Browse Source
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
Download Patch File Download Diff File Expand all files Collapse all files

98
tests/Language/GraphQL/ValidateSpec.hs
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]

16
tests/Test/FragmentSpec.hs
View File

@ -108,20 +108,16 @@ spec = do
it "embeds inline fragments without type" $ do
let sourceQuery = [r|{
garment {
circumference
... {
size
}
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)
]
[ "circumference" .= (60 :: Int)
, "size" .= ("L" :: Text)
]
in actual `shouldResolveTo` expected

16
tests/Test/StarWars/QuerySpec.hs
View File

@ -23,9 +23,9 @@ spec = describe "Star Wars Query Tests" $ do
it "R2-D2 hero" $ testQuery
[r| query HeroNameQuery {
hero {
id
}
id
}
}
|]
$ Aeson.object
[ "data" .= Aeson.object
@ -35,13 +35,13 @@ spec = describe "Star Wars Query Tests" $ do
it "R2-D2 ID and friends" $ testQuery
[r| query HeroNameAndFriendsQuery {
hero {
id
id
name
friends {
name
friends {
name
}
}
}
}
}
|]
$ Aeson.object [ "data" .= Aeson.object [
"hero" .= Aeson.object
@ -266,7 +266,7 @@ spec = describe "Star Wars Query Tests" $ do
query HeroNameQuery {
hero {
name
secretBackstory
secretBackstory
}
}
|]

92
tests/Test/StarWars/Schema.hs
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