Validate directives are unique per location

This commit is contained in:
Eugen Wissner 2020-09-18 07:32:58 +02:00
parent 497b93c41b
commit 9a08aa5de7
12 changed files with 79 additions and 34 deletions

View File

@ -10,8 +10,9 @@ and this project adheres to
### Changed ### Changed
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread` - `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
and `InlineFragment`. Thus validation rules can be defined more concise. and `InlineFragment`. Thus validation rules can be defined more concise.
- `AST.Document.Argument` contains the argument location. - `AST.Document`: `Argument` and `Directive` contain token location.
- `AST.Lexer.colon` ignores the result (it is always a colon). - `AST.Lexer.colon` and `AST.Lexer.at` ignore the result (it is always the
- same).
- `Validate.Validation`: `Validation.rules` was removed. `Validation.rules` - `Validate.Validation`: `Validation.rules` was removed. `Validation.rules`
contained the list of rules, but the executed rules shouldn't know about other contained the list of rules, but the executed rules shouldn't know about other
rules. `rules` was a part of the `Validation` context to pass it easier rules. `rules` was a part of the `Validation` context to pass it easier
@ -24,7 +25,7 @@ and this project adheres to
### Added ### Added
- `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule`, - `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule`,
`FragmentSpreadRule`, `ArgumentsRule` constructors. `FragmentSpreadRule`, `ArgumentsRule`, `DirectivesRule` constructors.
- `Validate.Rules`: - `Validate.Rules`:
- `fragmentsOnCompositeTypesRule` - `fragmentsOnCompositeTypesRule`
- `fragmentSpreadTargetDefinedRule` - `fragmentSpreadTargetDefinedRule`
@ -32,6 +33,7 @@ and this project adheres to
- `noUnusedFragmentsRule` - `noUnusedFragmentsRule`
- `noFragmentCyclesRule` - `noFragmentCyclesRule`
- `uniqueArgumentNamesRule` - `uniqueArgumentNamesRule`
- `uniqueDirectiveNamesRule`
- `AST.Document.Field`. - `AST.Document.Field`.
- `AST.Document.FragmentSpread`. - `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`. - `AST.Document.InlineFragment`.

View File

@ -280,7 +280,7 @@ data NonNullType
-- --
-- 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] deriving (Eq, Show) data Directive = Directive Name [Argument] Location deriving (Eq, Show)
-- * Type System -- * Type System

View File

@ -191,7 +191,7 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
-- | Converts a 'Directive' into a string. -- | Converts a 'Directive' into a string.
directive :: Formatter -> Directive -> Lazy.Text directive :: Formatter -> Directive -> Lazy.Text
directive formatter (Directive name args) directive formatter (Directive name args _)
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
directives :: Formatter -> [Directive] -> Lazy.Text directives :: Formatter -> [Directive] -> Lazy.Text

View File

@ -92,8 +92,8 @@ dollar :: Parser T.Text
dollar = symbol "$" dollar = symbol "$"
-- | Parser for "@". -- | Parser for "@".
at :: Parser Text at :: Parser ()
at = symbol "@" at = symbol "@" >> pure ()
-- | Parser for "&". -- | Parser for "&".
amp :: Parser T.Text amp :: Parser T.Text

View File

@ -520,11 +520,12 @@ directives :: Parser [Directive]
directives = many directive <?> "Directives" directives = many directive <?> "Directives"
directive :: Parser Directive directive :: Parser Directive
directive = Directive directive = label "Directive" $ do
<$ at location <- getLocation
<*> name at
<*> arguments directiveName <- name
<?> "Directive" directiveArguments <- arguments
pure $ Directive directiveName directiveArguments location
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
listOptIn surround = option [] . surround . some listOptIn surround = option [] . surround . some

View File

@ -360,7 +360,7 @@ appendSelection = foldM go mempty
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive] directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
directives = traverse directive directives = traverse directive
where where
directive (Full.Directive directiveName directiveArguments) directive (Full.Directive directiveName directiveArguments _)
= Definition.Directive directiveName . Type.Arguments = Definition.Directive directiveName . Type.Arguments
<$> foldM go HashMap.empty directiveArguments <$> foldM go HashMap.empty directiveArguments
go arguments (Full.Argument name value' _) = do go arguments (Full.Argument name value' _) = do

View File

@ -15,6 +15,7 @@ module Language.GraphQL.Validate
import Control.Monad (join) import Control.Monad (join)
import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (toList)
import Data.Sequence (Seq(..), (><), (|>)) import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
@ -185,7 +186,13 @@ fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _)
applyToChildren = directives rule directives' applyToChildren = directives rule directives'
directives :: Traversable t => Rule m -> t Directive -> Seq (RuleT m) directives :: Traversable t => Rule m -> t Directive -> Seq (RuleT m)
directives = foldMap . fmap pure . directive directives rule directives'
| DirectivesRule directivesRule <- rule =
applyToChildren |> directivesRule directiveList
| otherwise = applyToChildren
where
directiveList = toList directives'
applyToChildren = Seq.fromList $ fmap (directive rule) directiveList
directive :: Rule m -> Directive -> RuleT m directive :: Rule m -> Directive -> RuleT m
directive (ArgumentsRule _ rule) = rule directive (ArgumentsRule _ rule) = rule

View File

@ -19,6 +19,7 @@ module Language.GraphQL.Validate.Rules
, singleFieldSubscriptionsRule , singleFieldSubscriptionsRule
, specifiedRules , specifiedRules
, uniqueArgumentNamesRule , uniqueArgumentNamesRule
, uniqueDirectiveNamesRule
, uniqueFragmentNamesRule , uniqueFragmentNamesRule
, uniqueOperationNamesRule , uniqueOperationNamesRule
) where ) where
@ -61,6 +62,8 @@ specifiedRules =
, noUnusedFragmentsRule , noUnusedFragmentsRule
, fragmentSpreadTargetDefinedRule , fragmentSpreadTargetDefinedRule
, noFragmentCyclesRule , noFragmentCyclesRule
-- Directives.
, uniqueDirectiveNamesRule
] ]
-- | Definition must be OperationDefinition or FragmentDefinition. -- | Definition must be OperationDefinition or FragmentDefinition.
@ -125,8 +128,8 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
collectFromFragment typeCondition selections accumulator collectFromFragment typeCondition selections accumulator
| otherwise = HashSet.union accumulator | otherwise = HashSet.union accumulator
<$> collectFields selections <$> collectFields selections
skip (Directive "skip" [Argument "if" (Boolean True) _]) = True skip (Directive "skip" [Argument "if" (Boolean True) _] _) = True
skip (Directive "include" [Argument "if" (Boolean False) _]) = True skip (Directive "include" [Argument "if" (Boolean False) _] _) = True
skip _ = False skip _ = False
findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
| DefinitionFragment fragmentDefinition <- executableDefinition = | DefinitionFragment fragmentDefinition <- executableDefinition =
@ -452,22 +455,40 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
uniqueArgumentNamesRule :: forall m. Rule m uniqueArgumentNamesRule :: forall m. Rule m
uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
where where
fieldRule (Field _ _ arguments _ _ _) = filterDuplicates arguments fieldRule (Field _ _ arguments _ _ _) =
directiveRule (Directive _ arguments) = filterDuplicates arguments filterDuplicates extract "argument" arguments
filterDuplicates = lift directiveRule (Directive _ arguments _) =
filterDuplicates extract "argument" arguments
extract (Argument argumentName _ location) = (argumentName, location)
-- | Directives are used to describe some metadata or behavioral change on the
-- definition they apply to. When more than one directive of the same name is
-- 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
$ filterDuplicates extract "directive"
where
extract (Directive directiveName _ location) = (directiveName, location)
filterDuplicates :: (a -> (Text, Location)) -> String -> [a] -> RuleT m
filterDuplicates extract nodeType = lift
. Seq.fromList . Seq.fromList
. fmap makeError . fmap makeError
. filter ((> 1) . length) . filter ((> 1) . length)
. groupBy equalByName . groupBy equalByName
. sortOn getName . sortOn getName
getName (Argument argumentName _ _) = argumentName where
makeError arguments = Error getName = fst . extract
{ message = makeMessage $ head arguments equalByName lhs rhs = getName lhs == getName rhs
, locations = (\(Argument _ _ location) -> location) <$> arguments makeError directives = Error
{ message = makeMessage $ head directives
, locations = snd . extract <$> directives
} }
makeMessage argument = concat makeMessage directive = concat
[ "There can be only one argument named \"" [ "There can be only one "
, Text.unpack $ getName argument , nodeType
, " named \""
, Text.unpack $ fst $ extract directive
, "\"." , "\"."
] ]
equalByName lhs rhs = getName lhs == getName rhs

View File

@ -42,6 +42,7 @@ data Rule m
| FragmentSpreadRule (FragmentSpread -> RuleT m) | FragmentSpreadRule (FragmentSpread -> RuleT m)
| FieldRule (Field -> RuleT m) | FieldRule (Field -> RuleT m)
| ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m) | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
| DirectivesRule ([Directive] -> RuleT m)
-- | Monad transformer used by the rules. -- | Monad transformer used by the rules.
type RuleT m = ReaderT (Validation m) Seq Error type RuleT m = ReaderT (Validation m) Seq Error

View File

@ -77,7 +77,7 @@ spec = describe "Lexer" $ do
parse spread "" "..." `shouldParse` "..." parse spread "" "..." `shouldParse` "..."
parse colon "" `shouldSucceedOn` ":" parse colon "" `shouldSucceedOn` ":"
parse equals "" "=" `shouldParse` "=" parse equals "" "=" `shouldParse` "="
parse at "" "@" `shouldParse` "@" parse at "" `shouldSucceedOn` "@"
runBetween brackets `shouldSucceedOn` "[]" runBetween brackets `shouldSucceedOn` "[]"
runBetween braces `shouldSucceedOn` "{}" runBetween braces `shouldSucceedOn` "{}"
parse pipe "" "|" `shouldParse` "|" parse pipe "" "|" `shouldParse` "|"

View File

@ -128,7 +128,7 @@ spec = describe "Parser" $ do
parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|] parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
it "parses schema extension with an operation type and directive" $ it "parses schema extension with an operation type and directive" $
let newDirective = Directive "newDirective" [] let newDirective = Directive "newDirective" [] $ Location 1 15
schemaExtension = SchemaExtension schemaExtension = SchemaExtension
$ SchemaOperationExtension [newDirective] $ SchemaOperationExtension [newDirective]
$ OperationTypeDefinition Query "Query" :| [] $ OperationTypeDefinition Query "Query" :| []

View File

@ -428,3 +428,16 @@ spec =
, locations = [AST.Location 4 34, AST.Location 4 54] , locations = [AST.Location 4 34, AST.Location 4 54]
} }
in validate queryString `shouldBe` Seq.singleton expected in validate queryString `shouldBe` Seq.singleton expected
it "rejects more than one directive per location" $ do
let queryString = [r|
query ($foo: Boolean = true, $bar: Boolean = false) {
field @skip(if: $foo) @skip(if: $bar)
}
|]
expected = Error
{ message =
"There can be only one directive named \"skip\"."
, locations = [AST.Location 3 23, AST.Location 3 39]
}
in validate queryString `shouldBe` Seq.singleton expected