Validate fragment spreads are possible
This commit is contained in:
parent
86a0e00f7e
commit
2dbc985dfc
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
Loading…
Reference in New Issue