Validate arguments have unique names

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`.

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

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

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

stack.yaml

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

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