diff --git a/CHANGELOG.md b/CHANGELOG.md index 1c904d7..f7b2e94 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 7d0bcd0..5d21ca0 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 342a45f..fcd415e 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index cd2bd89..ecefaf6 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -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 diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index f6d1539..62a247d 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -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 diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 64259ec..d150446 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -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 diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 00ba629..ff2734d 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -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 diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 795e5ca..f9498b9 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -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 - . 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 + 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 + 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 diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index d07d6e8..f2bccd3 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -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 diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs index 5649d2d..c4fae45 100644 --- a/tests/Language/GraphQL/AST/LexerSpec.hs +++ b/tests/Language/GraphQL/AST/LexerSpec.hs @@ -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` "|" diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index f59e5a9..5c4d39e 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -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" :| [] diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index dfc3a4d..507ca7b 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -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