From b99bb722722b8d7a40445a3e8af7b6b3f09cf770 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Fri, 2 Jul 2021 09:28:03 +0200
Subject: Report subscription error locations

---
 src/Language/GraphQL/Execute/Subscribe.hs | 33 ++++++++++++++++++++++---------
 1 file changed, 24 insertions(+), 9 deletions(-)

(limited to 'src/Language/GraphQL/Execute/Subscribe.hs')

diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
index 3b07154..5d8d294 100644
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@@ -9,6 +9,7 @@ module Language.GraphQL.Execute.Subscribe
     ) where
 
 import Conduit
+import Control.Arrow (left)
 import Control.Monad.Catch (Exception(..), MonadCatch(..))
 import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
 import Data.HashMap.Strict (HashMap)
@@ -18,9 +19,16 @@ import Data.Sequence (Seq(..))
 import qualified Language.GraphQL.AST as Full
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
+import Language.GraphQL.Execute.Internal
 import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
 import qualified Language.GraphQL.Execute.Transform as Transform
 import Language.GraphQL.Error
+    ( Error(..)
+    , ResolverException
+    , Response
+    , ResponseEventStream
+    , runCollectErrs
+    )
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.Out as Out
@@ -31,9 +39,10 @@ subscribe :: (MonadCatch m, Serialize a)
     -> Out.ObjectType m
     -> Full.Location
     -> Seq (Transform.Selection m)
-    -> m (Either String (ResponseEventStream m a))
+    -> m (Either Error (ResponseEventStream m a))
 subscribe types' objectType objectLocation fields = do
-    sourceStream <- createSourceEventStream types' objectType fields
+    sourceStream <-
+        createSourceEventStream types' objectType objectLocation fields
     let traverser =
             mapSourceToResponseEvent types' objectType objectLocation fields
     traverse traverser sourceStream
@@ -53,19 +62,25 @@ mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStr
 createSourceEventStream :: MonadCatch m
     => HashMap Full.Name (Type m)
     -> Out.ObjectType m
+    -> Full.Location
     -> Seq (Transform.Selection m)
-    -> m (Either String (Out.SourceEventStream m))
-createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
+    -> m (Either Error (Out.SourceEventStream m))
+createSourceEventStream _types subscriptionType objectLocation fields
     | [fieldGroup] <- OrderedMap.elems groupedFieldSet
-    , Transform.Field _ fieldName arguments' _ _ <- NonEmpty.head fieldGroup
+    , Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
+    , Out.ObjectType _ _ _ fieldTypes <- subscriptionType
     , resolverT <- fieldTypes HashMap.! fieldName
     , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
     , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
         case coerceArgumentValues argumentDefinitions arguments' of
-            Left _ -> pure $ Left "Argument coercion failed."
-            Right  argumentValues ->
-                resolveFieldEventStream Type.Null argumentValues resolver
-    | otherwise = pure $ Left "Subscription contains more than one field."
+            Left _ -> pure
+                $ Left
+                $ Error "Argument coercion failed." [errorLocation] []
+            Right  argumentValues -> left (singleError [errorLocation])
+                <$> resolveFieldEventStream Type.Null argumentValues resolver
+    | otherwise = pure
+        $ Left
+        $ Error "Subscription contains more than one field." [objectLocation] []
   where
     groupedFieldSet = collectFields subscriptionType fields
 
-- 
cgit v1.2.3