Validate directives are unique per location

8 files changed, 59 insertions, 29 deletions

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