summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs17
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs2
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs14
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs49
4 files changed, 69 insertions, 13 deletions
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 529c3b1..b671c13 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -13,6 +13,7 @@ import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
@@ -66,7 +67,7 @@ collectFields objectType = foldl forEach OrderedMap.empty
| otherwise = groupedFields
aliasOrName :: forall m. Transform.Field m -> Name
-aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
+aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
=> Internal.AbstractType m
@@ -96,7 +97,7 @@ executeField fieldResolver prev fields
where
executeField' fieldDefinition resolver = do
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
- let (Transform.Field _ _ arguments' _ :| []) = fields
+ let (Transform.Field _ _ arguments' _ _ :| []) = fields
case coerceArgumentValues argumentDefinitions arguments' of
Nothing -> addError null $ Error "Argument coercing failed." [] []
Just argumentValues -> do
@@ -120,11 +121,12 @@ completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
coerceResult outputType $ Float float
completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
coerceResult outputType $ String string
-completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
+completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
+ Transform.Field _ _ _ _ location = NonEmpty.head fields
in if HashMap.member enum enumMembers
then coerceResult outputType $ Enum enum
- else addError null $ Error "Enum value completion failed." [] []
+ else addError null $ Error "Enum value completion failed." [location] []
completeValue (Out.ObjectBaseType objectType) fields result =
executeSelectionSet result objectType $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result
@@ -139,12 +141,13 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do
let abstractType = Internal.AbstractUnionType unionType
+ let Transform.Field _ _ _ _ location = NonEmpty.head fields
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
$ mergeSelectionSets fields
Nothing -> addError null
- $ Error "Union value completion failed." [] []
+ $ Error "Union value completion failed." [location] []
completeValue _ _ _ = addError null $ Error "Value completion failed." [] []
mergeSelectionSets :: MonadCatch m
@@ -152,7 +155,7 @@ mergeSelectionSets :: MonadCatch m
-> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
where
- forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
+ forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
selectionSet <> fieldSelectionSet
coerceResult :: (MonadCatch m, Serialize a)
@@ -177,7 +180,7 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection
coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
where
forEach fields@(field :| _) =
- let Transform.Field _ name _ _ = field
+ let Transform.Field _ name _ _ _ = field
in traverse (tryResolver fields) $ lookupResolver name
lookupResolver = flip HashMap.lookup resolvers
tryResolver fields resolver =
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
index 0a2a681..648e741 100644
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@@ -52,7 +52,7 @@ createSourceEventStream :: MonadCatch m
-> m (Either String (Out.SourceEventStream m))
createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
| [fieldGroup] <- OrderedMap.elems groupedFieldSet
- , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
+ , Transform.Field _ fieldName arguments' _ _ <- NonEmpty.head fieldGroup
, resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
, Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 62e5b54..5e2054b 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+ v. 2.0. If a copy of the MPL was not distributed with this file, You can
+ obtain one at https://mozilla.org/MPL/2.0/. -}
+
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -77,7 +81,11 @@ data Operation m
-- | Single GraphQL field.
data Field m = Field
- (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
+ (Maybe Full.Name)
+ Full.Name
+ (HashMap Full.Name Input)
+ (Seq (Selection m))
+ Full.Location
-- | Contains the operation to be executed along with its root type.
data Document m = Document
@@ -263,11 +271,11 @@ selection (Full.InlineFragmentSelection fragmentSelection) =
inlineFragment fragmentSelection
field :: Full.Field -> State (Replacement m) (Maybe (Field m))
-field (Full.Field alias name arguments' directives' selections _) = do
+field (Full.Field alias name arguments' directives' selections location) = do
fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections
fieldDirectives <- Definition.selection <$> directives directives'
- let field' = Field alias name fieldArguments fieldSelections
+ let field' = Field alias name fieldArguments fieldSelections location
pure $ field' <$ fieldDirectives
where
go arguments (Full.Argument name' (Full.Node value' _) _) =
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 3288371..5035ec8 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -15,7 +15,7 @@ import Data.Aeson.Types (emptyObject)
import Data.Conduit
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Document, Name)
+import Language.GraphQL.AST (Document, Location(..), Name)
import Language.GraphQL.AST.Parser (document)
import Language.GraphQL.Error
import Language.GraphQL.Execute
@@ -37,6 +37,29 @@ queryType = Out.ObjectType "Query" Nothing []
philosopherField =
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
+musicType :: Out.ObjectType (Either SomeException)
+musicType = Out.ObjectType "Music" Nothing []
+ $ HashMap.fromList resolvers
+ where
+ resolvers =
+ [ ("instrument", ValueResolver instrumentField instrumentResolver)
+ ]
+ instrumentResolver = pure $ Type.String "piano"
+ instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+
+poetryType :: Out.ObjectType (Either SomeException)
+poetryType = Out.ObjectType "Poetry" Nothing []
+ $ HashMap.fromList resolvers
+ where
+ resolvers =
+ [ ("genre", ValueResolver genreField genreResolver)
+ ]
+ genreResolver = pure $ Type.String "Futurism"
+ genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+
+interestType :: Out.UnionType (Either SomeException)
+interestType = Out.UnionType "Interest" Nothing [musicType, poetryType]
+
philosopherType :: Out.ObjectType (Either SomeException)
philosopherType = Out.ObjectType "Philosopher" Nothing []
$ HashMap.fromList resolvers
@@ -45,6 +68,7 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
[ ("firstName", ValueResolver firstNameField firstNameResolver)
, ("lastName", ValueResolver lastNameField lastNameResolver)
, ("school", ValueResolver schoolField schoolResolver)
+ , ("interest", ValueResolver interestField interestResolver)
]
firstNameField =
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
@@ -55,6 +79,11 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
schoolField
= Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty
schoolResolver = pure $ Type.Enum "EXISTENTIALISM"
+ interestField
+ = Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty
+ interestResolver = pure
+ $ Type.Object
+ $ HashMap.fromList [("instrument", "piano")]
subscriptionType :: Out.ObjectType (Either SomeException)
subscriptionType = Out.ObjectType "Subscription" Nothing []
@@ -138,7 +167,7 @@ spec =
]
executionErrors = pure $ Error
{ message = "Enum value completion failed."
- , locations = []
+ , locations = [Location 1 17]
, path = []
}
expected = Response data'' executionErrors
@@ -146,6 +175,22 @@ spec =
$ parse document "" "{ philosopher { school } }"
in actual `shouldBe` expected
+ it "gives location information for invalid interfaces" $
+ let data'' = Aeson.object
+ [ "philosopher" .= Aeson.object
+ [ "interest" .= Aeson.Null
+ ]
+ ]
+ executionErrors = pure $ Error
+ { message = "Union value completion failed."
+ , locations = [Location 1 17]
+ , path = []
+ }
+ expected = Response data'' executionErrors
+ Right (Right actual) = either (pure . parseError) execute'
+ $ parse document "" "{ philosopher { interest } }"
+ 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:22:44 +0000