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
- `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`
and `InlineFragment`. Thus validation rules can be defined more concise.
- `AST.Document.Argument` contains the argument location.
- `AST.Lexer.colon` ignores the result (it is always a colon).
- `AST.Document`: `Argument` and `Directive` contain token location.
- `AST.Lexer.colon` and `AST.Lexer.at` ignore the result (it is always the
- same).
- `Validate.Validation`: `Validation.rules` was removed. `Validation.rules`
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
@ -24,7 +25,7 @@ and this project adheres to
### Added
- `Validate.Validation.Rule`: `SelectionRule`, `FieldRule`, `FragmentRule`,
`FragmentSpreadRule`, `ArgumentsRule` constructors.
`FragmentSpreadRule`, `ArgumentsRule`, `DirectivesRule` constructors.
- `Validate.Rules`:
- `fragmentsOnCompositeTypesRule`
- `fragmentSpreadTargetDefinedRule`
@ -32,6 +33,7 @@ and this project adheres to
- `noUnusedFragmentsRule`
- `noFragmentCyclesRule`
- `uniqueArgumentNamesRule`
- `uniqueDirectiveNamesRule`
- `AST.Document.Field`.
- `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`.

View File

@ -280,7 +280,7 @@ data NonNullType
--
-- Directives begin with "@", can accept arguments, and can be applied to the
-- 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

View File

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

View File

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

View File

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

View File

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

View File

@ -15,6 +15,7 @@ module Language.GraphQL.Validate
import Control.Monad (join)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (toList)
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document
@ -185,7 +186,13 @@ fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _)
applyToChildren = directives rule directives'
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 (ArgumentsRule _ rule) = rule

View File

@ -19,6 +19,7 @@ module Language.GraphQL.Validate.Rules
, singleFieldSubscriptionsRule
, specifiedRules
, uniqueArgumentNamesRule
, uniqueDirectiveNamesRule
, uniqueFragmentNamesRule
, uniqueOperationNamesRule
) where
@ -61,6 +62,8 @@ specifiedRules =
, noUnusedFragmentsRule
, fragmentSpreadTargetDefinedRule
, noFragmentCyclesRule
-- Directives.
, uniqueDirectiveNamesRule
]
-- | Definition must be OperationDefinition or FragmentDefinition.
@ -125,8 +128,8 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
collectFromFragment typeCondition selections accumulator
| otherwise = HashSet.union accumulator
<$> collectFields selections
skip (Directive "skip" [Argument "if" (Boolean True) _]) = True
skip (Directive "include" [Argument "if" (Boolean False) _]) = True
skip (Directive "skip" [Argument "if" (Boolean True) _] _) = True
skip (Directive "include" [Argument "if" (Boolean False) _] _) = True
skip _ = False
findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing
| DefinitionFragment fragmentDefinition <- executableDefinition =
@ -452,22 +455,40 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
uniqueArgumentNamesRule :: forall m. Rule m
uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
where
fieldRule (Field _ _ arguments _ _ _) = filterDuplicates arguments
directiveRule (Directive _ arguments) = filterDuplicates arguments
filterDuplicates = lift
fieldRule (Field _ _ arguments _ _ _) =
filterDuplicates extract "argument" arguments
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
. fmap makeError
. filter ((> 1) . length)
. groupBy equalByName
. sortOn getName
getName (Argument argumentName _ _) = argumentName
makeError arguments = Error
{ message = makeMessage $ head arguments
, locations = (\(Argument _ _ location) -> location) <$> arguments
where
getName = fst . extract
equalByName lhs rhs = getName lhs == getName rhs
makeError directives = Error
{ message = makeMessage $ head directives
, locations = snd . extract <$> directives
}
makeMessage argument = concat
[ "There can be only one argument named \""
, Text.unpack $ getName argument
makeMessage directive = concat
[ "There can be only one "
, 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)
| FieldRule (Field -> RuleT m)
| ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
| DirectivesRule ([Directive] -> RuleT m)
-- | Monad transformer used by the rules.
type RuleT m = ReaderT (Validation m) Seq Error

View File

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

View File

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

View File

@ -428,3 +428,16 @@ spec =
, locations = [AST.Location 4 34, AST.Location 4 54]
}
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