Validate fragment spreads are possible

1 files changed, 75 insertions, 8 deletions

diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index 97ca2e9..4063b57 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -18,7 +18,7 @@ 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, shouldContain)
-import Text.Megaparsec (parse)
+import Text.Megaparsec (parse, errorBundlePretty)
 import Text.RawString.QQ (r)
 
 petSchema :: Schema IO
@@ -27,6 +27,7 @@ petSchema = schema queryType Nothing (Just subscriptionType) mempty
 queryType :: ObjectType IO
 queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
     [ ("dog", dogResolver)
+    , ("cat", catResolver)
     , ("findDog", findDogResolver)
     ]
   where
@@ -36,6 +37,39 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
         $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
     findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
     findDogResolver = ValueResolver findDogField $ pure Null
+    catField = Field Nothing (Out.NamedObjectType catType) mempty
+    catResolver = ValueResolver catField $ pure Null
+
+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
+    meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
+    meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 3
+    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
+        $ HashMap.singleton "catCommand"
+        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
+    doesKnowCommandResolver = ValueResolver doesKnowCommandField
+        $ pure $ Boolean True
+
+nameResolver :: Resolver IO
+nameResolver = ValueResolver nameField $ pure "Name"
+  where
+    nameField = Field Nothing (Out.NonNullScalarType string) mempty
+
+nicknameResolver :: Resolver IO
+nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
+  where
+    nicknameField = Field Nothing (Out.NamedScalarType string) mempty
 
 dogCommandType :: EnumType
 dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
@@ -54,10 +88,6 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
     , ("owner", ownerResolver)
     ]
   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"
     barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty
     barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3
     doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
@@ -116,8 +146,6 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
     , ("pets", petsResolver)
     ]
   where
-    nameField = Field Nothing (Out.NonNullScalarType string) mempty
-    nameResolver = ValueResolver nameField $ pure "Name"
     petsField =
         Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
     petsResolver = ValueResolver petsField $ pure $ List []
@@ -128,7 +156,7 @@ catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
 validate :: Text -> [Error]
 validate queryString =
     case parse AST.document "" queryString of
-        Left _ -> []
+        Left parseErrors -> error $ errorBundlePretty parseErrors
         Right ast -> toList $ document petSchema specifiedRules ast
 
 spec :: Spec
@@ -741,3 +769,42 @@ spec =
                     , locations = [AST.Location 5 19, AST.Location 9 19]
                     }
              in validate queryString `shouldBe` [expected]
+
+        it "rejects object inline spreads outside object scope" $
+            let queryString = [r|
+              {
+                dog {
+                  ... on Cat {
+                    meowVolume
+                  }
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Fragment cannot be spread here as objects of type \
+                        \\"Dog\" can never be of type \"Cat\"."
+                    , locations = [AST.Location 4 19]
+                    }
+             in validate queryString `shouldBe` [expected]
+
+        it "rejects object named spreads outside object scope" $
+            let queryString = [r|
+              {
+                dog {
+                  ... catInDogFragmentInvalid
+                }
+              }
+
+              fragment catInDogFragmentInvalid on Cat {
+                meowVolume
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Fragment \"catInDogFragmentInvalid\" cannot be spread \
+                        \here as objects of type \"Dog\" can never be of type \
+                        \\"Cat\"."
+                    , locations = [AST.Location 4 19]
+                    }
+             in validate queryString `shouldBe` [expected]