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

Validate fragment spreads are possible

Browse Source
This commit is contained in:
Eugen Wissner
2020-11-19 08:48:37 +01:00
parent 86a0e00f7e
commit 2dbc985dfc
3 changed files with 183 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
CHANGELOG.md
View File

@@ -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.

133
src/Language/GraphQL/Validate/Rules.hs
View File

@@ -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

83
tests/Language/GraphQL/ValidateSpec.hs
View File

@@ -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]