From ba07f8298bda9b18ea0408988cc2cd2239ce9726 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 13 Oct 2024 19:40:12 +0200 Subject: [PATCH] Validate repeatable directives --- CHANGELOG.md | 2 ++ src/Language/GraphQL/AST/DirectiveLocation.hs | 2 +- src/Language/GraphQL/AST/Document.hs | 6 +++- src/Language/GraphQL/AST/Encoder.hs | 2 +- src/Language/GraphQL/Execute/Coerce.hs | 2 +- src/Language/GraphQL/Validate.hs | 4 +-- src/Language/GraphQL/Validate/Rules.hs | 35 ++++++++++++------- tests/Language/GraphQL/AST/ParserSpec.hs | 4 +-- tests/Language/GraphQL/Validate/RulesSpec.hs | 18 ++++++++-- 9 files changed, 52 insertions(+), 23 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c492d22..9095874 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,8 @@ and this project adheres to ### Changed - `Schema.Directive` is extended to contain a boolean argument, representing repeatable directives. The parser can parse repeatable directive definitions. + Validation allows repeatable directives. +- `AST.Document.Directive` is a record. ### Fixed - `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF). diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs index d109666..600f931 100644 --- a/src/Language/GraphQL/AST/DirectiveLocation.hs +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Safe #-} --- | Various parts of a GraphQL document can be annotated with directives. +-- | Various parts of a GraphQL document can be annotated with directives. -- This module describes locations in a document where directives can appear. module Language.GraphQL.AST.DirectiveLocation ( DirectiveLocation(..) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index f695495..101cf78 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -380,7 +380,11 @@ instance Show NonNullType where -- -- Directives begin with "@", can accept arguments, and can be applied to the -- most GraphQL elements, providing additional information. -data Directive = Directive Name [Argument] Location deriving (Eq, Show) +data Directive = Directive + { name :: Name + , arguments :: [Argument] + , location :: Location + } deriving (Eq, Show) -- * Type System diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index afa30de..a1076e4 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -277,7 +277,7 @@ pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList pipeList (Pretty _) = Lazy.Text.concat . fmap (("\n" <> indentSymbol <> "| ") <>) - . toList + . toList enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text enumValueDefinition (Pretty _) enumValue = diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index 54fc1c1..f67d74b 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -147,7 +147,7 @@ coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue) | member enumValue type' = Just $ Type.Enum enumValue where member value (Type.EnumType _ _ members) = HashMap.member value members -coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = let (In.InputObjectType _ _ inputFields) = type' in Type.Object <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index ba00594..5feb85a 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -283,7 +283,7 @@ operationDefinition rule context operation schema' = Validation.schema context queryRoot = Just $ Out.NamedObjectType $ Schema.query schema' types' = Schema.types schema' - + typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) typeToOut (Schema.ObjectType objectType) = Just $ Out.NamedObjectType objectType @@ -403,7 +403,7 @@ arguments :: forall m -> Seq (Validation.RuleT m) arguments rule argumentTypes = foldMap forEach . Seq.fromList where - forEach argument'@(Full.Argument argumentName _ _) = + forEach argument'@(Full.Argument argumentName _ _) = let argumentType = HashMap.lookup argumentName argumentTypes in argument rule argumentType argument' diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index c68cd61..3fef94d 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -533,11 +533,20 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule -- used, the expected metadata or behavior becomes ambiguous, therefore only one -- of each directive is allowed per location. uniqueDirectiveNamesRule :: forall m. Rule m -uniqueDirectiveNamesRule = DirectivesRule - $ const $ lift . filterDuplicates extract "directive" +uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do + definitions' <- asks $ Schema.directives . schema + let filterNonRepeatable = flip HashSet.member nonRepeatableSet + . getField @"name" + nonRepeatableSet = + HashMap.foldlWithKey foldNonRepeatable HashSet.empty definitions' + lift $ filterDuplicates extract "directive" + $ filter filterNonRepeatable directives' where - extract (Full.Directive directiveName _ location') = - (directiveName, location') + foldNonRepeatable hashSet directiveName' (Schema.Directive _ _ False _) = + HashSet.insert directiveName' hashSet + foldNonRepeatable hashSet _ _ = hashSet + extract (Full.Directive directiveName' _ location') = + (directiveName', location') filterDuplicates :: forall a . (a -> (Text, Full.Location)) @@ -852,18 +861,18 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule knownDirectiveNamesRule :: Rule m knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do definitions' <- asks $ Schema.directives . schema - let directiveSet = HashSet.fromList $ fmap directiveName directives' - let definitionSet = HashSet.fromList $ HashMap.keys definitions' - let difference = HashSet.difference directiveSet definitionSet - let undefined' = filter (definitionFilter difference) directives' + let directiveSet = HashSet.fromList $ fmap (getField @"name") directives' + definitionSet = HashSet.fromList $ HashMap.keys definitions' + difference = HashSet.difference directiveSet definitionSet + undefined' = filter (definitionFilter difference) directives' lift $ Seq.fromList $ makeError <$> undefined' where + definitionFilter :: HashSet Full.Name -> Full.Directive -> Bool definitionFilter difference = flip HashSet.member difference - . directiveName - directiveName (Full.Directive directiveName' _ _) = directiveName' - makeError (Full.Directive directiveName' _ location') = Error - { message = errorMessage directiveName' - , locations = [location'] + . getField @"name" + makeError Full.Directive{..} = Error + { message = errorMessage name + , locations = [location] } errorMessage directiveName' = concat [ "Unknown directive \"@" diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index 0e7c28a..455c99a 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -82,8 +82,8 @@ spec = describe "Parser" $ do it "accepts any arguments" $ mapSize (const 10) $ property $ \xs -> let query' :: Text - arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) - query' = "query(" <> Text.intercalate ", " arguments <> ")" in + arguments' = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) + query' = "query(" <> Text.intercalate ", " arguments' <> ")" in parse document "" `shouldSucceedOn` ("{ " <> query' <> " }") it "parses minimal schema definition" $ diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs index 7bdbd86..07ab2f6 100644 --- a/tests/Language/GraphQL/Validate/RulesSpec.hs +++ b/tests/Language/GraphQL/Validate/RulesSpec.hs @@ -15,6 +15,8 @@ import Data.Text (Text) import qualified Language.GraphQL.AST as AST import Language.GraphQL.TH import Language.GraphQL.Type +import qualified Language.GraphQL.Type.Schema as Schema +import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Validate @@ -22,7 +24,9 @@ import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain) import Text.Megaparsec (parse, errorBundlePretty) petSchema :: Schema IO -petSchema = schema queryType Nothing (Just subscriptionType) mempty +petSchema = schema queryType Nothing (Just subscriptionType) + $ HashMap.singleton "repeat" + $ Schema.Directive Nothing mempty True [DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field] queryType :: ObjectType IO queryType = ObjectType "Query" Nothing [] $ HashMap.fromList @@ -494,7 +498,7 @@ spec = } in validate queryString `shouldBe` [expected] - context "uniqueDirectiveNamesRule" $ + context "uniqueDirectiveNamesRule" $ do it "rejects more than one directive per location" $ let queryString = [gql| query ($foo: Boolean = true, $bar: Boolean = false) { @@ -510,6 +514,16 @@ spec = } in validate queryString `shouldBe` [expected] + it "allows repeating repeatable directives" $ + let queryString = [gql| + query { + dog @repeat @repeat { + name + } + } + |] + in validate queryString `shouldBe` [] + context "uniqueVariableNamesRule" $ it "rejects duplicate variables" $ let queryString = [gql|