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