Fail with a location for result coercion

The intermediate representation was further modified so that the operation definitions contain location information. Probably I should introduce a data type that generalizes fields and operations, so it contains object type, location and the selection set, so the functions don't accept so many arguments.
2021-06-24 09:29:24 +02:00 · 2021-06-24 09:29:24 +02:00 · 96bb061666
commit 96bb061666
parent 812f6967d4
5 changed files with 100 additions and 62 deletions
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@ -8,7 +8,7 @@ import Control.Monad.Catch (MonadCatch)
 import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq(..))
 import Data.Text (Text)
-import Language.GraphQL.AST.Document (Document, Name)
+import qualified Language.GraphQL.AST.Document as Full
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
 import Language.GraphQL.Execute.Internal
@ -28,8 +28,8 @@ import Language.GraphQL.Type.Schema
 execute :: (MonadCatch m, VariableValue a, Serialize b)
    => Schema m -- ^ Resolvers.
    -> Maybe Text -- ^ Operation name.
-    -> HashMap Name a -- ^ Variable substitution function.
-    -> Document -- @GraphQL@ document.
+    -> 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
@ -40,20 +40,22 @@ executeRequest :: (MonadCatch m, Serialize a)
    => Transform.Document m
    -> m (Either (ResponseEventStream m a) (Response a))
 executeRequest (Transform.Document types' rootObjectType operation)
-    | (Transform.Query _ fields) <- operation =
-        Right <$> executeOperation types' rootObjectType fields
-    | (Transform.Mutation _ fields) <- operation =
-        Right <$> executeOperation types' rootObjectType fields
-    | (Transform.Subscription _ fields) <- operation
+    | (Transform.Query _ fields objectLocation) <- operation =
+        Right <$> executeOperation types' rootObjectType objectLocation fields
+    | (Transform.Mutation _ fields objectLocation) <- operation =
+        Right <$> executeOperation types' rootObjectType objectLocation fields
+    | (Transform.Subscription _ fields objectLocation) <- operation
        = either singleError Left
-        <$> Subscribe.subscribe types' rootObjectType fields
+        <$> Subscribe.subscribe types' rootObjectType objectLocation fields

 -- This is actually executeMutation, but we don't distinguish between queries
 -- and mutations yet.
 executeOperation :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
    -> Out.ObjectType m
+    -> Full.Location
    -> Seq (Transform.Selection m)
    -> m (Response a)
-executeOperation types' objectType fields =
-    runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields
+executeOperation types' objectType objectLocation fields
+    = runCollectErrs types'
+    $ executeSelectionSet Definition.Null objectType objectLocation fields
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@ -117,41 +117,42 @@ completeValue :: (MonadCatch m, Serialize a)
 completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
 completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
    = traverse (completeValue listType fields) list
-    >>= coerceResult outputType . List
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
-    coerceResult outputType $ Int int
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
-    coerceResult outputType $ Boolean boolean
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
-    coerceResult outputType $ Float float
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
-    coerceResult outputType $ String string
+    >>= coerceResult outputType (firstFieldLocation fields) . List
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) =
+    coerceResult outputType (firstFieldLocation fields) $ Int int
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) =
+    coerceResult outputType (firstFieldLocation fields) $ Boolean boolean
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) =
+    coerceResult outputType (firstFieldLocation fields) $ Float float
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) =
+    coerceResult outputType (firstFieldLocation fields) $ String string
 completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
    let Type.EnumType _ _ enumMembers = enumType
-        Transform.Field _ _ _ _ location = NonEmpty.head fields
+        location = firstFieldLocation fields
     in if HashMap.member enum enumMembers
-        then coerceResult outputType $ Enum enum
+        then coerceResult outputType location $ Enum enum
        else addError null $ Error "Enum value completion failed." [location] []
-completeValue (Out.ObjectBaseType objectType) fields result =
-    executeSelectionSet result objectType $ mergeSelectionSets fields
+completeValue (Out.ObjectBaseType objectType) fields result
+    = executeSelectionSet result objectType (firstFieldLocation fields)
+    $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
    | Type.Object objectMap <- result = do
        let abstractType = Internal.AbstractInterfaceType interfaceType
-        let Transform.Field _ _ _ _ location = NonEmpty.head fields
+        let location = firstFieldLocation fields
        concreteType <- resolveAbstractType abstractType objectMap
        case concreteType of
-            Just objectType -> executeSelectionSet result objectType
+            Just objectType -> executeSelectionSet result objectType location
                $ mergeSelectionSets fields
            Nothing -> addError null
                $ Error "Interface value completion failed." [location] []
 completeValue (Out.UnionBaseType unionType) fields result
    | Type.Object objectMap <- result = do
        let abstractType = Internal.AbstractUnionType unionType
-        let Transform.Field _ _ _ _ location = NonEmpty.head fields
+        let  location = firstFieldLocation fields
        concreteType <- resolveAbstractType abstractType objectMap
        case concreteType of
            Just objectType -> executeSelectionSet result objectType
-                $ mergeSelectionSets fields
+                location $ mergeSelectionSets fields
            Nothing -> addError null
                $ Error "Union value completion failed." [location] []
 completeValue _ (Transform.Field _ _ _ _ location :| _) _ =
@ -165,13 +166,18 @@ mergeSelectionSets = foldr forEach mempty
    forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
        selectionSet <> fieldSelectionSet

+firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location
+firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation
+
 coerceResult :: (MonadCatch m, Serialize a)
    => Out.Type m
+    -> Full.Location
    -> Output a
    -> CollectErrsT m a
-coerceResult outputType result
+coerceResult outputType parentLocation result
    | Just serialized <- serialize outputType result = pure serialized
-    | otherwise = addError null $ Error "Result coercion failed." [] []
+    | otherwise = addError null
+        $ Error "Result coercion failed." [parentLocation] []

 -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
 -- each field to each 'Transform.Selection'. Resolves into a value containing
@ -179,12 +185,14 @@ coerceResult outputType result
 executeSelectionSet :: (MonadCatch m, Serialize a)
    => Type.Value
    -> Out.ObjectType m
+    -> Full.Location
    -> Seq (Transform.Selection m)
    -> CollectErrsT m a
-executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do
    let fields = collectFields objectType selectionSet
    resolvedValues <- OrderedMap.traverseMaybe forEach fields
-    coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
+    coerceResult (Out.NonNullObjectType objectType) objectLocation
+        $ Object resolvedValues
  where
    forEach fields@(field :| _) =
        let Transform.Field _ name _ _ _ = field
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@ -15,7 +15,7 @@ import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq(..))
-import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.AST as Full
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
 import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
@ -27,26 +27,31 @@ import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema

 subscribe :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
    -> Out.ObjectType m
+    -> Full.Location
    -> Seq (Transform.Selection m)
    -> m (Either String (ResponseEventStream m a))
-subscribe types' objectType fields = do
+subscribe types' objectType objectLocation fields = do
    sourceStream <- createSourceEventStream types' objectType fields
-    traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
+    let traverser =
+            mapSourceToResponseEvent types' objectType objectLocation fields
+    traverse traverser sourceStream

 mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
    -> Out.ObjectType m
+    -> Full.Location
    -> Seq (Transform.Selection m)
    -> Out.SourceEventStream m
    -> m (ResponseEventStream m a)
-mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
+mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
+    = pure
    $ sourceStream
-    .| mapMC (executeSubscriptionEvent types' subscriptionType fields)
+    .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)

 createSourceEventStream :: MonadCatch m
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
    -> Out.ObjectType m
    -> Seq (Transform.Selection m)
    -> m (Either String (Out.SourceEventStream m))
@ -82,10 +87,12 @@ resolveFieldEventStream result args resolver =
        }

 executeSubscriptionEvent :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
    -> Out.ObjectType m
+    -> Full.Location
    -> Seq (Transform.Selection m)
    -> Definition.Value
    -> m (Response a)
-executeSubscriptionEvent types' objectType fields initialValue =
-    runCollectErrs types' $ executeSelectionSet initialValue objectType fields
+executeSubscriptionEvent types' objectType objectLocation fields initialValue
+    = runCollectErrs types'
+    $ executeSelectionSet initialValue objectType objectLocation fields
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@ -75,9 +75,9 @@ data Selection m

 -- | GraphQL has 3 operation types: queries, mutations and subscribtions.
 data Operation m
-    = Query (Maybe Text) (Seq (Selection m))
-    | Mutation (Maybe Text) (Seq (Selection m))
-    | Subscription (Maybe Text) (Seq (Selection m))
+    = Query (Maybe Text) (Seq (Selection m)) Full.Location
+    | Mutation (Maybe Text) (Seq (Selection m)) Full.Location
+    | Subscription (Maybe Text) (Seq (Selection m)) Full.Location

 -- | Single GraphQL field.
 data Field m = Field
@ -97,6 +97,7 @@ data OperationDefinition = OperationDefinition
    [Full.VariableDefinition]
    [Full.Directive]
    Full.SelectionSet
+    Full.Location

 -- | Query error types.
 data QueryError
@ -138,7 +139,7 @@ getOperation (Just operationName) operations
    | Just operation' <- find matchingName operations = pure operation'
    | otherwise = Left $ OperationNotFound operationName
  where
-    matchingName (OperationDefinition _ name _ _ _) =
+    matchingName (OperationDefinition _ name _ _ _ _) =
        name == Just operationName

 coerceVariableValues :: Coerce.VariableValue a
@ -148,7 +149,7 @@ coerceVariableValues :: Coerce.VariableValue a
    -> HashMap.HashMap Full.Name a
    -> Either QueryError Type.Subs
 coerceVariableValues types operationDefinition variableValues =
-    let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
+    let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
     in maybe (Left CoercionError) Right
        $ foldr forEach (Just HashMap.empty) variableDefinitions
  where
@ -206,14 +207,14 @@ document schema operationName subs ast = do
            , types = referencedTypes
            }
    case chosenOperation of
-        OperationDefinition Full.Query _ _ _ _ ->
+        OperationDefinition Full.Query _ _ _ _ _ ->
            pure $ Document referencedTypes (Schema.query schema)
                $ operation chosenOperation replacement
-        OperationDefinition Full.Mutation _ _ _ _
+        OperationDefinition Full.Mutation _ _ _ _ _
            | Just mutationType <- Schema.mutation schema ->
                pure $ Document referencedTypes mutationType
                    $ operation chosenOperation replacement
-        OperationDefinition Full.Subscription _ _ _ _
+        OperationDefinition Full.Subscription _ _ _ _ _
            | Just subscriptionType <- Schema.subscription schema ->
                pure $ Document referencedTypes subscriptionType
                    $ operation chosenOperation replacement
@ -238,10 +239,10 @@ defragment ast =
            (operations, HashMap.insert name fragment fragments')
    defragment' _ acc = acc
    transform = \case
-        Full.OperationDefinition type' name variables directives' selections _ ->
-            OperationDefinition type' name variables directives' selections
-        Full.SelectionSet selectionSet _ ->
-            OperationDefinition Full.Query Nothing mempty mempty selectionSet
+        Full.OperationDefinition type' name variables directives' selections location ->
+            OperationDefinition type' name variables directives' selections location
+        Full.SelectionSet selectionSet location ->
+            OperationDefinition Full.Query Nothing mempty mempty selectionSet location

 -- * Operation

@ -250,12 +251,12 @@ operation operationDefinition replacement
    = runIdentity
    $ evalStateT (collectFragments >> transform operationDefinition) replacement
  where
-    transform (OperationDefinition Full.Query name _ _ sels) =
-        Query name <$> appendSelection sels
-    transform (OperationDefinition Full.Mutation name _ _ sels) =
-        Mutation name <$> appendSelection sels
-    transform (OperationDefinition Full.Subscription name _ _ sels) =
-        Subscription name <$> appendSelection sels
+    transform (OperationDefinition Full.Query name _ _ sels location) =
+        flip (Query name) location <$> appendSelection sels
+    transform (OperationDefinition Full.Mutation name _ _ sels location) =
+        flip (Mutation name) location <$> appendSelection sels
+    transform (OperationDefinition Full.Subscription name _ _ sels location) =
+        flip (Subscription name) location <$> appendSelection sels

 -- * Selection

--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@ -82,6 +82,7 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
        , ("school", ValueResolver schoolField schoolResolver)
        , ("interest", ValueResolver interestField interestResolver)
        , ("majorWork", ValueResolver majorWorkField majorWorkResolver)
+        , ("century", ValueResolver centuryField centuryResolver)
        ]
    firstNameField =
        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
@ -104,6 +105,9 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
        $ HashMap.fromList
            [ ("title", "Also sprach Zarathustra: Ein Buch für Alle und Keinen")
            ]
+    centuryField =
+        Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty
+    centuryResolver = pure $ Float 18.5

 workType :: Out.InterfaceType (Either SomeException)
 workType = Out.InterfaceType "Work" Nothing []
@ -268,6 +272,22 @@ spec =
                        $ parse document "" "{ philosopher(id: true) { lastName } }"
                in actual `shouldBe` expected

+            it "gives location information for failed result coercion" $
+                let data'' = Aeson.object
+                        [ "philosopher" .= Aeson.object
+                            [ "century" .= Aeson.Null
+                            ]
+                        ]
+                    executionErrors = pure $ Error
+                        { message = "Result coercion failed."
+                        , locations = [Location 1 26]
+                        , path = []
+                        }
+                    expected = Response data'' executionErrors
+                    Right (Right actual) = either (pure . parseError) execute'
+                        $ parse document "" "{ philosopher(id: \"1\") { century } }"
+                in actual `shouldBe` expected
+
        context "Subscription" $
            it "subscribes" $
                let data'' = Aeson.object