From 9bfa2aa7e8a72c9cc08743152a96d18312625712 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 24 Sep 2020 05:47:31 +0200 Subject: [PATCH] Validate input fields have unique names --- CHANGELOG.md | 1 + README.md | 1 + src/Language/GraphQL/AST/Document.hs | 2 +- src/Language/GraphQL/AST/Encoder.hs | 6 ++-- src/Language/GraphQL/AST/Parser.hs | 11 +++--- src/Language/GraphQL/Execute/Transform.hs | 6 ++-- src/Language/GraphQL/Validate.hs | 38 +++++++++++++++------ src/Language/GraphQL/Validate/Rules.hs | 35 +++++++++++++++---- src/Language/GraphQL/Validate/Validation.hs | 1 + tests/Language/GraphQL/ValidateSpec.hs | 13 +++++++ 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