From 1b7cd85216e58650552e690be81fb46bea2d88ab Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 12 May 2021 06:51:59 +0200 Subject: [PATCH] Add location information to the intermediate tree --- src/Language/GraphQL/Execute/Execution.hs | 17 ++++---- src/Language/GraphQL/Execute/Subscribe.hs | 2 +- src/Language/GraphQL/Execute/Transform.hs | 14 +++++-- tests/Language/GraphQL/ExecuteSpec.hs | 49 ++++++++++++++++++++++- 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