{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# 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.Core (Config (..))
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 =
    RootResolverValue e m -> Parser (RootResolverValue e m)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      RootResolverValue
        { queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver = FieldName
-> Value -> ResolverState (ObjectTypeResolver (Resolver QUERY e m))
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 = FieldName
-> Value
-> ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
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 = FieldName
-> Value
-> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
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 = Maybe (Selection VALID -> ResolverState (Channel e))
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 <- ResolverState (ObjectTypeResolver m) -> m (ObjectTypeResolver m)
forall a. ResolverState a -> m a
forall (m :: * -> *) a. MonadResolver m => ResolverState a -> m a
liftState (ResolverState (ObjectTypeResolver m)
-> ResolverState (ObjectTypeResolver m)
forall (m :: * -> *) a e.
Applicative m =>
ResolverState a -> ResolverStateT e m a
toResolverStateT ResolverState (ObjectTypeResolver m)
res)
  ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue
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 :: forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver :: ResolverState (ObjectTypeResolver (Resolver QUERY e m))
queryResolver,
      ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver :: forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver :: ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
mutationResolver,
      ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver :: forall e (m :: * -> *).
RootResolverValue e m
-> ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver :: ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
subscriptionResolver,
      Maybe (Selection VALID -> ResolverState (Channel e))
channelMap :: forall e (m :: * -> *).
RootResolverValue e m
-> Maybe (Selection VALID -> ResolverState (Channel e))
channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))
channelMap
    }
  ctx :: ResolverContext
ctx@ResolverContext {operation :: ResolverContext -> Operation VALID
operation = Operation {Maybe FieldName
VariableDefinitions VALID
Directives VALID
Position
OperationType
SelectionSet VALID
operationPosition :: Position
operationType :: OperationType
operationName :: Maybe FieldName
operationArguments :: VariableDefinitions VALID
operationDirectives :: Directives VALID
operationSelection :: SelectionSet 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
..}, Config
config :: Config
config :: ResolverContext -> Config
config} =
    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 =
        Maybe
  (Selection VALID
   -> ResolverState (Channel (MonadEvent (Resolver QUERY e m))))
-> Resolver QUERY e m ValidValue
-> ResolverContext
-> ResponseStream
     (MonadEvent (Resolver QUERY e m))
     (MonadParam (Resolver QUERY e m))
     ValidValue
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))
Maybe
  (Selection VALID
   -> ResolverState (Channel (MonadEvent (Resolver QUERY e m))))
channelMap (ResolverState (ObjectTypeResolver (Resolver QUERY e m))
-> SelectionSet VALID -> Resolver QUERY e m ValidValue
forall (m :: * -> *).
MonadResolver m =>
ResolverState (ObjectTypeResolver m)
-> SelectionSet VALID -> m ValidValue
rootResolver (Config
-> (MonadResolver (Resolver QUERY e m),
    MonadOperation (Resolver QUERY e m) ~ QUERY) =>
   ObjectTypeResolver (Resolver QUERY e m)
   -> ObjectTypeResolver (Resolver QUERY e m)
forall (m :: * -> *).
Config
-> (MonadResolver m, MonadOperation m ~ QUERY) =>
   ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields Config
config (ObjectTypeResolver (Resolver QUERY e m)
 -> ObjectTypeResolver (Resolver QUERY e m))
-> ResolverState (ObjectTypeResolver (Resolver QUERY e m))
-> ResolverState (ObjectTypeResolver (Resolver QUERY e m))
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 =
        Maybe
  (Selection VALID
   -> ResolverState (Channel (MonadEvent (Resolver MUTATION e m))))
-> Resolver MUTATION e m ValidValue
-> ResolverContext
-> ResponseStream
     (MonadEvent (Resolver MUTATION e m))
     (MonadParam (Resolver MUTATION e m))
     ValidValue
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))
Maybe
  (Selection VALID
   -> ResolverState (Channel (MonadEvent (Resolver MUTATION e m))))
channelMap (ResolverState (ObjectTypeResolver (Resolver MUTATION e m))
-> SelectionSet VALID -> Resolver MUTATION e m ValidValue
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 =
        Maybe
  (Selection VALID
   -> ResolverState
        (Channel (MonadEvent (Resolver SUBSCRIPTION e m))))
-> Resolver SUBSCRIPTION e m ValidValue
-> ResolverContext
-> ResponseStream
     (MonadEvent (Resolver SUBSCRIPTION e m))
     (MonadParam (Resolver SUBSCRIPTION e m))
     ValidValue
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))
Maybe
  (Selection VALID
   -> ResolverState
        (Channel (MonadEvent (Resolver SUBSCRIPTION e m))))
channelMap (ResolverState (ObjectTypeResolver (Resolver SUBSCRIPTION e m))
-> SelectionSet VALID -> Resolver SUBSCRIPTION e m ValidValue
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 :: forall e (m :: * -> *).
RootResolverValue e m -> ResolverMap (Resolver QUERY e m)
queryResolverMap :: ResolverMap (Resolver QUERY e m)
queryResolverMap}
  ctx :: ResolverContext
ctx@ResolverContext {operation :: ResolverContext -> Operation VALID
operation = Operation {Maybe FieldName
VariableDefinitions VALID
Directives VALID
Position
OperationType
SelectionSet 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
operationPosition :: Position
operationType :: OperationType
operationName :: Maybe FieldName
operationArguments :: VariableDefinitions VALID
operationDirectives :: Directives VALID
operationSelection :: SelectionSet VALID
..}, Config
config :: ResolverContext -> Config
config :: Config
config} =
    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 = Maybe
  (Selection VALID
   -> ResolverState (Channel (MonadEvent (Resolver QUERY e m))))
-> Resolver QUERY e m ValidValue
-> ResolverContext
-> ResponseStream
     (MonadEvent (Resolver QUERY e m))
     (MonadParam (Resolver QUERY e m))
     ValidValue
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))
Maybe
  (Selection VALID
   -> ResolverState (Channel (MonadEvent (Resolver QUERY e m))))
forall a. Maybe a
Nothing Resolver QUERY e m ValidValue
queryResolver ResolverContext
ctx
        where
          queryResolver :: Resolver QUERY e m ValidValue
queryResolver = do
            TypeName
name <- (ResolverContext -> TypeName) -> Resolver QUERY e m TypeName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TypeDefinition OBJECT VALID -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName (TypeDefinition OBJECT VALID -> TypeName)
-> (ResolverContext -> TypeDefinition OBJECT VALID)
-> ResolverContext
-> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema VALID -> TypeDefinition OBJECT VALID
forall (s :: Stage). Schema s -> TypeDefinition OBJECT s
query (Schema VALID -> TypeDefinition OBJECT VALID)
-> (ResolverContext -> Schema VALID)
-> ResolverContext
-> TypeDefinition OBJECT VALID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> Schema VALID
schema)
            TypeName
-> ResolverMap (Resolver QUERY e m)
-> SelectionSet VALID
-> Resolver QUERY e m ValidValue
forall (m :: * -> *).
MonadResolver m =>
TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue
resolveNamedRoot TypeName
name (Config
-> TypeName
-> ResolverMap (Resolver QUERY e m)
-> ResolverMap (Resolver QUERY e m)
forall (m :: * -> *).
(MonadResolver m, MonadOperation m ~ QUERY) =>
Config -> TypeName -> ResolverMap m -> ResolverMap m
withNamedIntroFields Config
config TypeName
name ResolverMap (Resolver QUERY e m)
queryResolverMap) SelectionSet VALID
operationSelection
      selectByOperation OperationType
_ = GQLError -> ResultT (ResponseEvent e m) m ValidValue
forall a. GQLError -> ResultT (ResponseEvent e m) m a
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) => Config -> TypeName -> ResolverMap m -> ResolverMap m
withNamedIntroFields :: forall (m :: * -> *).
(MonadResolver m, MonadOperation m ~ QUERY) =>
Config -> TypeName -> ResolverMap m -> ResolverMap m
withNamedIntroFields Config
config = (NamedResolver m -> NamedResolver m)
-> TypeName
-> HashMap TypeName (NamedResolver m)
-> HashMap TypeName (NamedResolver m)
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
adjust NamedResolver m -> NamedResolver m
updateNamed
  where
    updateNamed :: NamedResolver m -> NamedResolver m
updateNamed NamedResolver {TypeName
NamedResolverFun m
resolverName :: TypeName
resolverFun :: NamedResolverFun m
resolverName :: forall (m :: * -> *). NamedResolver m -> TypeName
resolverFun :: forall (m :: * -> *). NamedResolver m -> NamedResolverFun m
..} = NamedResolver {resolverFun :: NamedResolverFun m
resolverFun = m [NamedResolverResult m] -> NamedResolverFun m
forall a b. a -> b -> a
const ([NamedResolverResult m] -> [NamedResolverResult m]
updateResult ([NamedResolverResult m] -> [NamedResolverResult m])
-> m [NamedResolverResult m] -> m [NamedResolverResult m]
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] = [ObjectTypeResolver m -> NamedResolverResult m
forall (m :: * -> *). ObjectTypeResolver m -> NamedResolverResult m
NamedObjectResolver (Config
-> (MonadResolver m, MonadOperation m ~ QUERY) =>
   ObjectTypeResolver m -> ObjectTypeResolver m
forall (m :: * -> *).
Config
-> (MonadResolver m, MonadOperation m ~ QUERY) =>
   ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields Config
config ObjectTypeResolver m
obj)]
        updateResult [NamedResolverResult m]
value = [NamedResolverResult m]
value

withIntroFields :: Config -> (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields :: forall (m :: * -> *).
Config
-> (MonadResolver m, MonadOperation m ~ QUERY) =>
   ObjectTypeResolver m -> ObjectTypeResolver m
withIntroFields Config
config (ObjectTypeResolver HashMap FieldName (m (ResolverValue m))
fields)
  | Config -> Bool
introspection Config
config = HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver (HashMap FieldName (m (ResolverValue m))
fields HashMap FieldName (m (ResolverValue m))
-> HashMap FieldName (m (ResolverValue m))
-> HashMap FieldName (m (ResolverValue m))
forall a. Semigroup a => a -> a -> a
<> ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
forall (m :: * -> *).
ObjectTypeResolver m -> HashMap FieldName (m (ResolverValue m))
objectFields ObjectTypeResolver m
forall (m :: * -> *).
(MonadOperation m ~ QUERY, MonadResolver m) =>
ObjectTypeResolver m
schemaAPI)
  | Bool
otherwise = HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
forall (m :: * -> *).
HashMap FieldName (m (ResolverValue m)) -> ObjectTypeResolver m
ObjectTypeResolver HashMap FieldName (m (ResolverValue m))
fields