Validate fragments on composite types

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

View File

@ -8,13 +8,18 @@ and this project adheres to
## [Unreleased] ## [Unreleased]
### Changed ### 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 ### Added
- `Validate.Validation.Rule`: `SelectionRule` constructor. - `Validate.Validation.Rule`: `SelectionRule`, `FragmentRule` and
`FragmentSpreadRule` constructors.
- `Validate.Rules`: - `Validate.Rules`:
- `fragmentsOnCompositeTypesRule`
- `fragmentSpreadTargetDefinedRule` - `fragmentSpreadTargetDefinedRule`
- `fragmentSpreadTypeExistenceRule` - `fragmentSpreadTypeExistenceRule`
- `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`.
### Fixed ### Fixed
- Collecting existing types from the schema considers subscriptions. - Collecting existing types from the schema considers subscriptions.

View File

@ -17,7 +17,9 @@ module Language.GraphQL.AST.Document
, ExecutableDefinition(..) , ExecutableDefinition(..)
, FieldDefinition(..) , FieldDefinition(..)
, FragmentDefinition(..) , FragmentDefinition(..)
, FragmentSpread(..)
, ImplementsInterfaces(..) , ImplementsInterfaces(..)
, InlineFragment(..)
, InputValueDefinition(..) , InputValueDefinition(..)
, Location(..) , Location(..)
, Name , 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 -- A fragment spread refers to a fragment defined outside the operation and is
-- expanded at the execution time. -- expanded at the execution time.
-- --
@ -148,23 +171,7 @@ type SelectionSetOpt = [Selection]
-- name -- name
-- } -- }
-- @ -- @
-- data FragmentSpread = FragmentSpread Name [Directive] Location
-- 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
deriving (Eq, Show) deriving (Eq, Show)
-- ** Arguments -- ** Arguments

View File

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

View File

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

View File

@ -298,8 +298,15 @@ selection (Full.Field alias name arguments' directives' selections _) =
where where
go arguments (Full.Argument name' value') = go arguments (Full.Argument name' value') =
inputField arguments 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 maybe (Left mempty) (Right . SelectionFragment) <$> do
spreadDirectives <- Definition.selection <$> directives directives' spreadDirectives <- Definition.selection <$> directives directives'
fragments' <- gets fragments fragments' <- gets fragments
@ -314,7 +321,11 @@ selection (Full.FragmentSpread name directives' _) =
Just fragment -> lift $ pure $ fragment <$ spreadDirectives Just fragment -> lift $ pure $ fragment <$ spreadDirectives
_ -> lift $ pure Nothing _ -> lift $ pure Nothing
| otherwise -> 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' fragmentDirectives <- Definition.selection <$> directives directives'
case fragmentDirectives of case fragmentDirectives of
Nothing -> pure $ Left mempty Nothing -> pure $ Left mempty

View File

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

View File

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

View File

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

View File

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

View File

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