diff options
| -rw-r--r-- | CHANGELOG.md | 11 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Document.hs | 37 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 16 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 6 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Transform.hs | 57 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate.hs | 12 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 58 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Validation.hs | 1 | ||||
| -rw-r--r-- | tests/Language/GraphQL/AST/EncoderSpec.hs | 2 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ValidateSpec.hs | 20 |
10 files changed, 141 insertions, 79 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 2e74142..29710bb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 5cfadc5..cc657f4 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -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. diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 0757867..dcc24fe 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index e68956f..136067b 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -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] diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index e36db55..6c7c141 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -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 +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' -selection (Full.FragmentSpreadSelection fragmentSelection) = - fragmentSpread fragmentSelection -selection (Full.InlineFragmentSelection fragmentSelection) = - inlineFragment fragmentSelection 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 - - 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 + -> 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 inlineFragment :: Full.InlineFragment diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 1ffa514..7aafa64 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -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 diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 28e12a3..6a079f1 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -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 diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index fb04b76..a513467 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -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 diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs index 85add18..9326fd1 100644 --- a/tests/Language/GraphQL/AST/EncoderSpec.hs +++ b/tests/Language/GraphQL/AST/EncoderSpec.hs @@ -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: """ diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index a95c4d6..10b6688 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -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 |