{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.Internal.Resolving.RootResolverValue ( runRootResolverValue, RootResolverValue (..), ) where import Control.Monad.Except (throwError) import Data.Aeson (FromJSON (..)) import Data.HashMap.Strict (adjust) import Data.Morpheus.App.Internal.Resolving.Event ( EventHandler (..), ) import Data.Morpheus.App.Internal.Resolving.MonadResolver import Data.Morpheus.App.Internal.Resolving.ResolveValue import Data.Morpheus.App.Internal.Resolving.Resolver ( Resolver, ResponseStream, ) import Data.Morpheus.App.Internal.Resolving.ResolverState ( ResolverState, toResolverStateT, ) import Data.Morpheus.App.Internal.Resolving.SchemaAPI (schemaAPI) import Data.Morpheus.App.Internal.Resolving.Types import Data.Morpheus.App.Internal.Resolving.Utils ( lookupResJSON, ) import Data.Morpheus.Types.Internal.AST ( MUTATION, Operation (..), OperationType (..), QUERY, SUBSCRIPTION, Schema (..), Selection, SelectionSet, TypeDefinition (typeName), TypeName, VALID, ValidValue, Value (..), ) import Relude hiding ( Show, empty, show, ) data RootResolverValue e m = RootResolverValue { forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m)), forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m)), forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)), forall e (m :: * -> *). RootResolverValue e m -> Maybe (Selection VALID -> ResolverState (Channel e)) channelMap :: Maybe (Selection VALID -> ResolverState (Channel e)) } | NamedResolversValue {forall e (m :: * -> *). RootResolverValue e m -> ResolverMap (Resolver QUERY e m) queryResolverMap :: ResolverMap (Resolver QUERY e m)} instance Monad m => FromJSON (RootResolverValue e m) where parseJSON :: Value -> Parser (RootResolverValue e m) parseJSON Value res = forall (f :: * -> *) a. Applicative f => a -> f a pure RootResolverValue { queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver = forall (f :: * -> *) (m :: * -> *). (ResolverMonad f, MonadReader ResolverContext m) => FieldName -> Value -> f (ObjectTypeResolver m) lookupResJSON FieldName "query" Value res, mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver = forall (f :: * -> *) (m :: * -> *). (ResolverMonad f, MonadReader ResolverContext m) => FieldName -> Value -> f (ObjectTypeResolver m) lookupResJSON FieldName "mutation" Value res, subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver = forall (f :: * -> *) (m :: * -> *). (ResolverMonad f, MonadReader ResolverContext m) => FieldName -> Value -> f (ObjectTypeResolver m) lookupResJSON FieldName "subscription" Value res, channelMap :: Maybe (Selection VALID -> ResolverState (Channel e)) channelMap = forall a. Maybe a Nothing } rootResolver :: (MonadResolver m) => ResolverState (ObjectTypeResolver m) -> SelectionSet VALID -> m ValidValue rootResolver :: forall (m :: * -> *). MonadResolver m => ResolverState (ObjectTypeResolver m) -> SelectionSet VALID -> m ValidValue rootResolver ResolverState (ObjectTypeResolver m) res SelectionSet VALID selection = do ObjectTypeResolver m root <- forall (m :: * -> *) a. MonadResolver m => ResolverState a -> m a liftState (forall (m :: * -> *) a e. Applicative m => ResolverState a -> ResolverStateT e m a toResolverStateT ResolverState (ObjectTypeResolver m) res) forall (m :: * -> *). MonadResolver m => ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue resolvePlainRoot ObjectTypeResolver m root SelectionSet VALID selection runRootResolverValue :: Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m (Value VALID) runRootResolverValue :: forall (m :: * -> *) e. Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m ValidValue runRootResolverValue RootResolverValue { ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver :: forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver, ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver :: forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver, ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver :: forall e (m :: * -> *). RootResolverValue e m -> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver, Maybe (Selection VALID -> ResolverState (Channel e)) channelMap :: Maybe (Selection VALID -> ResolverState (Channel e)) channelMap :: forall e (m :: * -> *). RootResolverValue e m -> Maybe (Selection VALID -> ResolverState (Channel e)) channelMap } ctx :: ResolverContext ctx@ResolverContext {operation :: ResolverContext -> Operation VALID operation = Operation {Maybe FieldName SelectionSet VALID OperationType Position Directives VALID VariableDefinitions VALID operationPosition :: forall (s :: Stage). Operation s -> Position operationType :: forall (s :: Stage). Operation s -> OperationType operationName :: forall (s :: Stage). Operation s -> Maybe FieldName operationArguments :: forall (s :: Stage). Operation s -> VariableDefinitions s operationDirectives :: forall (s :: Stage). Operation s -> Directives s operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s operationSelection :: SelectionSet VALID operationDirectives :: Directives VALID operationArguments :: VariableDefinitions VALID operationName :: Maybe FieldName operationType :: OperationType operationPosition :: Position ..}} = OperationType -> ResponseStream (MonadEvent (Resolver QUERY e m)) (MonadParam (Resolver QUERY e m)) ValidValue selectByOperation OperationType operationType where selectByOperation :: OperationType -> ResponseStream (MonadEvent (Resolver QUERY e m)) (MonadParam (Resolver QUERY e m)) ValidValue selectByOperation OperationType OPERATION_QUERY = forall (m :: * -> *). MonadResolver m => Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m))) -> m ValidValue -> ResolverContext -> ResponseStream (MonadEvent m) (MonadParam m) ValidValue runResolver Maybe (Selection VALID -> ResolverState (Channel e)) channelMap (forall (m :: * -> *). MonadResolver m => ResolverState (ObjectTypeResolver m) -> SelectionSet VALID -> m ValidValue rootResolver (forall (m :: * -> *). (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m withIntroFields forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ResolverState (ObjectTypeResolver (Resolver QUERY e m)) queryResolver) SelectionSet VALID operationSelection) ResolverContext ctx selectByOperation OperationType OPERATION_MUTATION = forall (m :: * -> *). MonadResolver m => Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m))) -> m ValidValue -> ResolverContext -> ResponseStream (MonadEvent m) (MonadParam m) ValidValue runResolver Maybe (Selection VALID -> ResolverState (Channel e)) channelMap (forall (m :: * -> *). MonadResolver m => ResolverState (ObjectTypeResolver m) -> SelectionSet VALID -> m ValidValue rootResolver ResolverState (ObjectTypeResolver (Resolver MUTATION e m)) mutationResolver SelectionSet VALID operationSelection) ResolverContext ctx selectByOperation OperationType OPERATION_SUBSCRIPTION = forall (m :: * -> *). MonadResolver m => Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m))) -> m ValidValue -> ResolverContext -> ResponseStream (MonadEvent m) (MonadParam m) ValidValue runResolver Maybe (Selection VALID -> ResolverState (Channel e)) channelMap (forall (m :: * -> *). MonadResolver m => ResolverState (ObjectTypeResolver m) -> SelectionSet VALID -> m ValidValue rootResolver ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m)) subscriptionResolver SelectionSet VALID operationSelection) ResolverContext ctx runRootResolverValue NamedResolversValue {ResolverMap (Resolver QUERY e m) queryResolverMap :: ResolverMap (Resolver QUERY e m) queryResolverMap :: forall e (m :: * -> *). RootResolverValue e m -> ResolverMap (Resolver QUERY e m) queryResolverMap} ctx :: ResolverContext ctx@ResolverContext {operation :: ResolverContext -> Operation VALID operation = Operation {Maybe FieldName SelectionSet VALID OperationType Position Directives VALID VariableDefinitions VALID operationSelection :: SelectionSet VALID operationDirectives :: Directives VALID operationArguments :: VariableDefinitions VALID operationName :: Maybe FieldName operationType :: OperationType operationPosition :: Position operationPosition :: forall (s :: Stage). Operation s -> Position operationType :: forall (s :: Stage). Operation s -> OperationType operationName :: forall (s :: Stage). Operation s -> Maybe FieldName operationArguments :: forall (s :: Stage). Operation s -> VariableDefinitions s operationDirectives :: forall (s :: Stage). Operation s -> Directives s operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s ..}} = OperationType -> ResponseStream (MonadEvent (Resolver QUERY e m)) (MonadParam (Resolver QUERY e m)) ValidValue selectByOperation OperationType operationType where selectByOperation :: OperationType -> ResponseStream (MonadEvent (Resolver QUERY e m)) (MonadParam (Resolver QUERY e m)) ValidValue selectByOperation OperationType OPERATION_QUERY = forall (m :: * -> *). MonadResolver m => Maybe (Selection VALID -> ResolverState (Channel (MonadEvent m))) -> m ValidValue -> ResolverContext -> ResponseStream (MonadEvent m) (MonadParam m) ValidValue runResolver forall a. Maybe a Nothing Resolver QUERY e m ValidValue queryResolver ResolverContext ctx where queryResolver :: Resolver QUERY e m ValidValue queryResolver = do TypeName name <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks (forall (a :: TypeCategory) (s :: Stage). TypeDefinition a s -> TypeName typeName forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (s :: Stage). Schema s -> TypeDefinition OBJECT s query forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolverContext -> Schema VALID schema) forall (m :: * -> *). MonadResolver m => TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue resolveNamedRoot TypeName name (forall (m :: * -> *). (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverMap m -> ResolverMap m withNamedIntroFields TypeName name ResolverMap (Resolver QUERY e m) queryResolverMap) SelectionSet VALID operationSelection selectByOperation OperationType _ = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "mutation and subscription is not supported for namedResolvers" withNamedIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverMap m -> ResolverMap m withNamedIntroFields :: forall (m :: * -> *). (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverMap m -> ResolverMap m withNamedIntroFields = forall k v. (Eq k, Hashable k) => (v -> v) -> k -> HashMap k v -> HashMap k v adjust forall {m :: * -> *}. (MonadOperation m ~ QUERY, MonadResolver m) => NamedResolver m -> NamedResolver m updateNamed where updateNamed :: NamedResolver m -> NamedResolver m updateNamed NamedResolver {TypeName NamedResolverFun m resolverFun :: forall (m :: * -> *). NamedResolver m -> NamedResolverFun m resolverName :: forall (m :: * -> *). NamedResolver m -> TypeName resolverFun :: NamedResolverFun m resolverName :: TypeName ..} = NamedResolver {resolverFun :: NamedResolverFun m resolverFun = forall a b. a -> b -> a const (forall {m :: * -> *}. (MonadOperation m ~ QUERY, MonadResolver m) => [NamedResolverResult m] -> [NamedResolverResult m] updateResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NamedResolverFun m resolverFun [ValidValue "ROOT"]), TypeName resolverName :: TypeName resolverName :: TypeName ..} where updateResult :: [NamedResolverResult m] -> [NamedResolverResult m] updateResult [NamedObjectResolver ObjectTypeResolver m obj] = [forall (m :: * -> *). ObjectTypeResolver m -> NamedResolverResult m NamedObjectResolver (forall (m :: * -> *). (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m withIntroFields ObjectTypeResolver m obj)] updateResult [NamedResolverResult m] value = [NamedResolverResult m] value withIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m withIntroFields :: forall (m :: * -> *). (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m withIntroFields (ObjectTypeResolver HashMap FieldName (m (ResolverValue m)) fields) = forall (m :: * -> *). HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m ObjectTypeResolver (HashMap FieldName (m (ResolverValue m)) fields forall a. Semigroup a => a -> a -> a <> forall (m :: * -> *). ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m)) objectFields forall (m :: * -> *). (MonadOperation m ~ QUERY, MonadResolver m) => ObjectTypeResolver m schemaAPI)