From b580d1a98880749c1473c11b790d3ec622fe00ad Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Sun, 27 Jun 2021 13:42:58 +0200
Subject: [PATCH] Attach the field location to resolver exceptions

---
 graphql.cabal                             |  1 +
 src/Language/GraphQL/Execute/Execution.hs | 10 +++---
 tests/Language/GraphQL/ExecuteSpec.hs     | 40 ++++++++++++++++++++---
 3 files changed, 43 insertions(+), 8 deletions(-)

diff --git a/graphql.cabal b/graphql.cabal
index 53f0a84..2e1b6d0 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -98,6 +98,7 @@ test-suite graphql-test
     , aeson
     , base >= 4.7 && < 5
     , conduit
+    , exceptions
     , graphql
     , hspec >= 2.8.2 && < 2.9
     , hspec-megaparsec >= 2.2.0 && < 2.3
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index c2a2d97..9ad4439 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -37,15 +37,17 @@ resolveFieldValue :: MonadCatch m
     => Type.Value
     -> Type.Subs
     -> Type.Resolve m
+    -> Full.Location
     -> CollectErrsT m Type.Value
-resolveFieldValue result args resolver =
+resolveFieldValue result args resolver location' =
     catch (lift $ runReaderT resolver context) handleFieldError
   where
     handleFieldError :: MonadCatch m
         => ResolverException
         -> CollectErrsT m Type.Value
-    handleFieldError e =
-        addError Type.Null $ Error (Text.pack $ displayException e) [] []
+    handleFieldError e
+        = addError Type.Null
+        $ Error (Text.pack $ displayException e) [location'] []
     context = Type.Context
         { Type.arguments = Type.Arguments args
         , Type.values = result
@@ -106,7 +108,7 @@ executeField fieldResolver prev fields
             Left errorLocations -> addError null
                 $ Error "Argument coercing failed." errorLocations []
             Right argumentValues -> do
-                answer <- resolveFieldValue prev argumentValues resolver
+                answer <- resolveFieldValue prev argumentValues resolver location'
                 completeValue fieldType fields answer
 
 completeValue :: (MonadCatch m, Serialize a)
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 1f8770b..d14eb9d 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -8,13 +8,15 @@ module Language.GraphQL.ExecuteSpec
     ( spec
     ) where
 
-import Control.Exception (SomeException)
+import Control.Exception (Exception(..), SomeException)
+import Control.Monad.Catch (throwM)
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
 import Data.Aeson.Types (emptyObject)
 import Data.Conduit
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Typeable (cast)
 import Language.GraphQL.AST (Document, Location(..), Name)
 import Language.GraphQL.AST.Parser (document)
 import Language.GraphQL.Error
@@ -28,6 +30,15 @@ import Test.Hspec (Spec, context, describe, it, shouldBe)
 import Text.Megaparsec (parse)
 import Text.RawString.QQ (r)
 
+data PhilosopherException = PhilosopherException
+    deriving Show
+
+instance Exception PhilosopherException where
+    toException = toException. ResolverException
+    fromException e = do
+        ResolverException resolverException <- fromException e
+        cast resolverException
+
 philosopherSchema :: Schema (Either SomeException)
 philosopherSchema =
     schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty
@@ -40,14 +51,21 @@ philosopherSchema =
 
 queryType :: Out.ObjectType (Either SomeException)
 queryType = Out.ObjectType "Query" Nothing []
-    $ HashMap.singleton "philosopher"
-    $ ValueResolver philosopherField
-    $ pure $ Object mempty
+    $ HashMap.fromList
+    [ ("philosopher", ValueResolver philosopherField philosopherResolver)
+    , ("genres", ValueResolver genresField genresResolver)
+    ]
   where
     philosopherField =
         Out.Field Nothing (Out.NonNullObjectType philosopherType)
         $ HashMap.singleton "id"
         $ In.Argument Nothing (In.NamedScalarType id) Nothing
+    philosopherResolver = pure $ Object mempty
+    genresField =
+      let fieldType = Out.ListType $ Out.NonNullScalarType string
+       in Out.Field Nothing fieldType HashMap.empty
+    genresResolver :: Resolve (Either SomeException)
+    genresResolver = throwM PhilosopherException
 
 musicType :: Out.ObjectType (Either SomeException)
 musicType = Out.ObjectType "Music" Nothing []
@@ -288,6 +306,20 @@ spec =
                         $ parse document "" "{ philosopher(id: \"1\") { century } }"
                 in actual `shouldBe` expected
 
+            it "gives location information for failed result coercion" $
+                let data'' = Aeson.object
+                        [ "genres" .= Aeson.Null
+                        ]
+                    executionErrors = pure $ Error
+                        { message = "PhilosopherException"
+                        , locations = [Location 1 3]
+                        , path = []
+                        }
+                    expected = Response data'' executionErrors
+                    Right (Right actual) = either (pure . parseError) execute'
+                        $ parse document "" "{ genres }"
+                in actual `shouldBe` expected
+
         context "Subscription" $
             it "subscribes" $
                 let data'' = Aeson.object