aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/Language/GraphQL/AST/EncoderSpec.hs64
-rw-r--r--tests/Language/GraphQL/AST/LexerSpec.hs4
-rw-r--r--tests/Language/GraphQL/AST/ParserSpec.hs2
-rw-r--r--tests/Language/GraphQL/ErrorSpec.hs2
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs39
-rw-r--r--tests/Language/GraphQL/ValidateSpec.hs522
-rw-r--r--tests/Test/DirectiveSpec.hs7
-rw-r--r--tests/Test/FragmentSpec.hs57
-rw-r--r--tests/Test/RootOperationSpec.hs14
-rw-r--r--tests/Test/StarWars/Data.hs204
-rw-r--r--tests/Test/StarWars/QuerySpec.hs366
-rw-r--r--tests/Test/StarWars/Schema.hs154
12 files changed, 543 insertions, 892 deletions
diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs
index 5fa3706..0c7dd39 100644
--- a/tests/Language/GraphQL/AST/EncoderSpec.hs
+++ b/tests/Language/GraphQL/AST/EncoderSpec.hs
@@ -4,7 +4,7 @@ module Language.GraphQL.AST.EncoderSpec
( spec
) where
-import Language.GraphQL.AST
+import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST.Encoder
import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
import Test.QuickCheck (choose, oneof, forAll)
@@ -15,52 +15,52 @@ spec :: Spec
spec = do
describe "value" $ do
context "null value" $ do
- let testNull formatter = value formatter Null `shouldBe` "null"
+ let testNull formatter = value formatter Full.Null `shouldBe` "null"
it "minified" $ testNull minified
it "pretty" $ testNull pretty
context "minified" $ do
it "escapes \\" $
- value minified (String "\\") `shouldBe` "\"\\\\\""
+ value minified (Full.String "\\") `shouldBe` "\"\\\\\""
it "escapes double quotes" $
- value minified (String "\"") `shouldBe` "\"\\\"\""
+ value minified (Full.String "\"") `shouldBe` "\"\\\"\""
it "escapes \\f" $
- value minified (String "\f") `shouldBe` "\"\\f\""
+ value minified (Full.String "\f") `shouldBe` "\"\\f\""
it "escapes \\n" $
- value minified (String "\n") `shouldBe` "\"\\n\""
+ value minified (Full.String "\n") `shouldBe` "\"\\n\""
it "escapes \\r" $
- value minified (String "\r") `shouldBe` "\"\\r\""
+ value minified (Full.String "\r") `shouldBe` "\"\\r\""
it "escapes \\t" $
- value minified (String "\t") `shouldBe` "\"\\t\""
+ value minified (Full.String "\t") `shouldBe` "\"\\t\""
it "escapes backspace" $
- value minified (String "a\bc") `shouldBe` "\"a\\bc\""
+ value minified (Full.String "a\bc") `shouldBe` "\"a\\bc\""
context "escapes Unicode for chars less than 0010" $ do
- it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""
- it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""
+ it "Null" $ value minified (Full.String "\x0000") `shouldBe` "\"\\u0000\""
+ it "bell" $ value minified (Full.String "\x0007") `shouldBe` "\"\\u0007\""
context "escapes Unicode for char less than 0020" $ do
- it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""
- it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""
+ it "DLE" $ value minified (Full.String "\x0010") `shouldBe` "\"\\u0010\""
+ it "EM" $ value minified (Full.String "\x0019") `shouldBe` "\"\\u0019\""
context "encodes without escape" $ do
- it "space" $ value minified (String "\x0020") `shouldBe` "\" \""
- it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""
+ it "space" $ value minified (Full.String "\x0020") `shouldBe` "\" \""
+ it "~" $ value minified (Full.String "\x007E") `shouldBe` "\"~\""
context "pretty" $ do
it "uses strings for short string values" $
- value pretty (String "Short text") `shouldBe` "\"Short text\""
+ value pretty (Full.String "Short text") `shouldBe` "\"Short text\""
it "uses block strings for text with new lines, with newline symbol" $
- value pretty (String "Line 1\nLine 2")
+ value pretty (Full.String "Line 1\nLine 2")
`shouldBe` [r|"""
Line 1
Line 2
"""|]
it "uses block strings for text with new lines, with CR symbol" $
- value pretty (String "Line 1\rLine 2")
+ value pretty (Full.String "Line 1\rLine 2")
`shouldBe` [r|"""
Line 1
Line 2
"""|]
it "uses block strings for text with new lines, with CR symbol followed by newline" $
- value pretty (String "Line 1\r\nLine 2")
+ value pretty (Full.String "Line 1\r\nLine 2")
`shouldBe` [r|"""
Line 1
Line 2
@@ -77,12 +77,12 @@ spec = do
forAll genNotAllowedSymbol $ \x -> do
let
rawValue = "Short \n" <> cons x "text"
- encoded = value pretty (String $ toStrict rawValue)
+ encoded = value pretty (Full.String $ toStrict rawValue)
shouldStartWith (unpack encoded) "\""
shouldEndWith (unpack encoded) "\""
shouldNotContain (unpack encoded) "\"\"\""
- it "Hello world" $ value pretty (String "Hello,\n World!\n\nYours,\n GraphQL.")
+ it "Hello world" $ value pretty (Full.String "Hello,\n World!\n\nYours,\n GraphQL.")
`shouldBe` [r|"""
Hello,
World!
@@ -91,29 +91,29 @@ spec = do
GraphQL.
"""|]
- it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|"""
+ it "has only newlines" $ value pretty (Full.String "\n") `shouldBe` [r|"""
"""|]
it "has newlines and one symbol at the begining" $
- value pretty (String "a\n\n") `shouldBe` [r|"""
+ value pretty (Full.String "a\n\n") `shouldBe` [r|"""
a
"""|]
it "has newlines and one symbol at the end" $
- value pretty (String "\n\na") `shouldBe` [r|"""
+ value pretty (Full.String "\n\na") `shouldBe` [r|"""
a
"""|]
it "has newlines and one symbol in the middle" $
- value pretty (String "\na\n") `shouldBe` [r|"""
+ value pretty (Full.String "\na\n") `shouldBe` [r|"""
a
"""|]
- it "skip trailing whitespaces" $ value pretty (String " Short\ntext ")
+ it "skip trailing whitespaces" $ value pretty (Full.String " Short\ntext ")
`shouldBe` [r|"""
Short
text
@@ -121,11 +121,13 @@ spec = do
describe "definition" $
it "indents block strings in arguments" $
- let arguments = [Argument "message" (String "line1\nline2")]
- field = Field Nothing "field" arguments [] []
- operation = DefinitionOperation
- $ SelectionSet (pure field)
- $ Location 0 0
+ let location = Full.Location 0 0
+ argumentValue = Full.Node (Full.String "line1\nline2") location
+ arguments = [Full.Argument "message" argumentValue location]
+ field = Full.Field Nothing "field" arguments [] [] location
+ fieldSelection = pure $ Full.FieldSelection field
+ operation = Full.DefinitionOperation
+ $ Full.SelectionSet fieldSelection location
in definition pretty operation `shouldBe` [r|{
field(message: """
line1
diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs
index 0b4cb31..c4fae45 100644
--- a/tests/Language/GraphQL/AST/LexerSpec.hs
+++ b/tests/Language/GraphQL/AST/LexerSpec.hs
@@ -75,9 +75,9 @@ spec = describe "Lexer" $ do
parse dollar "" "$" `shouldParse` "$"
runBetween parens `shouldSucceedOn` "()"
parse spread "" "..." `shouldParse` "..."
- parse colon "" ":" `shouldParse` ":"
+ parse colon "" `shouldSucceedOn` ":"
parse equals "" "=" `shouldParse` "="
- parse at "" "@" `shouldParse` "@"
+ parse at "" `shouldSucceedOn` "@"
runBetween brackets `shouldSucceedOn` "[]"
runBetween braces `shouldSucceedOn` "{}"
parse pipe "" "|" `shouldParse` "|"
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index f59e5a9..5c4d39e 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -128,7 +128,7 @@ spec = describe "Parser" $ do
parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
it "parses schema extension with an operation type and directive" $
- let newDirective = Directive "newDirective" []
+ let newDirective = Directive "newDirective" [] $ Location 1 15
schemaExtension = SchemaExtension
$ SchemaOperationExtension [newDirective]
$ OperationTypeDefinition Query "Query" :| []
diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs
index 1497c48..38d7d3a 100644
--- a/tests/Language/GraphQL/ErrorSpec.hs
+++ b/tests/Language/GraphQL/ErrorSpec.hs
@@ -19,6 +19,6 @@ import Test.Hspec ( Spec
spec :: Spec
spec = describe "singleError" $
it "constructs an error with the given message" $
- let errors'' = Seq.singleton $ Error "Message." []
+ let errors'' = Seq.singleton $ Error "Message." [] []
expected = Response Aeson.Null errors''
in singleError "Message." `shouldBe` expected
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 8fbb55b..f6e3e6f 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
module Language.GraphQL.ExecuteSpec
( spec
) where
@@ -10,10 +11,11 @@ module Language.GraphQL.ExecuteSpec
import Control.Exception (SomeException)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
+import Data.Aeson.Types (emptyObject)
import Data.Conduit
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Name)
+import Language.GraphQL.AST (Document, Name)
import Language.GraphQL.AST.Parser (document)
import Language.GraphQL.Error
import Language.GraphQL.Execute
@@ -21,13 +23,10 @@ import Language.GraphQL.Type as Type
import Language.GraphQL.Type.Out as Out
import Test.Hspec (Spec, context, describe, it, shouldBe)
import Text.Megaparsec (parse)
+import Text.RawString.QQ (r)
-schema :: Schema (Either SomeException)
-schema = Schema
- { query = queryType
- , mutation = Nothing
- , subscription = Just subscriptionType
- }
+philosopherSchema :: Schema (Either SomeException)
+philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty
queryType :: Out.ObjectType (Either SomeException)
queryType = Out.ObjectType "Query" Nothing []
@@ -71,9 +70,32 @@ quoteType = Out.ObjectType "Quote" Nothing []
quoteField =
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+type EitherStreamOrValue = Either
+ (ResponseEventStream (Either SomeException) Aeson.Value)
+ (Response Aeson.Value)
+
+execute' :: Document -> Either SomeException EitherStreamOrValue
+execute' =
+ execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)
+
spec :: Spec
spec =
describe "execute" $ do
+ it "rejects recursive fragments" $
+ let sourceQuery = [r|
+ {
+ ...cyclicFragment
+ }
+
+ fragment cyclicFragment on Query {
+ ...cyclicFragment
+ }
+ |]
+ expected = Response emptyObject mempty
+ Right (Right actual) = either (pure . parseError) execute'
+ $ parse document "" sourceQuery
+ in actual `shouldBe` expected
+
context "Query" $ do
it "skips unknown fields" $
let data'' = Aeson.object
@@ -82,7 +104,6 @@ spec =
]
]
expected = Response data'' mempty
- execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName surname } }"
in actual `shouldBe` expected
@@ -94,7 +115,6 @@ spec =
]
]
expected = Response data'' mempty
- execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
in actual `shouldBe` expected
@@ -106,7 +126,6 @@ spec =
]
]
expected = Response data'' mempty
- execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
Right (Left stream) = either (pure . parseError) execute'
$ parse document "" "subscription { newQuote { quote } }"
Right (Just actual) = runConduit $ stream .| await
diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index 8f6626b..318045c 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -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,23 +17,25 @@ 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)
-schema :: Schema IO
-schema = Schema
- { query = queryType
- , mutation = Nothing
- , subscription = Nothing
- }
+petSchema :: Schema IO
+petSchema = schema queryType Nothing (Just subscriptionType) mempty
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 +73,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"
@@ -81,19 +88,28 @@ petType :: InterfaceType IO
petType = InterfaceType "Pet" Nothing []
$ HashMap.singleton "name"
$ Field Nothing (Out.NonNullScalarType string) mempty
-{-
-alienType :: ObjectType IO
-alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList
- [ ("name", nameResolver)
- , ("homePlanet", homePlanetResolver)
+
+subscriptionType :: ObjectType IO
+subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList
+ [ ("newMessage", newMessageResolver)
+ , ("disallowedSecondRootField", newMessageResolver)
]
where
- nameField = Field Nothing (Out.NonNullScalarType string) mempty
- nameResolver = ValueResolver nameField $ pure "Name"
- homePlanetField =
- Field Nothing (Out.NamedScalarType string) mempty
- homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"
--}
+ newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty
+ newMessageResolver = ValueResolver newMessageField
+ $ pure $ Object HashMap.empty
+
+messageType :: ObjectType IO
+messageType = ObjectType "Message" Nothing [] $ HashMap.fromList
+ [ ("sender", senderResolver)
+ , ("body", bodyResolver)
+ ]
+ where
+ senderField = Field Nothing (Out.NonNullScalarType string) mempty
+ senderResolver = ValueResolver senderField $ pure "Sender"
+ bodyField = Field Nothing (Out.NonNullScalarType string) mempty
+ bodyResolver = ValueResolver bodyField $ pure "Message body."
+
humanType :: ObjectType IO
humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
[ ("name", nameResolver)
@@ -106,45 +122,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]
-
-dogOrHumanType :: UnionType IO
-dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType]
-
-humanOrAlienType :: UnionType IO
-humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType]
-}
-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 petSchema specifiedRules ast
spec :: Spec
spec =
@@ -166,9 +151,8 @@ spec =
{ message =
"Definition must be OperationDefinition or FragmentDefinition."
, locations = [AST.Location 9 15]
- , path = []
}
- in validate queryString `shouldBe` Seq.singleton expected
+ in validate queryString `shouldContain` [expected]
it "rejects multiple subscription root fields" $
let queryString = [r|
@@ -182,11 +166,11 @@ spec =
|]
expected = Error
{ message =
- "Subscription sub must select only one top level field."
+ "Subscription \"sub\" must select only one top level \
+ \field."
, locations = [AST.Location 2 15]
- , path = []
}
- 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|
@@ -204,11 +188,11 @@ spec =
|]
expected = Error
{ message =
- "Subscription sub must select only one top level field."
+ "Subscription \"sub\" must select only one top level \
+ \field."
, locations = [AST.Location 2 15]
- , path = []
}
- in validate queryString `shouldBe` Seq.singleton expected
+ in validate queryString `shouldContain` [expected]
it "rejects multiple anonymous operations" $
let queryString = [r|
@@ -230,9 +214,8 @@ spec =
{ message =
"This anonymous operation must be the only defined operation."
, locations = [AST.Location 2 15]
- , path = []
}
- in validate queryString `shouldBe` Seq.singleton expected
+ in validate queryString `shouldBe` [expected]
it "rejects operations with the same name" $
let queryString = [r|
@@ -252,9 +235,8 @@ spec =
{ message =
"There can be only one operation named \"dogOperation\"."
, locations = [AST.Location 2 15, AST.Location 8 15]
- , path = []
}
- in validate queryString `shouldBe` Seq.singleton expected
+ in validate queryString `shouldBe` [expected]
it "rejects fragments with the same name" $
let queryString = [r|
@@ -278,6 +260,406 @@ spec =
{ message =
"There can be only one fragment named \"fragmentOne\"."
, locations = [AST.Location 8 15, AST.Location 12 15]
- , path = []
}
- in validate queryString `shouldBe` Seq.singleton expected
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects the fragment spread without a target" $
+ let queryString = [r|
+ {
+ dog {
+ ...undefinedFragment
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Fragment target \"undefinedFragment\" is undefined."
+ , locations = [AST.Location 4 19]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects fragment spreads without an unknown target type" $
+ let queryString = [r|
+ {
+ dog {
+ ...notOnExistingType
+ }
+ }
+ fragment notOnExistingType on NotInSchema {
+ name
+ }
+ |]
+ expected = Error
+ { message =
+ "Fragment \"notOnExistingType\" is specified on type \
+ \\"NotInSchema\" which doesn't exist in the schema."
+ , locations = [AST.Location 4 19]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects inline fragments without a target" $
+ let queryString = [r|
+ {
+ ... on NotInSchema {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Inline fragment is specified on type \"NotInSchema\" \
+ \which doesn't exist in the schema."
+ , locations = [AST.Location 3 17]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects fragments on scalar types" $
+ let queryString = [r|
+ {
+ dog {
+ ...fragOnScalar
+ }
+ }
+ fragment fragOnScalar on Int {
+ name
+ }
+ |]
+ expected = Error
+ { message =
+ "Fragment cannot condition on non composite type \
+ \\"Int\"."
+ , locations = [AST.Location 7 15]
+ }
+ in validate queryString `shouldContain` [expected]
+
+ it "rejects inline fragments on scalar types" $
+ let queryString = [r|
+ {
+ ... on Boolean {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Fragment cannot condition on non composite type \
+ \\"Boolean\"."
+ , locations = [AST.Location 3 17]
+ }
+ in validate queryString `shouldContain` [expected]
+
+ it "rejects unused fragments" $
+ let queryString = [r|
+ fragment nameFragment on Dog { # unused
+ name
+ }
+
+ {
+ dog {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Fragment \"nameFragment\" is never used."
+ , locations = [AST.Location 2 15]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects spreads that form cycles" $
+ let queryString = [r|
+ {
+ dog {
+ ...nameFragment
+ }
+ }
+ fragment nameFragment on Dog {
+ name
+ ...barkVolumeFragment
+ }
+ fragment barkVolumeFragment on Dog {
+ barkVolume
+ ...nameFragment
+ }
+ |]
+ error1 = Error
+ { message =
+ "Cannot spread fragment \"barkVolumeFragment\" within \
+ \itself (via barkVolumeFragment -> nameFragment -> \
+ \barkVolumeFragment)."
+ , locations = [AST.Location 11 15]
+ }
+ error2 = Error
+ { message =
+ "Cannot spread fragment \"nameFragment\" within itself \
+ \(via nameFragment -> barkVolumeFragment -> \
+ \nameFragment)."
+ , locations = [AST.Location 7 15]
+ }
+ in validate queryString `shouldBe` [error1, error2]
+
+ it "rejects duplicate field arguments" $ do
+ let queryString = [r|
+ {
+ dog {
+ isHousetrained(atOtherHomes: true, atOtherHomes: true)
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "There can be only one argument named \"atOtherHomes\"."
+ , locations = [AST.Location 4 34, AST.Location 4 54]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects more than one directive per location" $ do
+ let queryString = [r|
+ query ($foo: Boolean = true, $bar: Boolean = false) {
+ dog @skip(if: $foo) @skip(if: $bar) {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "There can be only one directive named \"skip\"."
+ , locations = [AST.Location 3 21, AST.Location 3 37]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects duplicate variables" $
+ let queryString = [r|
+ query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {
+ dog {
+ isHousetrained(atOtherHomes: $atOtherHomes)
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "There can be only one variable named \"atOtherHomes\"."
+ , locations = [AST.Location 2 39, AST.Location 2 63]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects non-input types as variables" $
+ let queryString = [r|
+ query takesDogBang($dog: Dog!) {
+ dog {
+ isHousetrained(atOtherHomes: $dog)
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Variable \"$dog\" cannot be non-input type \"Dog\"."
+ , locations = [AST.Location 2 34]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects undefined variables" $
+ let queryString = [r|
+ query variableIsNotDefinedUsedInSingleFragment {
+ dog {
+ ...isHousetrainedFragment
+ }
+ }
+
+ fragment isHousetrainedFragment on Dog {
+ isHousetrained(atOtherHomes: $atOtherHomes)
+ }
+ |]
+ expected = Error
+ { message =
+ "Variable \"$atOtherHomes\" is not defined by \
+ \operation \
+ \\"variableIsNotDefinedUsedInSingleFragment\"."
+ , locations = [AST.Location 9 46]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects unused variables" $
+ let queryString = [r|
+ query variableUnused($atOtherHomes: Boolean) {
+ dog {
+ isHousetrained
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Variable \"$atOtherHomes\" is never used in operation \
+ \\"variableUnused\"."
+ , locations = [AST.Location 2 36]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects duplicate fields in input objects" $
+ let queryString = [r|
+ {
+ findDog(complex: { name: "Fido", name: "Jack" }) {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "There can be only one input field named \"name\"."
+ , locations = [AST.Location 3 36, AST.Location 3 50]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects undefined fields" $
+ let queryString = [r|
+ {
+ dog {
+ meowVolume
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Cannot query field \"meowVolume\" on type \"Dog\"."
+ , locations = [AST.Location 4 19]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects scalar fields with not empty selection set" $
+ let queryString = [r|
+ {
+ dog {
+ barkVolume {
+ sinceWhen
+ }
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Field \"barkVolume\" must not have a selection since \
+ \type \"Int\" has no subfields."
+ , locations = [AST.Location 4 19]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects field arguments missing in the type" $
+ let queryString = [r|
+ {
+ dog {
+ doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Unknown argument \"command\" on field \
+ \\"Dog.doesKnowCommand\"."
+ , locations = [AST.Location 4 35]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects directive arguments missing in the definition" $
+ let queryString = [r|
+ {
+ dog {
+ isHousetrained(atOtherHomes: true) @include(unless: false, if: true)
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Unknown argument \"unless\" on directive \"@include\"."
+ , locations = [AST.Location 4 63]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects undefined directives" $
+ let queryString = [r|
+ {
+ dog {
+ isHousetrained(atOtherHomes: true) @ignore(if: true)
+ }
+ }
+ |]
+ expected = Error
+ { message = "Unknown directive \"@ignore\"."
+ , locations = [AST.Location 4 54]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects undefined input object fields" $
+ let queryString = [r|
+ {
+ findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Field \"favoriteCookieFlavor\" is not defined \
+ \by type \"DogData\"."
+ , locations = [AST.Location 3 36]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects directives in invalid locations" $
+ let queryString = [r|
+ query @skip(if: $foo) {
+ dog {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message = "Directive \"@skip\" may not be used on QUERY."
+ , locations = [AST.Location 2 21]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "rejects missing required input fields" $
+ let queryString = [r|
+ {
+ findDog(complex: { name: null }) {
+ name
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Input field \"name\" of type \"DogData\" is required, \
+ \but it was not provided."
+ , locations = [AST.Location 3 34]
+ }
+ in validate queryString `shouldBe` [expected]
+
+ it "finds corresponding subscription fragment" $
+ let queryString = [r|
+ subscription sub {
+ ...anotherSubscription
+ ...multipleSubscriptions
+ }
+ fragment multipleSubscriptions on Subscription {
+ newMessage {
+ body
+ }
+ disallowedSecondRootField {
+ sender
+ }
+ }
+ fragment anotherSubscription on Subscription {
+ newMessage {
+ body
+ sender
+ }
+ }
+ |]
+ expected = Error
+ { message =
+ "Subscription \"sub\" must select only one top level \
+ \field."
+ , locations = [AST.Location 2 15]
+ }
+ in validate queryString `shouldBe` [expected]
diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs
index e6b6cea..2d586f6 100644
--- a/tests/Test/DirectiveSpec.hs
+++ b/tests/Test/DirectiveSpec.hs
@@ -19,8 +19,7 @@ import Test.Hspec.GraphQL
import Text.RawString.QQ (r)
experimentalResolver :: Schema IO
-experimentalResolver = Schema
- { query = queryType, mutation = Nothing, subscription = Nothing }
+experimentalResolver = schema queryType Nothing Nothing mempty
where
queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField"
@@ -72,7 +71,7 @@ spec =
...experimentalFragment @skip(if: true)
}
- fragment experimentalFragment on ExperimentalType {
+ fragment experimentalFragment on Query {
experimentalField
}
|]
@@ -83,7 +82,7 @@ spec =
it "should be able to @skip an inline fragment" $ do
let sourceQuery = [r|
{
- ... on ExperimentalType @skip(if: true) {
+ ... on Query @skip(if: true) {
experimentalField
}
}
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 089b721..f426e2c 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -46,18 +46,15 @@ inlineQuery = [r|{
}|]
shirtType :: Out.ObjectType IO
-shirtType = Out.ObjectType "Shirt" Nothing []
- $ HashMap.fromList
- [ ("size", sizeFieldType)
- , ("circumference", circumferenceFieldType)
- ]
+shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
+ [ ("size", sizeFieldType)
+ ]
hatType :: Out.ObjectType IO
-hatType = Out.ObjectType "Hat" Nothing []
- $ HashMap.fromList
- [ ("size", sizeFieldType)
- , ("circumference", circumferenceFieldType)
- ]
+hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
+ [ ("size", sizeFieldType)
+ , ("circumference", circumferenceFieldType)
+ ]
circumferenceFieldType :: Out.Resolver IO
circumferenceFieldType
@@ -70,12 +67,11 @@ sizeFieldType
$ pure $ snd size
toSchema :: Text -> (Text, Value) -> Schema IO
-toSchema t (_, resolve) = Schema
- { query = queryType, mutation = Nothing, subscription = Nothing }
+toSchema t (_, resolve) = schema queryType Nothing Nothing mempty
where
- unionMember = if t == "Hat" then hatType else shirtType
+ garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
- garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
+ garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty
queryType =
case t of
"circumference" -> hatType
@@ -111,22 +107,16 @@ spec = do
it "embeds inline fragments without type" $ do
let sourceQuery = [r|{
- garment {
- circumference
- ... {
- size
- }
+ circumference
+ ... {
+ size
}
}|]
- resolvers = ("garment", Object $ HashMap.fromList [circumference, size])
-
- actual <- graphql (toSchema "garment" resolvers) 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
@@ -183,21 +173,6 @@ spec = do
]
in actual `shouldResolveTo` expected
- it "rejects recursive fragments" $ do
- let expected = HashMap.singleton "data" $ Aeson.object []
- sourceQuery = [r|
- {
- ...circumferenceFragment
- }
-
- fragment circumferenceFragment on Hat {
- ...circumferenceFragment
- }
- |]
-
- actual <- graphql (toSchema "circumference" circumference) sourceQuery
- actual `shouldResolveTo` expected
-
it "considers type condition" $ do
let sourceQuery = [r|
{
diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs
index ea89279..1921ec9 100644
--- a/tests/Test/RootOperationSpec.hs
+++ b/tests/Test/RootOperationSpec.hs
@@ -23,13 +23,11 @@ hatType = Out.ObjectType "Hat" Nothing []
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 60
-schema :: Schema IO
-schema = Schema
- { query = Out.ObjectType "Query" Nothing [] hatFieldResolver
- , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
- , subscription = Nothing
- }
+garmentSchema :: Schema IO
+garmentSchema = schema queryType (Just mutationType) Nothing mempty
where
+ queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver
+ mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
garment = pure $ Object $ HashMap.fromList
[ ("circumference", Int 60)
]
@@ -57,7 +55,7 @@ spec =
[ "circumference" .= (60 :: Int)
]
]
- actual <- graphql schema querySource
+ actual <- graphql garmentSchema querySource
actual `shouldResolveTo` expected
it "chooses Mutation" $ do
@@ -70,5 +68,5 @@ spec =
$ object
[ "incrementCircumference" .= (61 :: Int)
]
- actual <- graphql schema querySource
+ actual <- graphql garmentSchema querySource
actual `shouldResolveTo` expected
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
deleted file mode 100644
index e3dd696..0000000
--- a/tests/Test/StarWars/Data.hs
+++ /dev/null
@@ -1,204 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Test.StarWars.Data
- ( Character
- , StarWarsException(..)
- , appearsIn
- , artoo
- , getDroid
- , getDroid'
- , getEpisode
- , getFriends
- , getHero
- , getHuman
- , id_
- , homePlanet
- , name_
- , secretBackstory
- , typeName
- ) where
-
-import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)
-import Control.Applicative (Alternative(..), liftA2)
-import Data.Maybe (catMaybes)
-import Data.Text (Text)
-import Data.Typeable (cast)
-import Language.GraphQL.Error
-import Language.GraphQL.Type
-
--- * Data
--- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
-
--- ** Characters
-
-type ID = Text
-
-data CharCommon = CharCommon
- { _id_ :: ID
- , _name :: Text
- , _friends :: [ID]
- , _appearsIn :: [Int]
- } deriving (Show)
-
-
-data Human = Human
- { _humanChar :: CharCommon
- , homePlanet :: Text
- }
-
-data Droid = Droid
- { _droidChar :: CharCommon
- , primaryFunction :: Text
- }
-
-type Character = Either Droid Human
-
-id_ :: Character -> ID
-id_ (Left x) = _id_ . _droidChar $ x
-id_ (Right x) = _id_ . _humanChar $ x
-
-name_ :: Character -> Text
-name_ (Left x) = _name . _droidChar $ x
-name_ (Right x) = _name . _humanChar $ x
-
-friends :: Character -> [ID]
-friends (Left x) = _friends . _droidChar $ x
-friends (Right x) = _friends . _humanChar $ x
-
-appearsIn :: Character -> [Int]
-appearsIn (Left x) = _appearsIn . _droidChar $ x
-appearsIn (Right x) = _appearsIn . _humanChar $ x
-
-data StarWarsException = SecretBackstory | InvalidArguments
-
-instance Show StarWarsException where
- show SecretBackstory = "secretBackstory is secret."
- show InvalidArguments = "Invalid arguments."
-
-instance Exception StarWarsException where
- toException = toException . ResolverException
- fromException e = do
- ResolverException resolverException <- fromException e
- cast resolverException
-
-secretBackstory :: Resolve (Either SomeException)
-secretBackstory = throwM SecretBackstory
-
-typeName :: Character -> Text
-typeName = either (const "Droid") (const "Human")
-
-luke :: Character
-luke = Right luke'
-
-luke' :: Human
-luke' = Human
- { _humanChar = CharCommon
- { _id_ = "1000"
- , _name = "Luke Skywalker"
- , _friends = ["1002","1003","2000","2001"]
- , _appearsIn = [4,5,6]
- }
- , homePlanet = "Tatooine"
- }
-
-vader :: Human
-vader = Human
- { _humanChar = CharCommon
- { _id_ = "1001"
- , _name = "Darth Vader"
- , _friends = ["1004"]
- , _appearsIn = [4,5,6]
- }
- , homePlanet = "Tatooine"
- }
-
-han :: Human
-han = Human
- { _humanChar = CharCommon
- { _id_ = "1002"
- , _name = "Han Solo"
- , _friends = ["1000","1003","2001" ]
- , _appearsIn = [4,5,6]
- }
- , homePlanet = mempty
- }
-
-leia :: Human
-leia = Human
- { _humanChar = CharCommon
- { _id_ = "1003"
- , _name = "Leia Organa"
- , _friends = ["1000","1002","2000","2001"]
- , _appearsIn = [4,5,6]
- }
- , homePlanet = "Alderaan"
- }
-
-tarkin :: Human
-tarkin = Human
- { _humanChar = CharCommon
- { _id_ = "1004"
- , _name = "Wilhuff Tarkin"
- , _friends = ["1001"]
- , _appearsIn = [4]
- }
- , homePlanet = mempty
- }
-
-threepio :: Droid
-threepio = Droid
- { _droidChar = CharCommon
- { _id_ = "2000"
- , _name = "C-3PO"
- , _friends = ["1000","1002","1003","2001" ]
- , _appearsIn = [ 4, 5, 6 ]
- }
- , primaryFunction = "Protocol"
- }
-
-artoo :: Character
-artoo = Left artoo'
-
-artoo' :: Droid
-artoo' = Droid
- { _droidChar = CharCommon
- { _id_ = "2001"
- , _name = "R2-D2"
- , _friends = ["1000","1002","1003"]
- , _appearsIn = [4,5,6]
- }
- , primaryFunction = "Astrometch"
- }
-
--- ** Helper functions
-
-getHero :: Int -> Character
-getHero 5 = luke
-getHero _ = artoo
-
-getHuman :: ID -> Maybe Character
-getHuman = fmap Right . getHuman'
-
-getHuman' :: ID -> Maybe Human
-getHuman' "1000" = pure luke'
-getHuman' "1001" = pure vader
-getHuman' "1002" = pure han
-getHuman' "1003" = pure leia
-getHuman' "1004" = pure tarkin
-getHuman' _ = empty
-
-getDroid :: ID -> Maybe Character
-getDroid = fmap Left . getDroid'
-
-getDroid' :: ID -> Maybe Droid
-getDroid' "2000" = pure threepio
-getDroid' "2001" = pure artoo'
-getDroid' _ = empty
-
-getFriends :: Character -> [Character]
-getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
-
-getEpisode :: Int -> Maybe Text
-getEpisode 4 = pure "NEW_HOPE"
-getEpisode 5 = pure "EMPIRE"
-getEpisode 6 = pure "JEDI"
-getEpisode _ = empty
diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
deleted file mode 100644
index 95b18d3..0000000
--- a/tests/Test/StarWars/QuerySpec.hs
+++ /dev/null
@@ -1,366 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Test.StarWars.QuerySpec
- ( spec
- ) where
-
-import qualified Data.Aeson as Aeson
-import Data.Aeson ((.=))
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
-import Language.GraphQL
-import Text.RawString.QQ (r)
-import Test.Hspec.Expectations (Expectation, shouldBe)
-import Test.Hspec (Spec, describe, it)
-import Test.StarWars.Schema
-
--- * Test
--- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
-
-spec :: Spec
-spec = describe "Star Wars Query Tests" $ do
- describe "Basic Queries" $ do
- it "R2-D2 hero" $ testQuery
- [r| query HeroNameQuery {
- hero {
- id
- }
- }
- |]
- $ Aeson.object
- [ "data" .= Aeson.object
- [ "hero" .= Aeson.object ["id" .= ("2001" :: Text)]
- ]
- ]
- it "R2-D2 ID and friends" $ testQuery
- [r| query HeroNameAndFriendsQuery {
- hero {
- id
- name
- friends {
- name
- }
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "hero" .= Aeson.object
- [ "id" .= ("2001" :: Text)
- , r2d2Name
- , "friends" .=
- [ Aeson.object [lukeName]
- , Aeson.object [hanName]
- , Aeson.object [leiaName]
- ]
- ]
- ]]
-
- describe "Nested Queries" $ do
- it "R2-D2 friends" $ testQuery
- [r| query NestedQuery {
- hero {
- name
- friends {
- name
- appearsIn
- friends {
- name
- }
- }
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "hero" .= Aeson.object [
- "name" .= ("R2-D2" :: Text)
- , "friends" .= [
- Aeson.object [
- "name" .= ("Luke Skywalker" :: Text)
- , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
- , "friends" .= [
- Aeson.object [hanName]
- , Aeson.object [leiaName]
- , Aeson.object [c3poName]
- , Aeson.object [r2d2Name]
- ]
- ]
- , Aeson.object [
- hanName
- , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
- , "friends" .=
- [ Aeson.object [lukeName]
- , Aeson.object [leiaName]
- , Aeson.object [r2d2Name]
- ]
- ]
- , Aeson.object [
- leiaName
- , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
- , "friends" .=
- [ Aeson.object [lukeName]
- , Aeson.object [hanName]
- , Aeson.object [c3poName]
- , Aeson.object [r2d2Name]
- ]
- ]
- ]
- ]
- ]]
- it "Luke ID" $ testQuery
- [r| query FetchLukeQuery {
- human(id: "1000") {
- name
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object
- [ "human" .= Aeson.object [lukeName]
- ]]
-
- it "Luke ID with variable" $ testQueryParams
- (HashMap.singleton "someId" "1000")
- [r| query FetchSomeIDQuery($someId: String!) {
- human(id: $someId) {
- name
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "human" .= Aeson.object [lukeName]
- ]]
- it "Han ID with variable" $ testQueryParams
- (HashMap.singleton "someId" "1002")
- [r| query FetchSomeIDQuery($someId: String!) {
- human(id: $someId) {
- name
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "human" .= Aeson.object [hanName]
- ]]
- it "Invalid ID" $ testQueryParams
- (HashMap.singleton "id" "Not a valid ID")
- [r| query humanQuery($id: String!) {
- human(id: $id) {
- name
- }
- }
- |] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]
- it "Luke aliased" $ testQuery
- [r| query FetchLukeAliased {
- luke: human(id: "1000") {
- name
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "luke" .= Aeson.object [lukeName]
- ]]
- it "R2-D2 ID and friends aliased" $ testQuery
- [r| query HeroNameAndFriendsQuery {
- hero {
- id
- name
- friends {
- friendName: name
- }
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "hero" .= Aeson.object [
- "id" .= ("2001" :: Text)
- , r2d2Name
- , "friends" .=
- [ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]
- , Aeson.object ["friendName" .= ("Han Solo" :: Text)]
- , Aeson.object ["friendName" .= ("Leia Organa" :: Text)]
- ]
- ]
- ]]
- it "Luke and Leia aliased" $ testQuery
- [r| query FetchLukeAndLeiaAliased {
- luke: human(id: "1000") {
- name
- }
- leia: human(id: "1003") {
- name
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object
- [ "luke" .= Aeson.object [lukeName]
- , "leia" .= Aeson.object [leiaName]
- ]]
-
- describe "Fragments for complex queries" $ do
- it "Aliases to query for duplicate content" $ testQuery
- [r| query DuplicateFields {
- luke: human(id: "1000") {
- name
- homePlanet
- }
- leia: human(id: "1003") {
- name
- homePlanet
- }
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "luke" .= Aeson.object [lukeName, tatooine]
- , "leia" .= Aeson.object [leiaName, alderaan]
- ]]
- it "Fragment for duplicate content" $ testQuery
- [r| query UseFragment {
- luke: human(id: "1000") {
- ...HumanFragment
- }
- leia: human(id: "1003") {
- ...HumanFragment
- }
- }
- fragment HumanFragment on Human {
- name
- homePlanet
- }
- |]
- $ Aeson.object [ "data" .= Aeson.object [
- "luke" .= Aeson.object [lukeName, tatooine]
- , "leia" .= Aeson.object [leiaName, alderaan]
- ]]
-
- describe "__typename" $ do
- it "R2D2 is a Droid" $ testQuery
- [r| query CheckTypeOfR2 {
- hero {
- __typename
- name
- }
- }
- |]
- $ Aeson.object ["data" .= Aeson.object [
- "hero" .= Aeson.object
- [ "__typename" .= ("Droid" :: Text)
- , r2d2Name
- ]
- ]]
- it "Luke is a human" $ testQuery
- [r| query CheckTypeOfLuke {
- hero(episode: EMPIRE) {
- __typename
- name
- }
- }
- |]
- $ Aeson.object ["data" .= Aeson.object [
- "hero" .= Aeson.object
- [ "__typename" .= ("Human" :: Text)
- , lukeName
- ]
- ]]
-
- describe "Errors in resolvers" $ do
- it "error on secretBackstory" $ testQuery
- [r|
- query HeroNameQuery {
- hero {
- name
- secretBackstory
- }
- }
- |]
- $ Aeson.object
- [ "data" .= Aeson.object
- [ "hero" .= Aeson.object
- [ "name" .= ("R2-D2" :: Text)
- , "secretBackstory" .= Aeson.Null
- ]
- ]
- , "errors" .=
- [ Aeson.object
- ["message" .= ("secretBackstory is secret." :: Text)]
- ]
- ]
- it "Error in a list" $ testQuery
- [r| query HeroNameQuery {
- hero {
- name
- friends {
- name
- secretBackstory
- }
- }
- }
- |]
- $ Aeson.object ["data" .= Aeson.object
- [ "hero" .= Aeson.object
- [ "name" .= ("R2-D2" :: Text)
- , "friends" .=
- [ Aeson.object
- [ "name" .= ("Luke Skywalker" :: Text)
- , "secretBackstory" .= Aeson.Null
- ]
- , Aeson.object
- [ "name" .= ("Han Solo" :: Text)
- , "secretBackstory" .= Aeson.Null
- ]
- , Aeson.object
- [ "name" .= ("Leia Organa" :: Text)
- , "secretBackstory" .= Aeson.Null
- ]
- ]
- ]
- ]
- , "errors" .=
- [ Aeson.object
- [ "message" .= ("secretBackstory is secret." :: Text)
- ]
- , Aeson.object
- [ "message" .= ("secretBackstory is secret." :: Text)
- ]
- , Aeson.object
- [ "message" .= ("secretBackstory is secret." :: Text)
- ]
- ]
- ]
- it "error on secretBackstory with alias" $ testQuery
- [r| query HeroNameQuery {
- mainHero: hero {
- name
- story: secretBackstory
- }
- }
- |]
- $ Aeson.object
- [ "data" .= Aeson.object
- [ "mainHero" .= Aeson.object
- [ "name" .= ("R2-D2" :: Text)
- , "story" .= Aeson.Null
- ]
- ]
- , "errors" .=
- [ Aeson.object
- [ "message" .= ("secretBackstory is secret." :: Text)
- ]
- ]
- ]
-
- where
- lukeName = "name" .= ("Luke Skywalker" :: Text)
- leiaName = "name" .= ("Leia Organa" :: Text)
- hanName = "name" .= ("Han Solo" :: Text)
- r2d2Name = "name" .= ("R2-D2" :: Text)
- c3poName = "name" .= ("C-3PO" :: Text)
- tatooine = "homePlanet" .= ("Tatooine" :: Text)
- alderaan = "homePlanet" .= ("Alderaan" :: Text)
-
-testQuery :: Text -> Aeson.Value -> Expectation
-testQuery q expected =
- let Right (Right actual) = graphql schema q
- in Aeson.Object actual `shouldBe` expected
-
-testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
-testQueryParams f q expected =
- let Right (Right actual) = graphqlSubs schema Nothing f q
- in Aeson.Object actual `shouldBe` expected
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
deleted file mode 100644
index cecd8eb..0000000
--- a/tests/Test/StarWars/Schema.hs
+++ /dev/null
@@ -1,154 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Test.StarWars.Schema
- ( schema
- ) where
-
-import Control.Monad.Catch (MonadThrow(..), SomeException)
-import Control.Monad.Trans.Reader (asks)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (catMaybes)
-import Data.Text (Text)
-import Language.GraphQL.Type
-import qualified Language.GraphQL.Type.In as In
-import qualified Language.GraphQL.Type.Out as Out
-import Test.StarWars.Data
-import Prelude hiding (id)
-
--- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
-
-schema :: Schema (Either SomeException)
-schema = Schema
- { query = queryType
- , mutation = Nothing
- , subscription = Nothing
- }
- where
- queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
- [ ("hero", heroFieldResolver)
- , ("human", humanFieldResolver)
- , ("droid", droidFieldResolver)
- ]
- heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
- $ HashMap.singleton "episode"
- $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
- heroFieldResolver = ValueResolver heroField hero
- humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
- $ HashMap.singleton "id"
- $ In.Argument Nothing (In.NonNullScalarType string) Nothing
- humanFieldResolver = ValueResolver humanField human
- droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
- droidFieldResolver = ValueResolver droidField droid
-
-heroObject :: Out.ObjectType (Either SomeException)
-heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
- [ ("id", idFieldType)
- , ("name", nameFieldType)
- , ("friends", friendsFieldType)
- , ("appearsIn", appearsInField)
- , ("homePlanet", homePlanetFieldType)
- , ("secretBackstory", secretBackstoryFieldType)
- , ("__typename", typenameFieldType)
- ]
- where
- homePlanetFieldType
- = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
- $ idField "homePlanet"
-
-droidObject :: Out.ObjectType (Either SomeException)
-droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
- [ ("id", idFieldType)
- , ("name", nameFieldType)
- , ("friends", friendsFieldType)
- , ("appearsIn", appearsInField)
- , ("primaryFunction", primaryFunctionFieldType)
- , ("secretBackstory", secretBackstoryFieldType)
- , ("__typename", typenameFieldType)
- ]
- where
- primaryFunctionFieldType
- = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
- $ idField "primaryFunction"
-
-typenameFieldType :: Resolver (Either SomeException)
-typenameFieldType
- = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
- $ idField "__typename"
-
-idFieldType :: Resolver (Either SomeException)
-idFieldType
- = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
- $ idField "id"
-
-nameFieldType :: Resolver (Either SomeException)
-nameFieldType
- = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
- $ idField "name"
-
-friendsFieldType :: Resolver (Either SomeException)
-friendsFieldType
- = ValueResolver (Out.Field Nothing fieldType mempty)
- $ idField "friends"
- where
- fieldType = Out.ListType $ Out.NamedObjectType droidObject
-
-appearsInField :: Resolver (Either SomeException)
-appearsInField
- = ValueResolver (Out.Field (Just description) fieldType mempty)
- $ idField "appearsIn"
- where
- fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
- description = "Which movies they appear in."
-
-secretBackstoryFieldType :: Resolver (Either SomeException)
-secretBackstoryFieldType = ValueResolver field secretBackstory
- where
- field = Out.Field Nothing (Out.NamedScalarType string) mempty
-
-idField :: Text -> Resolve (Either SomeException)
-idField f = do
- v <- asks values
- let (Object v') = v
- pure $ v' HashMap.! f
-
-episodeEnum :: EnumType
-episodeEnum = EnumType "Episode" (Just description)
- $ HashMap.fromList [newHope, empire, jedi]
- where
- description = "One of the films in the Star Wars Trilogy"
- newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.")
- empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
- jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
-
-hero :: Resolve (Either SomeException)
-hero = do
- episode <- argument "episode"
- pure $ character $ case episode of
- Enum "NEW_HOPE" -> getHero 4
- Enum "EMPIRE" -> getHero 5
- Enum "JEDI" -> getHero 6
- _ -> artoo
-
-human :: Resolve (Either SomeException)
-human = do
- id' <- argument "id"
- case id' of
- String i -> pure $ maybe Null character $ getHuman i >>= Just
- _ -> throwM InvalidArguments
-
-droid :: Resolve (Either SomeException)
-droid = do
- id' <- argument "id"
- case id' of
- String i -> pure $ maybe Null character $ getDroid i >>= Just
- _ -> throwM InvalidArguments
-
-character :: Character -> Value
-character char = Object $ HashMap.fromList
- [ ("id", String $ id_ char)
- , ("name", String $ name_ char)
- , ("friends", List $ character <$> getFriends char)
- , ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
- , ("homePlanet", String $ either mempty homePlanet char)
- , ("__typename", String $ typeName char)
- ]
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:53:08 +0000