summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md2
-rw-r--r--src/Language/GraphQL/AST/DirectiveLocation.hs2
-rw-r--r--src/Language/GraphQL/AST/Document.hs6
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs2
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs2
-rw-r--r--src/Language/GraphQL/Validate.hs4
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs35
-rw-r--r--tests/Language/GraphQL/AST/ParserSpec.hs4
-rw-r--r--tests/Language/GraphQL/Validate/RulesSpec.hs18
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|
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 19:21:36 +0000