diff options
Diffstat (limited to 'src/Language/GraphQL/Execute/Execution.hs')
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 160 |
1 files changed, 90 insertions, 70 deletions
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 647c60f..0c10419 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -1,11 +1,11 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Language.GraphQL.Execute.Execution ( executeSelectionSet ) where -import qualified Data.Aeson as Aeson import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) @@ -22,16 +22,17 @@ import Language.GraphQL.AST (Name) import Language.GraphQL.AST.Core import Language.GraphQL.Error import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Execute.Transform +import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Trans -import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema +import Prelude hiding (null) resolveFieldValue :: Monad m - => Definition.Value - -> Definition.Subs + => Type.Value + -> Type.Subs -> ActionT m a -> m (Either Text a) resolveFieldValue result args = @@ -41,29 +42,29 @@ resolveFieldValue result args = collectFields :: Monad m => Out.ObjectType m - -> Seq (Selection m) - -> Map Name (NonEmpty (Field m)) + -> Seq (Transform.Selection m) + -> Map Name (NonEmpty (Transform.Field m)) collectFields objectType = foldl forEach Map.empty where - forEach groupedFields (SelectionField field) = + forEach groupedFields (Transform.SelectionField field) = let responseKey = aliasOrName field in Map.insertWith (<>) responseKey (field :| []) groupedFields - forEach groupedFields (SelectionFragment selectionFragment) - | Fragment fragmentType fragmentSelectionSet <- selectionFragment + forEach groupedFields (Transform.SelectionFragment selectionFragment) + | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment , doesFragmentTypeApply fragmentType objectType = let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet | otherwise = groupedFields -aliasOrName :: forall m. Field m -> Name -aliasOrName (Field alias name _ _) = fromMaybe name alias +aliasOrName :: forall m. Transform.Field m -> Name +aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias resolveAbstractType :: Monad m => AbstractType m - -> HashMap Name Definition.Value + -> Type.Subs -> CollectErrsT m (Maybe (Out.ObjectType m)) resolveAbstractType abstractType values' - | Just (Definition.String typeName) <- HashMap.lookup "__typename" values' = do + | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do types' <- gets types case HashMap.lookup typeName types' of Just (ObjectType objectType) -> @@ -97,14 +98,14 @@ instanceOf objectType (AbstractUnionType unionType) = where go unionMemberType acc = acc || objectType == unionMemberType -executeField :: Monad m +executeField :: (Monad m, Serialize a) => Out.Resolver m - -> Definition.Value - -> NonEmpty (Field m) - -> CollectErrsT m Aeson.Value + -> Type.Value + -> NonEmpty (Transform.Field m) + -> CollectErrsT m a executeField (Out.Resolver fieldDefinition resolver) prev fields = do let Out.Field _ fieldType argumentDefinitions = fieldDefinition - let (Field _ _ arguments' _ :| []) = fields + let (Transform.Field _ _ arguments' _ :| []) = fields case coerceArgumentValues argumentDefinitions arguments' of Nothing -> errmsg "Argument coercing failed." Just argumentValues -> do @@ -113,61 +114,80 @@ executeField (Out.Resolver fieldDefinition resolver) prev fields = do Right result -> completeValue fieldType fields result Left errorMessage -> errmsg errorMessage -completeValue :: Monad m +completeValue :: (Monad m, Serialize a) => Out.Type m - -> NonEmpty (Field m) - -> Definition.Value - -> CollectErrsT m Aeson.Value -completeValue _ _ Definition.Null = pure Aeson.Null -completeValue _ _ (Definition.Int integer) = pure $ Aeson.toJSON integer -completeValue _ _ (Definition.Boolean boolean') = pure $ Aeson.Bool boolean' -completeValue _ _ (Definition.Float float') = pure $ Aeson.toJSON float' -completeValue _ _ (Definition.Enum enum) = pure $ Aeson.String enum -completeValue _ _ (Definition.String string') = pure $ Aeson.String string' -completeValue (Out.ListBaseType listType) fields (Definition.List list) = - Aeson.toJSON <$> traverse (completeValue listType fields) list + -> NonEmpty (Transform.Field m) + -> Type.Value + -> CollectErrsT m 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 +completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) = + let Type.EnumType _ _ enumMembers = enumType + in if HashMap.member enum enumMembers + then coerceResult outputType $ Enum enum + else errmsg "Value completion failed." completeValue (Out.ObjectBaseType objectType) fields result = executeSelectionSet result objectType $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result - | Definition.Object objectMap <- result = do - abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap - case abstractType of + | Type.Object objectMap <- result = do + let abstractType = AbstractInterfaceType interfaceType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of Just objectType -> executeSelectionSet result objectType $ mergeSelectionSets fields Nothing -> errmsg "Value completion failed." completeValue (Out.UnionBaseType unionType) fields result - | Definition.Object objectMap <- result = do - abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap - case abstractType of + | Type.Object objectMap <- result = do + let abstractType = AbstractUnionType unionType + concreteType <- resolveAbstractType abstractType objectMap + case concreteType of Just objectType -> executeSelectionSet result objectType $ mergeSelectionSets fields Nothing -> errmsg "Value completion failed." completeValue _ _ _ = errmsg "Value completion failed." -mergeSelectionSets :: Monad m => NonEmpty (Field m) -> Seq (Selection m) -mergeSelectionSets fields = foldr forEach mempty fields +mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m) +mergeSelectionSets = foldr forEach mempty where - forEach (Field _ _ _ fieldSelectionSet) selectionSet = + forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet = selectionSet <> fieldSelectionSet -errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value -errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null +errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a +errmsg errorMessage = addErrMsg errorMessage >> pure null --- | Takes an 'Out.ObjectType' and a list of 'Selection's and applies each field --- to each 'Selection'. Resolves into a value containing the resolved --- 'Selection', or a null value and error information. -executeSelectionSet :: Monad m - => Definition.Value +coerceResult :: (Monad m, Serialize a) + => Out.Type m + -> Output a + -> CollectErrsT m a +coerceResult outputType result + | Just serialized <- serialize outputType result = pure serialized + | otherwise = errmsg "Result coercion failed." + +-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies +-- each field to each 'Transform.Selection'. Resolves into a value containing +-- the resolved 'Transform.Selection', or a null value and error information. +executeSelectionSet :: (Monad m, Serialize a) + => Type.Value -> Out.ObjectType m - -> Seq (Selection m) - -> CollectErrsT m Aeson.Value + -> Seq (Transform.Selection m) + -> CollectErrsT m a executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do let fields = collectFields objectType selectionSet resolvedValues <- Map.traverseMaybeWithKey forEach fields - pure $ Aeson.toJSON resolvedValues + coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues where forEach _ fields@(field :| _) = - let Field _ name _ _ = field + let Transform.Field _ name _ _ = field in traverse (tryResolver fields) $ lookupResolver name lookupResolver = flip HashMap.lookup resolvers tryResolver fields resolver = @@ -175,35 +195,35 @@ executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selection coerceArgumentValues :: HashMap Name In.Argument - -> HashMap Name Input - -> Maybe Definition.Subs + -> HashMap Name Transform.Input + -> Maybe Type.Subs coerceArgumentValues argumentDefinitions argumentValues = HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions where forEach variableName (In.Argument _ variableType defaultValue) = matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue - coerceArgumentValue inputType (Int integer) = - coerceInputLiteral inputType (Definition.Int integer) - coerceArgumentValue inputType (Boolean boolean) = - coerceInputLiteral inputType (Definition.Boolean boolean) - coerceArgumentValue inputType (String string) = - coerceInputLiteral inputType (Definition.String string) - coerceArgumentValue inputType (Float float) = - coerceInputLiteral inputType (Definition.Float float) - coerceArgumentValue inputType (Enum enum) = - coerceInputLiteral inputType (Definition.Enum enum) - coerceArgumentValue inputType Null + coerceArgumentValue inputType (Transform.Int integer) = + coerceInputLiteral inputType (Type.Int integer) + coerceArgumentValue inputType (Transform.Boolean boolean) = + coerceInputLiteral inputType (Type.Boolean boolean) + coerceArgumentValue inputType (Transform.String string) = + coerceInputLiteral inputType (Type.String string) + coerceArgumentValue inputType (Transform.Float float) = + coerceInputLiteral inputType (Type.Float float) + coerceArgumentValue inputType (Transform.Enum enum) = + coerceInputLiteral inputType (Type.Enum enum) + coerceArgumentValue inputType Transform.Null | In.isNonNullType inputType = Nothing - | otherwise = coerceInputLiteral inputType Definition.Null - coerceArgumentValue (In.ListBaseType inputType) (List list) = + | otherwise = coerceInputLiteral inputType Type.Null + coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) = let coerceItem = coerceInputLiteral inputType - in Definition.List <$> traverse coerceItem list - coerceArgumentValue (In.InputObjectBaseType inputType) (Object object) + in Type.List <$> traverse coerceItem list + coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object) | In.InputObjectType _ _ inputFields <- inputType = let go = forEachField object resultMap = HashMap.foldrWithKey go (pure mempty) inputFields - in Definition.Object <$> resultMap - coerceArgumentValue _ (Variable variable) = pure variable + in Type.Object <$> resultMap + coerceArgumentValue _ (Transform.Variable variable) = pure variable coerceArgumentValue _ _ = Nothing forEachField object variableName (In.InputField _ variableType defaultValue) = matchFieldValues coerceArgumentValue object variableName variableType defaultValue |