From 6daae8a5219f62de98b4a65788e436fb1eac8cba Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Fri, 2 Oct 2020 06:31:38 +0200
Subject: Validate directives are in valid locations

---
 src/Language/GraphQL/Validate/Rules.hs | 32 +++++++++++++++++++++++++++++---
 1 file changed, 29 insertions(+), 3 deletions(-)

(limited to 'src/Language/GraphQL/Validate/Rules.hs')

diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 7cfa712..6c35f70 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -10,7 +10,8 @@
 
 -- | This module contains default rules defined in the GraphQL specification.
 module Language.GraphQL.Validate.Rules
-    ( executableDefinitionsRule
+    ( directivesInValidLocationsRule
+    , executableDefinitionsRule
     , fieldsOnCorrectTypeRule
     , fragmentsOnCompositeTypesRule
     , fragmentSpreadTargetDefinedRule
@@ -90,6 +91,7 @@ specifiedRules =
     , uniqueInputFieldNamesRule
     -- Directives.
     , knownDirectiveNamesRule
+    , directivesInValidLocationsRule
     , uniqueDirectiveNamesRule
     -- Variables.
     , uniqueVariableNamesRule
@@ -514,7 +516,7 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 -- of each directive is allowed per location.
 uniqueDirectiveNamesRule :: forall m. Rule m
 uniqueDirectiveNamesRule = DirectivesRule
-    $ lift . filterDuplicates extract "directive"
+    $ const $ lift . filterDuplicates extract "directive"
   where
     extract (Directive directiveName _ location') = (directiveName, location')
 
@@ -818,7 +820,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 -- | GraphQL servers define what directives they support. For each usage of a
 -- directive, the directive must be available on that server.
 knownDirectiveNamesRule :: Rule m
-knownDirectiveNamesRule = DirectivesRule $ \directives' -> do
+knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
     definitions' <- asks directives
     let directiveSet = HashSet.fromList $ fmap directiveName directives'
     let definitionSet = HashSet.fromList $ HashMap.keys definitions'
@@ -867,3 +869,27 @@ knownInputFieldNamesRule = ValueRule go constGo
         , Text.unpack typeName
         , "\"."
         ]
+
+-- | GraphQL servers define what directives they support and where they support
+-- them. For each usage of a directive, the directive must be used in a location
+-- that the server has declared support for.
+directivesInValidLocationsRule :: Rule m
+directivesInValidLocationsRule = DirectivesRule directivesRule
+  where
+    directivesRule directiveLocation directives' = do
+        Directive directiveName _ location <- lift $ Seq.fromList directives'
+        maybeDefinition <- asks $ HashMap.lookup directiveName . directives
+        case maybeDefinition of
+            Just (Schema.Directive _ allowedLocations _)
+                | directiveLocation `notElem` allowedLocations -> pure $ Error
+                    { message = errorMessage directiveName directiveLocation
+                    , locations = [location]
+                    }
+            _ -> lift mempty
+    errorMessage directiveName directiveLocation = concat
+        [ "Directive \"@"
+        , Text.unpack directiveName
+        , "\" may not be used on "
+        , show directiveLocation
+        , "."
+        ]
-- 
cgit v1.2.3