prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Validate fragments on composite types

Browse Source
This commit is contained in:
Eugen Wissner 2020-09-07 22:01:49 +02:00
parent d327d9d1ce
commit f6ff0ab9c7
10 changed files with 212 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
CHANGELOG.md
View File

@ -8,13 +8,18 @@ and this project adheres to
## [Unreleased]
### Changed
- Added location information to `AST.Document.Selection`.
- `AST.Document.Selection` wraps additional new types: `FragmentSpread`
and `InlineFragment`. Thus validation rules can be more concise.
### Added
- `Validate.Validation.Rule`: `SelectionRule` constructor.
- `Validate.Validation.Rule`: `SelectionRule`, `FragmentRule` and
`FragmentSpreadRule` constructors.
- `Validate.Rules`:
- `fragmentsOnCompositeTypesRule`
- `fragmentSpreadTargetDefinedRule`
- `fragmentSpreadTypeExistenceRule`
- `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`.
### Fixed
- Collecting existing types from the schema considers subscriptions.

41
src/Language/GraphQL/AST/Document.hs
View File

@ -17,7 +17,9 @@ module Language.GraphQL.AST.Document
, ExecutableDefinition(..)
, FieldDefinition(..)
, FragmentDefinition(..)
, FragmentSpread(..)
, ImplementsInterfaces(..)
, InlineFragment(..)
, InputValueDefinition(..)
, Location(..)
, Name
@ -132,7 +134,28 @@ type SelectionSetOpt = [Selection]
-- }
-- }
-- @
data Selection
= Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location
| FragmentSpreadSelection FragmentSpread
| InlineFragmentSelection InlineFragment
deriving (Eq, Show)
-- Inline fragments don't have any name and the type condition ("on UserType")
-- is optional.
--
-- @
-- {
-- user {
-- ... on UserType {
-- id
-- name
-- }
-- }
-- @
data InlineFragment = InlineFragment
(Maybe TypeCondition) [Directive] SelectionSet Location
deriving (Eq, Show)
-- A fragment spread refers to a fragment defined outside the operation and is
-- expanded at the execution time.
--
@ -148,23 +171,7 @@ type SelectionSetOpt = [Selection]
-- name
-- }
-- @
--
-- Inline fragments are similar but they don't have any name and the type
-- condition ("on UserType") is optional.
--
-- @
-- {
-- user {
-- ... on UserType {
-- id
-- name
-- }
-- }
-- @
data Selection
= Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location
| FragmentSpread Name [Directive] Location
| InlineFragment (Maybe TypeCondition) [Directive] SelectionSet Location
data FragmentSpread = FragmentSpread Name [Directive] Location
deriving (Eq, Show)
-- ** Arguments

28
src/Language/GraphQL/AST/Encoder.hs
View File

@ -128,10 +128,10 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
where
encodeSelection (Field alias name args directives' selections _) =
field incrementIndent alias name args directives' selections
encodeSelection (InlineFragment typeCondition directives' selections _) =
inlineFragment incrementIndent typeCondition directives' selections
encodeSelection (FragmentSpread name directives' _) =
fragmentSpread incrementIndent name directives'
encodeSelection (InlineFragmentSelection fragmentSelection) =
inlineFragment incrementIndent fragmentSelection
encodeSelection (FragmentSpreadSelection fragmentSelection) =
fragmentSpread incrementIndent fragmentSelection
incrementIndent
| Pretty indentation <- formatter = Pretty $ indentation + 1
| otherwise = Minified
@ -172,22 +172,18 @@ argument formatter (Argument name value')
-- * Fragments
fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
fragmentSpread formatter name directives'
fragmentSpread :: Formatter -> FragmentSpread -> Lazy.Text
fragmentSpread formatter (FragmentSpread name directives' _)
= "..." <> Lazy.Text.fromStrict name
<> optempty (directives formatter) directives'
inlineFragment ::
Formatter ->
Maybe TypeCondition ->
[Directive] ->
SelectionSet ->
Lazy.Text
inlineFragment formatter tc dirs sels = "... on "
<> Lazy.Text.fromStrict (fold tc)
<> directives formatter dirs
inlineFragment :: Formatter -> InlineFragment -> Lazy.Text
inlineFragment formatter (InlineFragment typeCondition directives' selections _)
= "... on "
<> Lazy.Text.fromStrict (fold typeCondition)
<> directives formatter directives'
<> eitherFormat formatter " " mempty
<> selectionSet formatter sels
<> selectionSet formatter selections
fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)

8
src/Language/GraphQL/AST/Parser.hs
View File

@ -377,8 +377,8 @@ selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
selection :: Parser Selection
selection = field
<|> try fragmentSpread
<|> inlineFragment
<|> FragmentSpreadSelection <$> try fragmentSpread
<|> InlineFragmentSelection <$> inlineFragment
<?> "Selection"
field :: Parser Selection
@ -400,7 +400,7 @@ arguments = listOptIn parens argument <?> "Arguments"
argument :: Parser Argument
argument = Argument <$> name <* colon <*> value <?> "Argument"
fragmentSpread :: Parser Selection
fragmentSpread :: Parser FragmentSpread
fragmentSpread = label "FragmentSpread" $ do
location <- getLocation
_ <- spread
@ -408,7 +408,7 @@ fragmentSpread = label "FragmentSpread" $ do
directives' <- directives
pure $ FragmentSpread fragmentName' directives' location
inlineFragment :: Parser Selection
inlineFragment :: Parser InlineFragment
inlineFragment = label "InlineFragment" $ do
location <- getLocation
_ <- spread

15
src/Language/GraphQL/Execute/Transform.hs
View File

@ -298,8 +298,15 @@ selection (Full.Field alias name arguments' directives' selections _) =
where
go arguments (Full.Argument name' value') =
inputField arguments name' value'
selection (Full.FragmentSpreadSelection fragmentSelection) =
fragmentSpread fragmentSelection
selection (Full.InlineFragmentSelection fragmentSelection) =
inlineFragment fragmentSelection
selection (Full.FragmentSpread name directives' _) =
fragmentSpread
:: Full.FragmentSpread
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
fragmentSpread (Full.FragmentSpread name directives' _) =
maybe (Left mempty) (Right . SelectionFragment) <$> do
spreadDirectives <- Definition.selection <$> directives directives'
fragments' <- gets fragments
@ -314,7 +321,11 @@ selection (Full.FragmentSpread name directives' _) =
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
_ -> lift $ pure Nothing
| otherwise -> lift $ pure Nothing
selection (Full.InlineFragment type' directives' selections _) = do
inlineFragment
:: Full.InlineFragment
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
inlineFragment (Full.InlineFragment type' directives' selections _) = do
fragmentDirectives <- Definition.selection <$> directives directives'
case fragmentDirectives of
Nothing -> pure $ Left mempty

70
src/Language/GraphQL/Validate.hs
View File

@ -3,7 +3,6 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
-- | GraphQL validator.
module Language.GraphQL.Validate
@ -41,18 +40,15 @@ document schema' rules' document' =
go definition' accumulator = (accumulator ><) <$> definition definition'
definition :: forall m. Definition -> ValidateT m
definition = \case
definition'@(ExecutableDefinition executableDefinition') -> do
applied <- applyRules definition'
children <- executableDefinition executableDefinition'
pure $ children >< applied
definition' -> applyRules definition'
definition definition'
| ExecutableDefinition executableDefinition' <- definition'
= visitChildSelections ruleFilter
$ executableDefinition executableDefinition'
| otherwise = asks rules >>= foldM ruleFilter Seq.empty
where
applyRules definition' =
asks rules >>= foldM (ruleFilter definition') Seq.empty
ruleFilter definition' accumulator (DefinitionRule rule) =
ruleFilter accumulator (DefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule definition'
ruleFilter _ accumulator _ = pure accumulator
ruleFilter accumulator _ = pure accumulator
runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
runRule accumulator (Just error') = pure $ accumulator |> error'
@ -67,7 +63,7 @@ executableDefinition (DefinitionFragment definition') =
operationDefinition :: forall m. OperationDefinition -> ValidateT m
operationDefinition operation =
let selectionSet = getSelectionSet operation
in visitChildSelections ruleFilter selectionSet
in visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
where
ruleFilter accumulator (OperationDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule operation
@ -75,36 +71,54 @@ operationDefinition operation =
getSelectionSet (SelectionSet selectionSet _) = selectionSet
getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet
visitChildSelections :: forall m
. (Seq Error -> Rule m -> ValidateT m)
-> ValidateT m
-> ValidateT m
visitChildSelections ruleFilter children' = do
rules' <- asks rules
applied <- foldM ruleFilter Seq.empty rules'
children <- children'
pure $ children >< applied
selection :: forall m. Selection -> ValidateT m
selection selection'
| FragmentSpread{} <- selection' =
asks rules >>= foldM ruleFilter Seq.empty
| FragmentSpreadSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ fragmentSpread fragmentSelection
| Field _ _ _ _ selectionSet _ <- selection' =
visitChildSelections ruleFilter selectionSet
| InlineFragment _ _ selectionSet _ <- selection' =
visitChildSelections ruleFilter selectionSet
visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
| InlineFragmentSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ inlineFragment fragmentSelection
where
ruleFilter accumulator (SelectionRule rule) =
mapReaderT (runRule accumulator) $ rule selection'
ruleFilter accumulator _ = pure accumulator
inlineFragment :: forall m. InlineFragment -> ValidateT m
inlineFragment fragment@(InlineFragment _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections
where
ruleFilter accumulator (FragmentRule _ inlineRule) =
mapReaderT (runRule accumulator) $ inlineRule fragment
ruleFilter accumulator _ = pure accumulator
fragmentSpread :: forall m. FragmentSpread -> ValidateT m
fragmentSpread fragment =
asks rules >>= foldM ruleFilter Seq.empty
where
ruleFilter accumulator (FragmentSpreadRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator _ = pure accumulator
traverseSelectionSet :: Traversable t => forall m. t Selection -> ValidateT m
traverseSelectionSet = fmap fold . traverse selection
visitChildSelections :: Traversable t
=> (Seq Error -> Rule m -> ValidateT m)
-> t Selection
-> ValidateT m
visitChildSelections ruleFilter selectionSet = do
rules' <- asks rules
applied <- foldM ruleFilter Seq.empty rules'
children <- traverseSelectionSet selectionSet
pure $ children >< applied
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
fragmentDefinition fragment@(FragmentDefinition _ _ _ selectionSet _) =
visitChildSelections ruleFilter selectionSet
visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
where
ruleFilter accumulator (FragmentDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator (FragmentRule definitionRule _) =
mapReaderT (runRule accumulator) $ definitionRule fragment
ruleFilter accumulator _ = pure accumulator

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

@ -10,6 +10,7 @@
-- | This module contains default rules defined in the GraphQL specification.
module Language.GraphQL.Validate.Rules
( executableDefinitionsRule
, fragmentsOnCompositeTypesRule
, fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule
, loneAnonymousOperationRule
@ -46,6 +47,7 @@ specifiedRules =
, uniqueFragmentNamesRule
, fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule
, fragmentsOnCompositeTypesRule
]
-- | Definition must be OperationDefinition or FragmentDefinition.
@ -89,24 +91,29 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
errorMessage =
"Anonymous Subscription must select only one top level field."
collectFields selectionSet = foldM forEach HashSet.empty selectionSet
forEach accumulator (Field alias name _ directives _ _)
| any skip directives = pure accumulator
| Just aliasedName <- alias = pure
$ HashSet.insert aliasedName accumulator
| otherwise = pure $ HashSet.insert name accumulator
forEach accumulator (FragmentSpread fragmentName directives _)
forEach accumulator = \case
Field alias name _ directives _ _
| any skip directives -> pure accumulator
| Just aliasedName <- alias -> pure
$ HashSet.insert aliasedName accumulator
| otherwise -> pure $ HashSet.insert name accumulator
FragmentSpreadSelection fragmentSelection ->
forSpread accumulator fragmentSelection
InlineFragmentSelection fragmentSelection ->
forInline accumulator fragmentSelection
forSpread accumulator (FragmentSpread fragmentName directives _)
| any skip directives = pure accumulator
| otherwise = do
inVisitetFragments <- gets $ HashSet.member fragmentName
if inVisitetFragments
then pure accumulator
else collectFromSpread fragmentName accumulator
forEach accumulator (InlineFragment typeCondition' directives selectionSet _)
forInline accumulator (InlineFragment maybeType directives selections _)
| any skip directives = pure accumulator
| Just typeCondition <- typeCondition' =
collectFromFragment typeCondition selectionSet accumulator
| Just typeCondition <- maybeType =
collectFromFragment typeCondition selections accumulator
| otherwise = HashSet.union accumulator
<$> collectFields selectionSet
<$> collectFields selections
skip (Directive "skip" [Argument "if" (Boolean True)]) = True
skip (Directive "include" [Argument "if" (Boolean False)]) = True
skip _ = False
@ -233,7 +240,7 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
-- | Named fragment spreads must refer to fragments defined within the document.
-- It is a validation error if the target of a spread is not defined.
fragmentSpreadTargetDefinedRule :: forall m. Rule m
fragmentSpreadTargetDefinedRule = SelectionRule $ \case
fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
FragmentSpread fragmentName _ location -> do
ast' <- asks ast
case find (isSpreadTarget fragmentName) ast' of
@ -243,7 +250,6 @@ fragmentSpreadTargetDefinedRule = SelectionRule $ \case
, path = []
}
Just _ -> lift Nothing
_ -> lift Nothing
where
error' fragmentName = concat
[ "Fragment target \""
@ -262,27 +268,30 @@ isSpreadTarget _ _ = False
-- the query does not validate.
fragmentSpreadTypeExistenceRule :: forall m. Rule m
fragmentSpreadTypeExistenceRule = SelectionRule $ \case
FragmentSpread fragmentName _ location -> do
ast' <- asks ast
target <- lift $ find (isSpreadTarget fragmentName) ast'
typeCondition <- extractTypeCondition target
types' <- asks types
case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error
{ message = spreadError fragmentName typeCondition
, locations = [location]
, path = []
}
Just _ -> lift Nothing
InlineFragment (Just typeCondition) _ _ location -> do
types' <- asks types
case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error
{ message = inlineError typeCondition
, locations = [location]
, path = []
}
Just _ -> lift Nothing
FragmentSpreadSelection fragmentSelection
| FragmentSpread fragmentName _ location <- fragmentSelection -> do
ast' <- asks ast
target <- lift $ find (isSpreadTarget fragmentName) ast'
typeCondition <- extractTypeCondition target
types' <- asks types
case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error
{ message = spreadError fragmentName typeCondition
, locations = [location]
, path = []
}
Just _ -> lift Nothing
InlineFragmentSelection fragmentSelection
| InlineFragment maybeType _ _ location <- fragmentSelection
, Just typeCondition <- maybeType -> do
types' <- asks types
case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error
{ message = inlineError typeCondition
, locations = [location]
, path = []
}
Just _ -> lift Nothing
_ -> lift Nothing
where
extractTypeCondition (viewFragment -> Just fragmentDefinition) =
@ -301,3 +310,31 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ \case
, Text.unpack typeCondition
, "\" which doesn't exist in the schema."
]
-- | 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
-- applies to both inline and named fragments.
fragmentsOnCompositeTypesRule :: forall m. Rule m
fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
where
inlineRule (InlineFragment (Just typeCondition) _ _ location) =
check typeCondition location
inlineRule _ = lift Nothing
definitionRule (FragmentDefinition _ typeCondition _ _ location) =
check typeCondition location
check typeCondition location = do
types' <- asks types
-- Skip unknown types, they are checked by another rule.
_ <- lift $ HashMap.lookup typeCondition types'
case lookupTypeCondition typeCondition types' of
Nothing -> pure $ Error
{ message = errorMessage typeCondition
, locations = [location]
, path = []
}
Just _ -> lift Nothing
errorMessage typeCondition = concat
[ "Fragment cannot condition on non composite type \""
, Text.unpack typeCondition,
"\"."
]

2
src/Language/GraphQL/Validate/Validation.hs
View File

@ -50,6 +50,8 @@ data Rule m
| OperationDefinitionRule (OperationDefinition -> RuleT m)
| FragmentDefinitionRule (FragmentDefinition -> RuleT m)
| SelectionRule (Selection -> RuleT m)
| FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
| FragmentSpreadRule (FragmentSpread -> RuleT m)
-- | Monad transformer used by the rules.
type RuleT m = ReaderT (Validation m) Maybe Error

2
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-16.12
resolver: lts-16.13
packages:
- .

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

@ -336,3 +336,40 @@ spec =
, path = []
}
in validate queryString `shouldBe` Seq.singleton 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]
, path = []
}
in validate queryString `shouldBe` Seq.singleton 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]
, path = []
}
in validate queryString `shouldBe` Seq.singleton expected