Validate fragment spreads are possible

3 files changed, 183 insertions, 34 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 49701e8..46c0b19 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -10,6 +10,7 @@ and this project adheres to
 ### Added
 - `Validate.Rules`:
   - `overlappingFieldsCanBeMergedRule`
+  - `possibleFragmentSpreadsRule`
 - `Type.Schema.implementations` contains a map from interfaces and objects to
   interfaces they implement.
 
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index d17c1bc..56c839e 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -25,6 +25,7 @@ module Language.GraphQL.Validate.Rules
     , noUnusedFragmentsRule
     , noUnusedVariablesRule
     , overlappingFieldsCanBeMergedRule
+    , possibleFragmentSpreadsRule
     , providedRequiredInputFieldsRule
     , providedRequiredArgumentsRule
     , scalarLeafsRule
@@ -93,6 +94,7 @@ specifiedRules =
     , noUnusedFragmentsRule
     , fragmentSpreadTargetDefinedRule
     , noFragmentCyclesRule
+    , possibleFragmentSpreadsRule
     -- Values
     , knownInputFieldNamesRule
     , uniqueInputFieldNamesRule
@@ -322,10 +324,8 @@ fragmentSpreadTypeExistenceRule :: forall m. Rule m
 fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
     Full.FragmentSpreadSelection fragmentSelection
         | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do
-            ast' <- asks ast
-            let target = find (isSpreadTarget fragmentName) ast'
-            typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition
             types' <- asks $ Schema.types . schema
+            typeCondition <- findSpreadTarget fragmentName
             case HashMap.lookup typeCondition types' of
                 Nothing -> pure $ Error
                     { message = spreadError fragmentName typeCondition
@@ -344,10 +344,6 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
                 Just _ -> lift mempty
     _ -> lift mempty
   where
-    extractTypeCondition (viewFragment -> Just fragmentDefinition) =
-        let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
-         in Just typeCondition
-    extractTypeCondition _ = Nothing
     spreadError fragmentName typeCondition = concat
         [ "Fragment \""
         , Text.unpack fragmentName
@@ -361,9 +357,9 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
         , "\" which doesn't exist in the schema."
         ]
 
-maybeToSeq :: forall a. Maybe a -> Seq a
-maybeToSeq (Just x) = pure x
-maybeToSeq Nothing = mempty
+maybeToSeq :: forall a m. Maybe a -> ReaderT (Validation m) Seq a
+maybeToSeq (Just x) = lift $ pure x
+maybeToSeq Nothing = lift mempty
 
 -- | Fragments can only be declared on unions, interfaces, and objects. They are
 -- invalid on scalars. They can only be applied on non‐leaf fields. This rule
@@ -379,7 +375,7 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
     check typeCondition location' = do
         types' <- asks $ Schema.types . schema
         -- Skip unknown types, they are checked by another rule.
-        _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types'
+        _ <- maybeToSeq $ HashMap.lookup typeCondition types'
         case Type.lookupTypeCondition typeCondition types' of
             Nothing -> pure $ Error
                 { message = errorMessage typeCondition
@@ -718,7 +714,7 @@ fieldsOnCorrectTypeRule = FieldRule fieldRule
     fieldRule parentType (Full.Field _ fieldName _ _ _ location')
         | Just objectType <- parentType
         , Nothing <- Type.lookupTypeField fieldName objectType
-        , Just typeName <- compositeTypeName objectType = pure $ Error
+        , Just typeName <- typeNameIfComposite objectType = pure $ Error
             { message = errorMessage fieldName typeName
             , locations = [location']
             }
@@ -731,20 +727,17 @@ fieldsOnCorrectTypeRule = FieldRule fieldRule
         , "\"."
         ]
 
-compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name
-compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
-    Just typeName
-compositeTypeName (Out.InterfaceBaseType interfaceType) =
+compositeTypeName :: forall m. Type.CompositeType m -> Full.Name
+compositeTypeName (Type.CompositeObjectType (Out.ObjectType typeName _ _ _)) =
+    typeName
+compositeTypeName (Type.CompositeInterfaceType interfaceType) =
     let Out.InterfaceType typeName _ _ _ = interfaceType
-        in Just typeName
-compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =
-    Just typeName
-compositeTypeName (Out.ScalarBaseType _) =
-    Nothing
-compositeTypeName (Out.EnumBaseType _) =
-    Nothing
-compositeTypeName (Out.ListBaseType wrappedType) =
-    compositeTypeName wrappedType
+     in typeName
+compositeTypeName (Type.CompositeUnionType (Out.UnionType typeName _ _)) =
+    typeName
+
+typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name
+typeNameIfComposite = fmap compositeTypeName . Type.outToComposite
 
 -- | Field selections on scalars or enums are never allowed, because they are
 -- the leaf nodes of any GraphQL query.
@@ -802,7 +795,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
   where
     fieldRule (Just objectType) (Full.Field _ fieldName arguments  _ _ _)
         | Just typeField <- Type.lookupTypeField fieldName objectType
-        , Just typeName <- compositeTypeName objectType =
+        , Just typeName <- typeNameIfComposite objectType =
             lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
     fieldRule _ _ = lift mempty
     go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors
@@ -1205,3 +1198,91 @@ data FieldInfo m = FieldInfo
     , type' :: Out.Type m
     , parent :: Type.CompositeType m
     }
+
+-- | Fragments are declared on a type and will only apply when the runtime
+-- object type matches the type condition. They also are spread within the
+-- context of a parent type. A fragment spread is only valid if its type
+-- condition could ever apply within the parent type.
+possibleFragmentSpreadsRule :: forall m. Rule m
+possibleFragmentSpreadsRule = SelectionRule go
+  where
+    go (Just parentType) (Full.InlineFragmentSelection fragmentSelection)
+        | Full.InlineFragment maybeType _ _ location' <- fragmentSelection
+        , Just typeCondition <- maybeType = do
+            (fragmentTypeName, parentTypeName) <-
+                compareTypes typeCondition parentType
+            pure $ Error
+                { message = concat
+                    [ "Fragment cannot be spread here as objects of type \""
+                    , Text.unpack parentTypeName
+                    , "\" can never be of type \""
+                    , Text.unpack fragmentTypeName
+                    , "\"."
+                    ]
+                , locations = [location']
+                }
+    go (Just parentType) (Full.FragmentSpreadSelection fragmentSelection)
+        | Full.FragmentSpread fragmentName _ location' <- fragmentSelection = do
+            typeCondition <- findSpreadTarget fragmentName
+            (fragmentTypeName, parentTypeName) <-
+                compareTypes typeCondition parentType
+            pure $ Error
+                { message = concat
+                    [ "Fragment \""
+                    , Text.unpack fragmentName
+                    , "\" cannot be spread here as objects of type \""
+                    , Text.unpack parentTypeName
+                    , "\" can never be of type \""
+                    , Text.unpack fragmentTypeName
+                    , "\"."
+                    ]
+                , locations = [location']
+                }
+    go _ _ = lift mempty
+    compareTypes typeCondition parentType = do
+        types' <- asks $ Schema.types . schema
+        fragmentType <- maybeToSeq
+            $ Type.lookupTypeCondition typeCondition types'
+        parentComposite <- maybeToSeq
+            $ Type.outToComposite parentType
+        possibleFragments <- getPossibleTypes fragmentType
+        possibleParents <- getPossibleTypes parentComposite
+        let fragmentTypeName = compositeTypeName fragmentType
+        let parentTypeName = compositeTypeName parentComposite
+        if HashSet.null $ HashSet.intersection possibleFragments possibleParents
+            then pure (fragmentTypeName, parentTypeName)
+            else lift mempty
+    getPossibleTypeList (Type.CompositeObjectType objectType) =
+        pure [Schema.ObjectType objectType]
+    getPossibleTypeList (Type.CompositeUnionType unionType) =
+        let Out.UnionType _ _ members = unionType
+         in pure $ Schema.ObjectType <$> members
+    getPossibleTypeList (Type.CompositeInterfaceType interfaceType) =
+        let Out.InterfaceType typeName _ _ _ = interfaceType
+         in HashMap.lookupDefault [] typeName
+        <$> asks (Schema.implementations . schema)
+    getPossibleTypes compositeType
+        = foldr (HashSet.insert . internalTypeName) HashSet.empty
+        <$> getPossibleTypeList compositeType
+
+internalTypeName :: forall m. Schema.Type m -> Full.Name
+internalTypeName (Schema.ScalarType (Definition.ScalarType typeName _)) =
+    typeName
+internalTypeName (Schema.EnumType (Definition.EnumType typeName _ _)) = typeName
+internalTypeName (Schema.ObjectType (Out.ObjectType typeName _ _ _)) = typeName
+internalTypeName (Schema.InputObjectType (In.InputObjectType typeName _ _)) =
+    typeName
+internalTypeName (Schema.InterfaceType (Out.InterfaceType typeName _ _ _)) =
+    typeName
+internalTypeName (Schema.UnionType (Out.UnionType typeName _ _)) = typeName
+
+findSpreadTarget :: Full.Name -> ReaderT (Validation m1) Seq Full.TypeCondition
+findSpreadTarget fragmentName = do
+    ast' <- asks ast
+    let target = find (isSpreadTarget fragmentName) ast'
+    maybeToSeq $ target >>= extractTypeCondition
+  where
+    extractTypeCondition (viewFragment -> Just fragmentDefinition) =
+        let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
+            in Just typeCondition
+    extractTypeCondition _ = Nothing
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]