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

Validate all fragments are used

Browse Source
This commit is contained in:
Eugen Wissner 2020-09-09 17:04:31 +02:00
parent f6ff0ab9c7
commit c2c57b6363
10 changed files with 141 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
CHANGELOG.md
View File

@ -8,22 +8,27 @@ and this project adheres to
## [Unreleased]
### Changed
- `AST.Document.Selection` wraps additional new types: `FragmentSpread`
and `InlineFragment`. Thus validation rules can be more concise.
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
and `InlineFragment`. Thus validation rules can be defined more concise.
### Added
- `Validate.Validation.Rule`: `SelectionRule`, `FragmentRule` and
- `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule` and
`FragmentSpreadRule` constructors.
- `Validate.Rules`:
- `fragmentsOnCompositeTypesRule`
- `fragmentSpreadTargetDefinedRule`
- `fragmentSpreadTypeExistenceRule`
- `noUnusedFragmentsRule`
- `AST.Document.Field`.
- `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`.
### Fixed
- Collecting existing types from the schema considers subscriptions.
### Removed
- `AST.Document.Alias`. Use `AST.Document.Name` instead.
## [0.10.0.0] - 2020-08-29
### Changed
- `Test.Hspec.GraphQL.*`: replace `IO` in the resolver with any `MonadCatch`.

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

@ -5,8 +5,7 @@
-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
-- for more information.
module Language.GraphQL.AST.Document
( Alias
, Argument(..)
( Argument(..)
, ArgumentsDefinition(..)
, ConstValue(..)
, Definition(..)
@ -15,6 +14,7 @@ module Language.GraphQL.AST.Document
, Document
, EnumValueDefinition(..)
, ExecutableDefinition(..)
, Field(..)
, FieldDefinition(..)
, FragmentDefinition(..)
, FragmentSpread(..)
@ -118,9 +118,14 @@ type SelectionSet = NonEmpty Selection
-- | Field selection.
type SelectionSetOpt = [Selection]
-- | Selection is a single entry in a selection set. It can be a single field,
-- fragment spread or inline fragment.
--
-- | Selection is a single entry in a selection set. It can be a single 'Field',
-- 'FragmentSpread' or an 'InlineFragment'.
data Selection
= FieldSelection Field
| FragmentSpreadSelection FragmentSpread
| InlineFragmentSelection InlineFragment
deriving (Eq, Show)
-- The only required property of a field is its name. Optionally it can also
-- have an alias, arguments, directives and a list of subfields.
--
@ -134,10 +139,8 @@ type SelectionSetOpt = [Selection]
-- }
-- }
-- @
data Selection
= Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt Location
| FragmentSpreadSelection FragmentSpread
| InlineFragmentSelection InlineFragment
data Field =
Field (Maybe Name) Name [Argument] [Directive] SelectionSetOpt Location
deriving (Eq, Show)
-- Inline fragments don't have any name and the type condition ("on UserType")
@ -189,22 +192,6 @@ data FragmentSpread = FragmentSpread Name [Directive] Location
-- Here "id" is an argument for the field "user" and its value is 4.
data Argument = Argument Name Value deriving (Eq,Show)
-- ** Field Alias
-- | Alternative field name.
--
-- @
-- {
-- smallPic: profilePic(size: 64)
-- bigPic: profilePic(size: 1024)
-- }
-- @
--
-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
-- used to distinquish between profile pictures with different arguments
-- (sizes).
type Alias = Name
-- ** Fragments
-- | Fragment definition.

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

@ -126,8 +126,8 @@ indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
selection :: Formatter -> Selection -> Lazy.Text
selection formatter = Lazy.Text.append indent' . encodeSelection
where
encodeSelection (Field alias name args directives' selections _) =
field incrementIndent alias name args directives' selections
encodeSelection (FieldSelection fieldSelection) =
field incrementIndent fieldSelection
encodeSelection (InlineFragmentSelection fragmentSelection) =
inlineFragment incrementIndent fragmentSelection
encodeSelection (FragmentSpreadSelection fragmentSelection) =
@ -142,15 +142,9 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
colon :: Formatter -> Lazy.Text
colon formatter = eitherFormat formatter ": " ":"
-- | Converts Field into a string
field :: Formatter ->
Maybe Name ->
Name ->
[Argument] ->
[Directive] ->
[Selection] ->
Lazy.Text
field formatter alias name args dirs set
-- | Converts Field into a string.
field :: Formatter -> Field -> Lazy.Text
field formatter (Field alias name args dirs set _)
= optempty prependAlias (fold alias)
<> Lazy.Text.fromStrict name
<> optempty (arguments formatter) args

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

@ -376,12 +376,12 @@ selectionSetOpt :: Parser SelectionSetOpt
selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
selection :: Parser Selection
selection = field
selection = FieldSelection <$> field
<|> FragmentSpreadSelection <$> try fragmentSpread
<|> InlineFragmentSelection <$> inlineFragment
<?> "Selection"
field :: Parser Selection
field :: Parser Field
field = label "Field" $ do
location <- getLocation
alias' <- optional alias
@ -391,7 +391,7 @@ field = label "Field" $ do
selectionSetOpt' <- selectionSetOpt
pure $ Field alias' name' arguments' directives' selectionSetOpt' location
alias :: Parser Alias
alias :: Parser Name
alias = try (name <* colon) <?> "Alias"
arguments :: Parser [Argument]

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

@ -288,39 +288,42 @@ operation operationDefinition replacement
selection
:: Full.Selection
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
selection (Full.Field alias name arguments' directives' selections _) =
maybe (Left mempty) (Right . SelectionField) <$> do
fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections
fieldDirectives <- Definition.selection <$> directives directives'
let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives
where
go arguments (Full.Argument name' value') =
inputField arguments name' value'
selection (Full.FragmentSpreadSelection fragmentSelection) =
fragmentSpread fragmentSelection
selection (Full.FieldSelection fieldSelection) =
maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
selection (Full.FragmentSpreadSelection fragmentSelection)
= maybe (Left mempty) (Right . SelectionFragment)
<$> fragmentSpread fragmentSelection
selection (Full.InlineFragmentSelection fragmentSelection) =
inlineFragment fragmentSelection
field :: Full.Field -> State (Replacement m) (Maybe (Field m))
field (Full.Field alias name arguments' directives' selections _) = do
fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections
fieldDirectives <- Definition.selection <$> directives directives'
let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives
where
go arguments (Full.Argument name' value') =
inputField arguments name' value'
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
-> State (Replacement m) (Maybe (Fragment m))
fragmentSpread (Full.FragmentSpread name directives' _) = do
spreadDirectives <- Definition.selection <$> directives directives'
fragments' <- gets fragments
fragmentDefinitions' <- gets fragmentDefinitions
case HashMap.lookup name fragments' of
Just definition -> lift $ pure $ definition <$ spreadDirectives
Nothing
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
fragDef <- fragmentDefinition definition
case fragDef of
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
_ -> lift $ pure Nothing
| otherwise -> lift $ pure Nothing
fragmentDefinitions' <- gets fragmentDefinitions
case HashMap.lookup name fragments' of
Just definition -> lift $ pure $ definition <$ spreadDirectives
Nothing
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
fragDef <- fragmentDefinition definition
case fragDef of
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
_ -> lift $ pure Nothing
| otherwise -> lift $ pure Nothing
inlineFragment
:: Full.InlineFragment

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

@ -85,8 +85,8 @@ selection :: forall m. Selection -> ValidateT m
selection selection'
| FragmentSpreadSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ fragmentSpread fragmentSelection
| Field _ _ _ _ selectionSet _ <- selection' =
visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
| FieldSelection fieldSelection <- selection' =
visitChildSelections ruleFilter $ field fieldSelection
| InlineFragmentSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ inlineFragment fragmentSelection
where
@ -94,6 +94,14 @@ selection selection'
mapReaderT (runRule accumulator) $ rule selection'
ruleFilter accumulator _ = pure accumulator
field :: forall m. Field -> ValidateT m
field field'@(Field _ _ _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections
where
ruleFilter accumulator (FieldRule rule) =
mapReaderT (runRule accumulator) $ rule field'
ruleFilter accumulator _ = pure accumulator
inlineFragment :: forall m. InlineFragment -> ValidateT m
inlineFragment fragment@(InlineFragment _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections

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

@ -14,6 +14,7 @@ module Language.GraphQL.Validate.Rules
, fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule
, loneAnonymousOperationRule
, noUnusedFragmentsRule
, singleFieldSubscriptionsRule
, specifiedRules
, uniqueFragmentNamesRule
@ -45,9 +46,10 @@ specifiedRules =
, uniqueOperationNamesRule
-- Fragments.
, uniqueFragmentNamesRule
, fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule
, fragmentsOnCompositeTypesRule
, noUnusedFragmentsRule
, fragmentSpreadTargetDefinedRule
]
-- | Definition must be OperationDefinition or FragmentDefinition.
@ -92,15 +94,16 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
"Anonymous Subscription must select only one top level field."
collectFields selectionSet = foldM forEach HashSet.empty selectionSet
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
FieldSelection fieldSelection -> forField accumulator fieldSelection
FragmentSpreadSelection fragmentSelection ->
forSpread accumulator fragmentSelection
InlineFragmentSelection fragmentSelection ->
forInline accumulator fragmentSelection
forField accumulator (Field alias name _ directives _ _)
| any skip directives = pure accumulator
| Just aliasedName <- alias = pure
$ HashSet.insert aliasedName accumulator
| otherwise = pure $ HashSet.insert name accumulator
forSpread accumulator (FragmentSpread fragmentName directives _)
| any skip directives = pure accumulator
| otherwise = do
@ -129,7 +132,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
Just compositeType
| Just objectType <- Schema.subscription schema'
, True <- doesFragmentTypeApply compositeType objectType ->
HashSet.union accumulator<$> collectFields selectionSet
HashSet.union accumulator <$> collectFields selectionSet
| otherwise -> pure accumulator
collectFromSpread fragmentName accumulator = do
modify $ HashSet.insert fragmentName
@ -338,3 +341,44 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
, Text.unpack typeCondition,
"\"."
]
-- | Defined fragments must be used within a document.
noUnusedFragmentsRule :: forall m. Rule m
noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment ->
asks ast >>= findSpreadByName fragment
where
findSpreadByName (FragmentDefinition fragName _ _ _ location) definitions
| foldr (go fragName) False definitions = lift Nothing
| otherwise = pure $ Error
{ message = errorMessage fragName
, locations = [location]
, path = []
}
errorMessage fragName = concat
[ "Fragment \""
, Text.unpack fragName
, "\" is never used."
]
go fragName (viewOperation -> Just operation) accumulator
| SelectionSet selections _ <- operation =
evaluateSelections fragName accumulator selections
| OperationDefinition _ _ _ _ selections _ <- operation =
evaluateSelections fragName accumulator selections
go fragName (viewFragment -> Just fragment) accumulator
| FragmentDefinition _ _ _ selections _ <- fragment =
evaluateSelections fragName accumulator selections
go _ _ _ = False
evaluateSelection fragName selection accumulator
| FragmentSpreadSelection spreadSelection <- selection
, FragmentSpread spreadName _ _ <- spreadSelection
, spreadName == fragName = True
| FieldSelection fieldSelection <- selection
, Field _ _ _ _ selections _ <- fieldSelection =
evaluateSelections fragName accumulator selections
| InlineFragmentSelection inlineSelection <- selection
, InlineFragment _ _ selections _ <- inlineSelection =
evaluateSelections fragName accumulator selections
| otherwise = accumulator || False
evaluateSelections :: Foldable t => Name -> Bool -> t Selection -> Bool
evaluateSelections fragName accumulator selections =
foldr (evaluateSelection fragName) accumulator selections

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

@ -52,6 +52,7 @@ data Rule m
| SelectionRule (Selection -> RuleT m)
| FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
| FragmentSpreadRule (FragmentSpread -> RuleT m)
| FieldRule (Field -> RuleT m)
-- | Monad transformer used by the rules.
type RuleT m = ReaderT (Validation m) Maybe Error

2
tests/Language/GraphQL/AST/EncoderSpec.hs
View File

@ -124,7 +124,7 @@ spec = do
let arguments = [Argument "message" (String "line1\nline2")]
field = Field Nothing "field" arguments [] [] $ Location 0 0
operation = DefinitionOperation
$ SelectionSet (pure field)
$ SelectionSet (pure $ FieldSelection field)
$ Location 0 0
in definition pretty operation `shouldBe` [r|{
field(message: """

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

@ -373,3 +373,23 @@ spec =
, path = []
}
in validate queryString `shouldBe` Seq.singleton expected
it "rejects unused fragments" $
let queryString = [r|
fragment nameFragment on Dog { # unused
name
}
{
dog {
name
}
}
|]
expected = Error
{ message =
"Fragment \"nameFragment\" is never used."
, locations = [AST.Location 2 15]
, path = []
}
in validate queryString `shouldBe` Seq.singleton expected