From 809f446ff1f7e4c94393cce0f490a07ef64d3440 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Fri, 5 Jan 2024 20:46:02 +0100
Subject: [PATCH] Fix variable location in objects and lists

---
 src/Language/GraphQL/Validate/Rules.hs       | 22 +++++++-----------
 tests/Language/GraphQL/Validate/RulesSpec.hs | 24 ++++++++++++++++++--
 2 files changed, 30 insertions(+), 16 deletions(-)

diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 2be8bec..2d7adba 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -2,11 +2,13 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 
 -- | This module contains default rules defined in the GraphQL specification.
@@ -61,6 +63,7 @@ import Data.Sequence (Seq(..), (|>))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
+import GHC.Records (HasField(..))
 import qualified Language.GraphQL.AST.Document as Full
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Internal as Type
@@ -668,25 +671,16 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
         = filterSelections' selections
         >>= lift . mapReaderT (<> mapDirectives directives') . pure
     findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
-
     mapArguments = Seq.fromList . (>>= findArgumentVariables)
     mapDirectives = foldMap findDirectiveVariables
 
-    findArgumentVariables (Full.Argument _ Full.Node{node = value, ..} _) =
-        findValueVariables location value
+    findArgumentVariables (Full.Argument _ value _) = findNodeVariables value
+    findNodeVariables Full.Node{ node = value, ..} = findValueVariables location value
 
     findValueVariables location (Full.Variable value') = [(value', [location])]
-    findValueVariables location (Full.List values) =
-        values
-            >>= (\(Full.Node{node = value}) -> findValueVariables location value)
-    findValueVariables _ (Full.Object fields) =
-        fields
-            >>= ( \( Full.ObjectField
-                        { location = location
-                        , value = Full.Node{node = value}
-                        }
-                    ) -> findValueVariables location value
-                )
+    findValueVariables _ (Full.List values) = values >>= findNodeVariables
+    findValueVariables _ (Full.Object fields) = fields
+        >>= findNodeVariables . getField @"value"
     findValueVariables _ _ = []
     makeError operationName (variableName, locations') = Error
         { message = errorMessage operationName variableName
diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs
index 0d9faaa..7bdbd86 100644
--- a/tests/Language/GraphQL/Validate/RulesSpec.hs
+++ b/tests/Language/GraphQL/Validate/RulesSpec.hs
@@ -18,7 +18,7 @@ import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Validate
-import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain, xit)
+import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain)
 import Text.Megaparsec (parse, errorBundlePretty)
 
 petSchema :: Schema IO
@@ -29,6 +29,7 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
     [ ("dog", dogResolver)
     , ("cat", catResolver)
     , ("findDog", findDogResolver)
+    , ("findCats", findCatsResolver)
     ]
   where
     dogField = Field Nothing (Out.NamedObjectType dogType) mempty
@@ -39,6 +40,11 @@ queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
     findDogResolver = ValueResolver findDogField $ pure Null
     catField = Field Nothing (Out.NamedObjectType catType) mempty
     catResolver = ValueResolver catField $ pure Null
+    findCatsArguments = HashMap.singleton "commands"
+        $ In.Argument Nothing (In.NonNullListType $ In.NonNullEnumType catCommandType)
+        $ Just $ List []
+    findCatsField = Field Nothing (Out.NonNullListType $ Out.NonNullObjectType catType) findCatsArguments
+    findCatsResolver = ValueResolver findCatsField $ pure $ List []
 
 catCommandType :: EnumType
 catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
@@ -560,7 +566,7 @@ spec =
                         }
                  in validate queryString `shouldBe` [expected]
 
-            xit "gets location of the variable inside an input object" $
+            it "gets variable location inside an input object" $
                 let queryString = [gql|
                   query {
                     findDog (complex: { name: $name }) {
@@ -574,6 +580,20 @@ spec =
                         }
                  in validate queryString `shouldBe` [expected]
 
+            it "gets variable location inside an array" $
+                let queryString = [gql|
+                  query {
+                    findCats (commands: [JUMP, $command]) {
+                      name
+                    }
+                  }
+                |]
+                    expected = Error
+                        { message = "Variable \"$command\" is not defined."
+                        , locations = [AST.Location 2 30]
+                        }
+                 in validate queryString `shouldBe` [expected]
+
         context "noUnusedVariablesRule" $ do
             it "rejects unused variables" $
                 let queryString = [gql|