Validate repeatable directives
This commit is contained in:
parent
1834e5c41e
commit
ba07f8298b
@ -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).
|
||||||
|
@ -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(..)
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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 =
|
||||||
|
@ -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
|
||||||
|
@ -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'
|
||||||
|
|
||||||
|
@ -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 \"@"
|
||||||
|
@ -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" $
|
||||||
|
@ -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|
|
||||||
|
Loading…
Reference in New Issue
Block a user