Validate repeatable directives
All checks were successful
Build / audit (push) Successful in 20s
Build / test (push) Successful in 6m7s
Build / doc (push) Successful in 5m5s

This commit is contained in:
Eugen Wissner 2024-10-13 19:40:12 +02:00
parent 1834e5c41e
commit ba07f8298b
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
9 changed files with 52 additions and 23 deletions

View File

@ -10,6 +10,8 @@ and this project adheres to
### Changed ### Changed
- `Schema.Directive` is extended to contain a boolean argument, representing - `Schema.Directive` is extended to contain a boolean argument, representing
repeatable directives. The parser can parse repeatable directive definitions. repeatable directives. The parser can parse repeatable directive definitions.
Validation allows repeatable directives.
- `AST.Document.Directive` is a record.
### Fixed ### Fixed
- `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF). - `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF).

View File

@ -1,6 +1,6 @@
{-# LANGUAGE Safe #-} {-# 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. -- This module describes locations in a document where directives can appear.
module Language.GraphQL.AST.DirectiveLocation module Language.GraphQL.AST.DirectiveLocation
( DirectiveLocation(..) ( DirectiveLocation(..)

View File

@ -380,7 +380,11 @@ instance Show NonNullType where
-- --
-- Directives begin with "@", can accept arguments, and can be applied to the -- Directives begin with "@", can accept arguments, and can be applied to the
-- most GraphQL elements, providing additional information. -- 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 -- * Type System

View File

@ -277,7 +277,7 @@ pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text
pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList pipeList Minified = (" " <>) . Lazy.Text.intercalate " | " . toList
pipeList (Pretty _) = Lazy.Text.concat pipeList (Pretty _) = Lazy.Text.concat
. fmap (("\n" <> indentSymbol <> "| ") <>) . fmap (("\n" <> indentSymbol <> "| ") <>)
. toList . toList
enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text
enumValueDefinition (Pretty _) enumValue = enumValueDefinition (Pretty _) enumValue =

View File

@ -147,7 +147,7 @@ coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
| member enumValue type' = Just $ Type.Enum enumValue | member enumValue type' = Just $ Type.Enum enumValue
where where
member value (Type.EnumType _ _ members) = HashMap.member value members 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' let (In.InputObjectType _ _ inputFields) = type'
in Type.Object in Type.Object
<$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields

View File

@ -283,7 +283,7 @@ operationDefinition rule context operation
schema' = Validation.schema context schema' = Validation.schema context
queryRoot = Just $ Out.NamedObjectType $ Schema.query schema' queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
types' = Schema.types schema' types' = Schema.types schema'
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
typeToOut (Schema.ObjectType objectType) = typeToOut (Schema.ObjectType objectType) =
Just $ Out.NamedObjectType objectType Just $ Out.NamedObjectType objectType
@ -403,7 +403,7 @@ arguments :: forall m
-> Seq (Validation.RuleT m) -> Seq (Validation.RuleT m)
arguments rule argumentTypes = foldMap forEach . Seq.fromList arguments rule argumentTypes = foldMap forEach . Seq.fromList
where where
forEach argument'@(Full.Argument argumentName _ _) = forEach argument'@(Full.Argument argumentName _ _) =
let argumentType = HashMap.lookup argumentName argumentTypes let argumentType = HashMap.lookup argumentName argumentTypes
in argument rule argumentType argument' in argument rule argumentType argument'

View File

@ -533,11 +533,20 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
-- used, the expected metadata or behavior becomes ambiguous, therefore only one -- used, the expected metadata or behavior becomes ambiguous, therefore only one
-- of each directive is allowed per location. -- of each directive is allowed per location.
uniqueDirectiveNamesRule :: forall m. Rule m uniqueDirectiveNamesRule :: forall m. Rule m
uniqueDirectiveNamesRule = DirectivesRule uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
$ const $ lift . filterDuplicates extract "directive" 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 where
extract (Full.Directive directiveName _ location') = foldNonRepeatable hashSet directiveName' (Schema.Directive _ _ False _) =
(directiveName, location') HashSet.insert directiveName' hashSet
foldNonRepeatable hashSet _ _ = hashSet
extract (Full.Directive directiveName' _ location') =
(directiveName', location')
filterDuplicates :: forall a filterDuplicates :: forall a
. (a -> (Text, Full.Location)) . (a -> (Text, Full.Location))
@ -852,18 +861,18 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
knownDirectiveNamesRule :: Rule m knownDirectiveNamesRule :: Rule m
knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
definitions' <- asks $ Schema.directives . schema definitions' <- asks $ Schema.directives . schema
let directiveSet = HashSet.fromList $ fmap directiveName directives' let directiveSet = HashSet.fromList $ fmap (getField @"name") directives'
let definitionSet = HashSet.fromList $ HashMap.keys definitions' definitionSet = HashSet.fromList $ HashMap.keys definitions'
let difference = HashSet.difference directiveSet definitionSet difference = HashSet.difference directiveSet definitionSet
let undefined' = filter (definitionFilter difference) directives' undefined' = filter (definitionFilter difference) directives'
lift $ Seq.fromList $ makeError <$> undefined' lift $ Seq.fromList $ makeError <$> undefined'
where where
definitionFilter :: HashSet Full.Name -> Full.Directive -> Bool
definitionFilter difference = flip HashSet.member difference definitionFilter difference = flip HashSet.member difference
. directiveName . getField @"name"
directiveName (Full.Directive directiveName' _ _) = directiveName' makeError Full.Directive{..} = Error
makeError (Full.Directive directiveName' _ location') = Error { message = errorMessage name
{ message = errorMessage directiveName' , locations = [location]
, locations = [location']
} }
errorMessage directiveName' = concat errorMessage directiveName' = concat
[ "Unknown directive \"@" [ "Unknown directive \"@"

View File

@ -82,8 +82,8 @@ spec = describe "Parser" $ do
it "accepts any arguments" $ mapSize (const 10) $ property $ \xs -> it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
let let
query' :: Text query' :: Text
arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue)) arguments' = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
query' = "query(" <> Text.intercalate ", " arguments <> ")" in query' = "query(" <> Text.intercalate ", " arguments' <> ")" in
parse document "" `shouldSucceedOn` ("{ " <> query' <> " }") parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
it "parses minimal schema definition" $ it "parses minimal schema definition" $

View File

@ -15,6 +15,8 @@ import Data.Text (Text)
import qualified Language.GraphQL.AST as AST import qualified Language.GraphQL.AST as AST
import Language.GraphQL.TH import Language.GraphQL.TH
import Language.GraphQL.Type 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.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Validate import Language.GraphQL.Validate
@ -22,7 +24,9 @@ import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain)
import Text.Megaparsec (parse, errorBundlePretty) import Text.Megaparsec (parse, errorBundlePretty)
petSchema :: Schema IO 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 IO
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
@ -494,7 +498,7 @@ spec =
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
context "uniqueDirectiveNamesRule" $ context "uniqueDirectiveNamesRule" $ do
it "rejects more than one directive per location" $ it "rejects more than one directive per location" $
let queryString = [gql| let queryString = [gql|
query ($foo: Boolean = true, $bar: Boolean = false) { query ($foo: Boolean = true, $bar: Boolean = false) {
@ -510,6 +514,16 @@ spec =
} }
in validate queryString `shouldBe` [expected] in validate queryString `shouldBe` [expected]
it "allows repeating repeatable directives" $
let queryString = [gql|
query {
dog @repeat @repeat {
name
}
}
|]
in validate queryString `shouldBe` []
context "uniqueVariableNamesRule" $ context "uniqueVariableNamesRule" $
it "rejects duplicate variables" $ it "rejects duplicate variables" $
let queryString = [gql| let queryString = [gql|