summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Language/GraphQL/Execute.hs26
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs50
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs29
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs37
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs20
5 files changed, 100 insertions, 62 deletions
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index ac8f954..9e96cd2 100644
--- 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
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 31cc579..c2a2d97 100644
--- 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
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
index fada378..3b07154 100644
--- 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
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 5f3b771..117b708 100644
--- 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
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 5e86848..1f8770b 100644
--- 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
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:19:04 +0000