Validate directives are unique per location

12 files changed, 79 insertions, 34 deletions

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