Validate input fields have unique names

10 files changed, 84 insertions, 30 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index c808915..2494efa 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -46,6 +46,7 @@ and this project adheres to
   - `noUndefinedVariablesRule`
   - `noUndefinedVariablesRule`
   - `noUnusedVariablesRule`
+  - `uniqueInputFieldNamesRule`
 - `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.
diff --git a/README.md b/README.md
index ee5bab4..455ab50 100644
--- a/README.md
+++ b/README.md
@@ -1,6 +1,7 @@
 # GraphQL implementation in Haskell
 
 [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
+[![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/graphql/badge)](https://matrix.hackage.haskell.org/package/graphql)
 [![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22)
 [![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
 [![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org)
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index 1875e49..c870580 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -236,7 +236,7 @@ data ConstValue
 -- | Key-value pair.
 --
 -- A list of 'ObjectField's represents a GraphQL object type.
-data ObjectField a = ObjectField Name a
+data ObjectField a = ObjectField Name a Location
     deriving (Eq, Show)
 
 -- ** Variables
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index 176a897..011527a 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -220,8 +220,8 @@ fromConstValue (ConstEnum x) = Enum x
 fromConstValue (ConstList x) = List $ fromConstValue <$> x
 fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
   where
-    fromConstObjectField (ObjectField key value') =
-        ObjectField key $ fromConstValue value'
+    fromConstObjectField (ObjectField key value' location) =
+        ObjectField key (fromConstValue value') location
 
 booleanValue :: Bool -> Lazy.Text
 booleanValue True  = "true"
@@ -290,7 +290,7 @@ objectValue formatter = intercalate $ objectField formatter
         . fmap f
 
 objectField :: Formatter -> ObjectField Value -> Lazy.Text
-objectField formatter (ObjectField name value') =
+objectField formatter (ObjectField name value' _) =
     Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
 
 -- | Converts a 'Type' a type into a string.
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 29eee79..eb82f38 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -487,11 +487,12 @@ nullValue :: Parser Text
 nullValue = symbol "null" <?> "NullValue"
 
 objectField :: Parser a -> Parser (ObjectField a)
-objectField valueParser = ObjectField
-    <$> name
-    <* colon
-    <*> valueParser
-    <?> "ObjectField"
+objectField valueParser = label "ObjectField" $ do
+    location <- getLocation
+    fieldName <- name
+    colon
+    fieldValue <- valueParser
+    pure $ ObjectField fieldName fieldValue location
 
 variableDefinitions :: Parser [VariableDefinition]
 variableDefinitions = listOptIn parens variableDefinition
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 0c4d39c..cf90dbf 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -177,7 +177,7 @@ constValue (Full.ConstList l) = Type.List $ constValue <$> l
 constValue (Full.ConstObject o) =
     Type.Object $ HashMap.fromList $ constObjectField <$> o
   where
-    constObjectField (Full.ObjectField key value') = (key, constValue value')
+    constObjectField (Full.ObjectField key value' _) = (key, constValue value')
 
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
@@ -383,7 +383,7 @@ value (Full.List list) = Type.List <$> traverse value list
 value (Full.Object object) =
     Type.Object . HashMap.fromList <$> traverse objectField object
   where
-    objectField (Full.ObjectField name value') = (name,) <$> value value'
+    objectField (Full.ObjectField name value' _) = (name,) <$> value value'
 
 input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
 input (Full.Variable name) =
@@ -399,7 +399,7 @@ input (Full.Object object) = do
     objectFields <- foldM objectField HashMap.empty object
     pure $ pure $ Object objectFields
   where
-    objectField resultMap (Full.ObjectField name value') =
+    objectField resultMap (Full.ObjectField name value' _) =
         inputField resultMap name value'
 
 inputField :: forall m
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index 702935b..be9ba33 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -92,7 +92,7 @@ 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
+    DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments'
 
 typeDefinition :: Rule m -> TypeDefinition -> Seq (RuleT m)
 typeDefinition rule = \case
@@ -113,8 +113,8 @@ 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
+fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') =
+    directives rule directives' >< argumentsDefinition rule arguments'
 
 argumentsDefinition :: Rule m -> ArgumentsDefinition -> Seq (RuleT m)
 argumentsDefinition rule (ArgumentsDefinition definitions) =
@@ -129,12 +129,18 @@ operationDefinition rule operation
     | OperationDefinitionRule operationRule <- rule =
         pure $ operationRule operation
     | VariablesRule variablesRule <- rule
-    , OperationDefinition _ _ variables _ _ _ <- operation =
-        pure $ variablesRule variables
+    , OperationDefinition _ _ variables _ _ _ <- operation
+        = Seq.fromList (variableDefinition rule <$> variables)
+        |> variablesRule variables
     | SelectionSet selections _ <- operation = selectionSet rule selections
     | OperationDefinition _ _ _ directives' selections _  <- operation =
         selectionSet rule selections >< directives rule directives'
 
+variableDefinition :: Rule m -> VariableDefinition -> RuleT m
+variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
+    maybe (lift mempty) rule value
+variableDefinition _ _ = lift mempty
+
 fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m)
 fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' =
     pure $ rule fragmentDefinition'
@@ -164,12 +170,21 @@ selection rule selection'
                 fragmentSpread rule fragmentSpread'
 
 field :: Rule m -> Field -> Seq (RuleT m)
-field rule field'@(Field _ _ _ directives' selections _)
+field rule field'@(Field _ _ arguments' directives' selections _)
     | FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
     | ArgumentsRule fieldRule _  <- rule = applyToChildren |> fieldRule field'
     | otherwise = applyToChildren
   where
-    applyToChildren = selectionSet rule selections >< directives rule directives'
+    applyToChildren = selectionSet rule selections
+        >< directives rule directives'
+        >< arguments rule arguments'
+
+arguments :: Rule m -> [Argument] -> Seq (RuleT m)
+arguments = (.) Seq.fromList . fmap . argument
+
+argument :: Rule m -> Argument -> RuleT m
+argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
+argument _ _ = lift mempty
 
 inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m)
 inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _)
@@ -195,8 +210,9 @@ directives rule directives'
     | otherwise = applyToChildren
   where
     directiveList = toList directives'
-    applyToChildren = Seq.fromList $ fmap (directive rule) directiveList
+    applyToChildren = foldMap (directive rule) directiveList
 
-directive :: Rule m -> Directive -> RuleT m
-directive (ArgumentsRule _ rule) = rule
-directive _ = lift . const mempty
+directive :: Rule m -> Directive -> Seq (RuleT m)
+directive (ArgumentsRule _ argumentsRule) directive' =
+    pure $ argumentsRule directive'
+directive rule (Directive _ arguments' _) = arguments rule arguments'
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index c123017..1d34162 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -23,6 +23,7 @@ module Language.GraphQL.Validate.Rules
     , uniqueArgumentNamesRule
     , uniqueDirectiveNamesRule
     , uniqueFragmentNamesRule
+    , uniqueInputFieldNamesRule
     , uniqueOperationNamesRule
     , uniqueVariableNamesRule
     , variablesAreInputTypesRule
@@ -71,6 +72,8 @@ specifiedRules =
     , noUnusedFragmentsRule
     , fragmentSpreadTargetDefinedRule
     , noFragmentCyclesRule
+    -- Values
+    , uniqueInputFieldNamesRule
     -- Directives.
     , uniqueDirectiveNamesRule
     -- Variables.
@@ -485,9 +488,9 @@ uniqueArgumentNamesRule :: forall m. Rule m
 uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
   where
     fieldRule (Field _ _ arguments _ _ _) =
-        filterDuplicates extract "argument" arguments
+        lift $ filterDuplicates extract "argument" arguments
     directiveRule (Directive _ arguments _) =
-        filterDuplicates extract "argument" arguments
+        lift $ filterDuplicates extract "argument" arguments
     extract (Argument argumentName _ location) = (argumentName, location)
 
 -- | Directives are used to describe some metadata or behavioral change on the
@@ -496,13 +499,12 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 -- of each directive is allowed per location.
 uniqueDirectiveNamesRule :: forall m. Rule m
 uniqueDirectiveNamesRule = DirectivesRule
-    $ filterDuplicates extract "directive"
+    $ lift . filterDuplicates extract "directive"
   where
     extract (Directive directiveName _ location) = (directiveName, location)
 
-filterDuplicates :: (a -> (Text, Location)) -> String -> [a] -> RuleT m
-filterDuplicates extract nodeType = lift
-    . Seq.fromList
+filterDuplicates :: (a -> (Text, Location)) -> String -> [a] -> Seq Error
+filterDuplicates extract nodeType = Seq.fromList
     . fmap makeError
     . filter ((> 1) . length)
     . groupBy equalByName
@@ -527,7 +529,7 @@ filterDuplicates extract nodeType = lift
 -- variable is the same.
 uniqueVariableNamesRule :: forall m. Rule m
 uniqueVariableNamesRule = VariablesRule
-    $ filterDuplicates extract "variable"
+    $ lift . filterDuplicates extract "variable"
   where
     extract (VariableDefinition variableName _ _ location) =
         (variableName, location)
@@ -651,3 +653,22 @@ noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage
         , Text.unpack operationName
         , "\"."
         ]
+
+-- | Input objects must not contain more than one field of the same name,
+-- otherwise an ambiguity would exist which includes an ignored portion of
+-- syntax.
+uniqueInputFieldNamesRule :: forall m. Rule m
+uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
+  where
+    go (Object fields) = foldMap (objectField go) fields
+        <> filterFieldDuplicates fields
+    go (List values) = foldMap go values
+    go _ = mempty
+    objectField go' (ObjectField _ fieldValue _) = go' fieldValue
+    filterFieldDuplicates fields =
+        filterDuplicates getFieldName "input field" fields
+    getFieldName (ObjectField fieldName _ location) = (fieldName, location)
+    constGo (ConstObject fields) = foldMap (objectField constGo) fields
+        <> filterFieldDuplicates fields
+    constGo (ConstList values) = foldMap constGo values
+    constGo _ = mempty
diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs
index 385c4ae..a56d930 100644
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@@ -44,6 +44,7 @@ data Rule m
     | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
     | DirectivesRule ([Directive] -> RuleT m)
     | VariablesRule ([VariableDefinition] -> RuleT m)
+    | ValueRule (Value -> RuleT m) (ConstValue -> RuleT m)
 
 -- | Monad transformer used by the rules.
 type RuleT m = ReaderT (Validation m) Seq Error
diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index b93e2a6..75e78d4 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -508,3 +508,16 @@ spec =
                     , locations = [AST.Location 2 36]
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects duplicate fields in input objects" $
+            let queryString = [r|
+              {
+                findDog(complex: { name: "Fido", name: "Jack" })
+              }
+            |]
+                expected = Error
+                    { message =
+                        "There can be only one input field named \"name\"."
+                    , locations = [AST.Location 3 36, AST.Location 3 50]
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected