From 497b93c41b2534ec2b92b49e93267178417bef56 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 17 Sep 2020 10:33:37 +0200 Subject: [PATCH] Validate arguments have unique names --- CHANGELOG.md | 3 +- src/Language/GraphQL/Validate.hs | 128 +++++++++++++++++--- src/Language/GraphQL/Validate/Rules.hs | 32 ++++- src/Language/GraphQL/Validate/Validation.hs | 1 + stack.yaml | 2 +- tests/Language/GraphQL/ValidateSpec.hs | 15 +++ 6 files changed, 160 insertions(+), 21 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d26c746..1c904d7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,13 +24,14 @@ and this project adheres to ### Added - `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule`, - `FragmentSpreadRule` constructors. + `FragmentSpreadRule`, `ArgumentsRule` constructors. - `Validate.Rules`: - `fragmentsOnCompositeTypesRule` - `fragmentSpreadTargetDefinedRule` - `fragmentSpreadTypeExistenceRule` - `noUnusedFragmentsRule` - `noFragmentCyclesRule` + - `uniqueArgumentNamesRule` - `AST.Document.Field`. - `AST.Document.FragmentSpread`. - `AST.Document.InlineFragment`. diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 41a5e9e..00ba629 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} -- | GraphQL validator. module Language.GraphQL.Validate @@ -38,11 +39,47 @@ document schema' rules' document' = join $ lift $ foldr (definition rule') Seq.empty document' definition :: Rule m -> Definition -> Seq (RuleT m) -> Seq (RuleT m) -definition (DefinitionRule rule) definition' acc = - acc |> rule definition' -definition rule (ExecutableDefinition executableDefinition') acc = - acc >< executableDefinition rule executableDefinition' -definition _ _ acc = acc +definition (DefinitionRule rule) definition' accumulator = + accumulator |> rule definition' +definition rule (ExecutableDefinition executableDefinition') accumulator = + accumulator >< executableDefinition rule executableDefinition' +definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator = + accumulator >< typeSystemDefinition rule typeSystemDefinition' +definition rule (TypeSystemExtension extension _) accumulator = + accumulator >< typeSystemExtension rule extension + +typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m) +typeSystemExtension rule = \case + SchemaExtension extension -> schemaExtension rule extension + TypeExtension extension -> typeExtension rule extension + +typeExtension :: Rule m -> TypeExtension -> Seq (RuleT m) +typeExtension rule = \case + ScalarTypeExtension _ directives' -> directives rule directives' + ObjectTypeFieldsDefinitionExtension _ _ directives' fields -> + directives rule directives' >< foldMap (fieldDefinition rule) fields + ObjectTypeDirectivesExtension _ _ directives' -> directives rule directives' + ObjectTypeImplementsInterfacesExtension _ _ -> mempty + InterfaceTypeFieldsDefinitionExtension _ directives' fields -> + directives rule directives' >< foldMap (fieldDefinition rule) fields + InterfaceTypeDirectivesExtension _ directives' -> + directives rule directives' + UnionTypeUnionMemberTypesExtension _ directives' _ -> + directives rule directives' + UnionTypeDirectivesExtension _ directives' -> directives rule directives' + EnumTypeEnumValuesDefinitionExtension _ directives' values -> + directives rule directives' >< foldMap (enumValueDefinition rule) values + EnumTypeDirectivesExtension _ directives' -> directives rule directives' + InputObjectTypeInputFieldsDefinitionExtension _ directives' fields + -> directives rule directives' + >< foldMap (inputValueDefinition rule) fields + InputObjectTypeDirectivesExtension _ directives' -> + directives rule directives' + +schemaExtension :: Rule m -> SchemaExtension -> Seq (RuleT m) +schemaExtension rule = \case + SchemaOperationExtension directives' _ -> directives rule directives' + SchemaDirectivesExtension directives' -> directives rule directives' executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m) executableDefinition rule (DefinitionOperation operation) = @@ -50,23 +87,60 @@ executableDefinition rule (DefinitionOperation operation) = executableDefinition rule (DefinitionFragment fragment) = fragmentDefinition rule fragment +typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m) +typeSystemDefinition rule = \case + SchemaDefinition directives' _ -> directives rule directives' + TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition' + DirectiveDefinition _ _ arguments _ -> argumentsDefinition rule arguments + +typeDefinition :: Rule m -> TypeDefinition -> Seq (RuleT m) +typeDefinition rule = \case + ScalarTypeDefinition _ _ directives' -> directives rule directives' + ObjectTypeDefinition _ _ _ directives' fields -> + directives rule directives' >< foldMap (fieldDefinition rule) fields + InterfaceTypeDefinition _ _ directives' fields -> + directives rule directives' >< foldMap (fieldDefinition rule) fields + UnionTypeDefinition _ _ directives' _ -> directives rule directives' + EnumTypeDefinition _ _ directives' values -> + directives rule directives' >< foldMap (enumValueDefinition rule) values + InputObjectTypeDefinition _ _ directives' fields + -> directives rule directives' + <> foldMap (inputValueDefinition rule) fields + +enumValueDefinition :: Rule m -> EnumValueDefinition -> Seq (RuleT m) +enumValueDefinition rule (EnumValueDefinition _ _ directives') = + directives rule directives' + +fieldDefinition :: Rule m -> FieldDefinition -> Seq (RuleT m) +fieldDefinition rule (FieldDefinition _ _ arguments _ directives') = + directives rule directives' >< argumentsDefinition rule arguments + +argumentsDefinition :: Rule m -> ArgumentsDefinition -> Seq (RuleT m) +argumentsDefinition rule (ArgumentsDefinition definitions) = + foldMap (inputValueDefinition rule) definitions + +inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m) +inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') = + directives rule directives' + operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m) operationDefinition (OperationDefinitionRule rule) operationDefinition' = pure $ rule operationDefinition' operationDefinition rule (SelectionSet selections _) = selectionSet rule selections -operationDefinition rule (OperationDefinition _ _ _ _ selections _) = - selectionSet rule selections +operationDefinition rule (OperationDefinition _ _ _ directives' selections _) = + selectionSet rule selections >< directives rule directives' fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m) fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' = pure $ rule fragmentDefinition' -fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ _ selections _) +fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _) | FragmentRule definitionRule _ <- rule = applyToChildren |> definitionRule fragmentDefinition' | otherwise = applyToChildren where applyToChildren = selectionSet rule selections + >< directives rule directives' selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m) selectionSet = foldMap . selection @@ -83,18 +157,36 @@ selection rule selection' InlineFragmentSelection inlineFragment' -> inlineFragment rule inlineFragment' FragmentSpreadSelection fragmentSpread' -> - pure $ fragmentSpread rule fragmentSpread' + fragmentSpread rule fragmentSpread' field :: Rule m -> Field -> Seq (RuleT m) -field (FieldRule rule) field' = pure $ rule field' -field rule (Field _ _ _ _ selections _) = selectionSet rule selections +field rule field'@(Field _ _ _ directives' selections _) + | FieldRule fieldRule <- rule = applyToChildren |> fieldRule field' + | ArgumentsRule fieldRule _ <- rule = applyToChildren |> fieldRule field' + | otherwise = applyToChildren + where + applyToChildren = selectionSet rule selections >< directives rule directives' inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m) -inlineFragment (FragmentRule _ rule) inlineFragment' = - pure $ rule inlineFragment' -inlineFragment rule (InlineFragment _ _ selections _) = - selectionSet rule selections +inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _) + | FragmentRule _ fragmentRule <- rule = + applyToChildren |> fragmentRule inlineFragment' + | otherwise = applyToChildren + where + applyToChildren = selectionSet rule selections + >< directives rule directives' -fragmentSpread :: Rule m -> FragmentSpread -> RuleT m -fragmentSpread (FragmentSpreadRule rule) fragmentSpread' = rule fragmentSpread' -fragmentSpread _ _ = lift mempty +fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m) +fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _) + | FragmentSpreadRule fragmentRule <- rule = + applyToChildren |> fragmentRule fragmentSpread' + | otherwise = applyToChildren + where + applyToChildren = directives rule directives' + +directives :: Traversable t => Rule m -> t Directive -> Seq (RuleT m) +directives = foldMap . fmap pure . directive + +directive :: Rule m -> Directive -> RuleT m +directive (ArgumentsRule _ rule) = rule +directive _ = lift . const mempty diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 2d9cf74..795e5ca 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -18,6 +18,7 @@ module Language.GraphQL.Validate.Rules , noUnusedFragmentsRule , singleFieldSubscriptionsRule , specifiedRules + , uniqueArgumentNamesRule , uniqueFragmentNamesRule , uniqueOperationNamesRule ) where @@ -31,9 +32,10 @@ import Data.Foldable (find) import qualified Data.HashMap.Strict as HashMap import Data.HashMap.Strict (HashMap) import qualified Data.HashSet as HashSet -import Data.List (sortBy) +import Data.List (groupBy, sortBy, sortOn) import Data.Ord (comparing) import Data.Sequence (Seq(..)) +import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.Document @@ -50,6 +52,8 @@ specifiedRules = , singleFieldSubscriptionsRule , loneAnonymousOperationRule , uniqueOperationNamesRule + -- Arguments. + , uniqueArgumentNamesRule -- Fragments. , uniqueFragmentNamesRule , fragmentSpreadTypeExistenceRule @@ -441,3 +445,29 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case Nothing -> pure accumulator Just (FragmentDefinition _ _ _ selections _) -> (accumulator <>) <$> collectFields selections + +-- | Fields and directives treat arguments as a mapping of argument name to +-- value. More than one argument with the same name in an argument set is +-- ambiguous and invalid. +uniqueArgumentNamesRule :: forall m. Rule m +uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule + where + fieldRule (Field _ _ arguments _ _ _) = filterDuplicates arguments + directiveRule (Directive _ arguments) = filterDuplicates arguments + filterDuplicates = lift + . Seq.fromList + . fmap makeError + . filter ((> 1) . length) + . groupBy equalByName + . sortOn getName + getName (Argument argumentName _ _) = argumentName + makeError arguments = Error + { message = makeMessage $ head arguments + , locations = (\(Argument _ _ location) -> location) <$> arguments + } + makeMessage argument = concat + [ "There can be only one argument named \"" + , Text.unpack $ getName argument + , "\"." + ] + equalByName lhs rhs = getName lhs == getName rhs diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 0cc39f7..d07d6e8 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -41,6 +41,7 @@ data Rule m | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m) | FragmentSpreadRule (FragmentSpread -> RuleT m) | FieldRule (Field -> RuleT m) + | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m) -- | Monad transformer used by the rules. type RuleT m = ReaderT (Validation m) Seq Error diff --git a/stack.yaml b/stack.yaml index 7fe786b..5911955 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.13 +resolver: lts-16.14 packages: - . diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index 53f63aa..dfc3a4d 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -413,3 +413,18 @@ spec = , locations = [AST.Location 7 15] } in validate queryString `shouldBe` Seq.fromList [error1, error2] + + it "rejects duplicate field arguments" $ do + let queryString = [r| + { + dog { + isHousetrained(atOtherHomes: true, atOtherHomes: true) + } + } + |] + expected = Error + { message = + "There can be only one argument named \"atOtherHomes\"." + , locations = [AST.Location 4 34, AST.Location 4 54] + } + in validate queryString `shouldBe` Seq.singleton expected