Report subscription error locations

src/Language/GraphQL/Execute.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ExplicitForAll #-}
+
 -- | This module provides functions to execute a @GraphQL@ request.
 module Language.GraphQL.Execute
     ( execute
@@ -14,10 +16,16 @@ import Language.GraphQL.Execute.Execution
 import Language.GraphQL.Execute.Internal
 import qualified Language.GraphQL.Execute.Transform as Transform
 import qualified Language.GraphQL.Execute.Subscribe as Subscribe
-import Language.GraphQL.Error (ResponseEventStream, Response, runCollectErrs)
+import Language.GraphQL.Error
+    ( Error
+    , ResponseEventStream
+    , Response(..)
+    , runCollectErrs
+    )
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
+import Prelude hiding (null)
 
 -- | The substitution is applied to the document, and the resolvers are applied
 -- to the resulting fields. The operation name can be used if the document
@@ -31,10 +39,9 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
     -> HashMap Full.Name a -- ^ Variable substitution function.
     -> Full.Document -- @GraphQL@ document.
     -> m (Either (ResponseEventStream m b) (Response b))
-execute schema' operationName subs document =
-    case Transform.document schema' operationName subs document of
-        Left queryError -> pure $ singleError $ show queryError
-        Right transformed -> executeRequest transformed
+execute schema' operationName subs document
+    = either (pure . rightErrorResponse . singleError [] . show) executeRequest
+    $ Transform.document schema' operationName subs document
 
 executeRequest :: (MonadCatch m, Serialize a)
     => Transform.Document m
@@ -45,7 +52,7 @@ executeRequest (Transform.Document types' rootObjectType operation)
     | (Transform.Mutation _ fields objectLocation) <- operation =
         Right <$> executeOperation types' rootObjectType objectLocation fields
     | (Transform.Subscription _ fields objectLocation) <- operation
-        = either singleError Left
+        = either rightErrorResponse Left
         <$> Subscribe.subscribe types' rootObjectType objectLocation fields
 
 -- This is actually executeMutation, but we don't distinguish between queries
@@ -59,3 +66,6 @@ executeOperation :: (MonadCatch m, Serialize a)
 executeOperation types' objectType objectLocation fields
     = runCollectErrs types'
     $ executeSelectionSet Definition.Null objectType objectLocation fields
+
+rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
+rightErrorResponse = Right . Response null . pure

src/Language/GraphQL/Execute/Internal.hs

@@ -15,13 +15,8 @@ import Control.Monad.Trans.State (modify)
 import Control.Monad.Catch (MonadCatch)
 import Data.Sequence ((|>))
 import qualified Data.Text as Text
-import Language.GraphQL.Execute.Coerce
-import Language.GraphQL.Error
-    ( CollectErrsT
-    , Error(..)
-    , Resolution(..)
-    , Response(..)
-    )
+import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..))
 import Prelude hiding (null)
 
 addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a
@@ -32,6 +27,5 @@ addError returnValue error' = modify appender >> pure returnValue
        { errors = errors |> error'
        }
 
-singleError :: Serialize b => forall a. String -> Either a (Response b)
-singleError message =
-    Right $ Response null $ pure $ Error (Text.pack message) [] []
+singleError :: [Full.Location] -> String -> Error
+singleError errorLocations message = Error (Text.pack message) errorLocations []

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