{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App ( Config (..), VALIDATION_MODE (..), defaultConfig, debugConfig, App (..), AppData (..), runApp, withDebugger, mkApp, runAppStream, MapAPI (..), eitherSchema, ) where import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Morpheus.App.Internal.Resolving ( ResolverContext (..), ResponseStream, ResultT (..), RootResolverValue, resultOr, runRootResolverValue, ) import Data.Morpheus.App.Internal.Stitching (Stitching (..)) import Data.Morpheus.App.MapAPI (MapAPI (..)) import Data.Morpheus.Core ( Config (..), RenderGQL (..), VALIDATION_MODE (..), ValidateSchema (..), debugConfig, defaultConfig, internalSchema, parseRequestWith, render, ) import Data.Morpheus.Internal.Ext ((<:>)) import Data.Morpheus.Internal.Utils ( empty, prop, throwErrors, ) import Data.Morpheus.Types.IO ( GQLRequest (..), GQLResponse, renderResponse, ) import Data.Morpheus.Types.Internal.AST ( GQLError, GQLErrors, Operation (..), OperationType (Mutation, Query, Subscription), Schema (..), Selection (..), SelectionContent (..), VALID, Value, toAny, ) import qualified Data.Morpheus.Types.Internal.AST as AST import Relude hiding (ByteString, empty) mkApp :: ValidateSchema s => Schema s -> RootResolverValue e m -> App e m mkApp :: Schema s -> RootResolverValue e m -> App e m mkApp Schema s appSchema RootResolverValue e m appResolvers = (NonEmpty GQLError -> App e m) -> (Schema VALID -> App e m) -> Result GQLError (Schema VALID) -> App e m forall err a' a. (NonEmpty err -> a') -> (a -> a') -> Result err a -> a' resultOr NonEmpty GQLError -> App e m forall event (m :: * -> *). NonEmpty GQLError -> App event m FailApp (AppData e m VALID -> App e m forall event (m :: * -> *). AppData event m VALID -> App event m App (AppData e m VALID -> App e m) -> (Schema VALID -> AppData e m VALID) -> Schema VALID -> App e m forall b c a. (b -> c) -> (a -> b) -> a -> c . Config -> RootResolverValue e m -> Schema VALID -> AppData e m VALID forall event (m :: * -> *) (s :: Stage). Config -> RootResolverValue event m -> Schema s -> AppData event m s AppData Config defaultConfig RootResolverValue e m appResolvers) (Bool -> Config -> Schema s -> Result GQLError (Schema VALID) forall (s :: Stage). ValidateSchema s => Bool -> Config -> Schema s -> Result GQLError (Schema VALID) validateSchema Bool True Config defaultConfig Schema s appSchema) data App event (m :: Type -> Type) = App {App event m -> AppData event m VALID app :: AppData event m VALID} | FailApp {App event m -> NonEmpty GQLError appErrors :: GQLErrors} instance RenderGQL (App e m) where renderGQL :: App e m -> Rendering renderGQL App {AppData e m VALID app :: AppData e m VALID app :: forall event (m :: * -> *). App event m -> AppData event m VALID app} = AppData e m VALID -> Rendering forall a. RenderGQL a => a -> Rendering renderGQL AppData e m VALID app renderGQL FailApp {NonEmpty GQLError appErrors :: NonEmpty GQLError appErrors :: forall event (m :: * -> *). App event m -> NonEmpty GQLError appErrors} = ByteString -> Rendering forall a. RenderGQL a => a -> Rendering renderGQL (ByteString -> Rendering) -> ByteString -> Rendering forall a b. (a -> b) -> a -> b $ [GQLError] -> ByteString forall a. ToJSON a => a -> ByteString A.encode ([GQLError] -> ByteString) -> [GQLError] -> ByteString forall a b. (a -> b) -> a -> b $ NonEmpty GQLError -> [GQLError] forall (t :: * -> *) a. Foldable t => t a -> [a] toList NonEmpty GQLError appErrors instance Monad m => Semigroup (App e m) where (FailApp NonEmpty GQLError err1) <> :: App e m -> App e m -> App e m <> (FailApp NonEmpty GQLError err2) = NonEmpty GQLError -> App e m forall event (m :: * -> *). NonEmpty GQLError -> App event m FailApp (NonEmpty GQLError err1 NonEmpty GQLError -> NonEmpty GQLError -> NonEmpty GQLError forall a. Semigroup a => a -> a -> a <> NonEmpty GQLError err2) FailApp {NonEmpty GQLError appErrors :: NonEmpty GQLError appErrors :: forall event (m :: * -> *). App event m -> NonEmpty GQLError appErrors} <> App {} = NonEmpty GQLError -> App e m forall event (m :: * -> *). NonEmpty GQLError -> App event m FailApp NonEmpty GQLError appErrors App {} <> FailApp {NonEmpty GQLError appErrors :: NonEmpty GQLError appErrors :: forall event (m :: * -> *). App event m -> NonEmpty GQLError appErrors} = NonEmpty GQLError -> App e m forall event (m :: * -> *). NonEmpty GQLError -> App event m FailApp NonEmpty GQLError appErrors (App AppData e m VALID x) <> (App AppData e m VALID y) = (NonEmpty GQLError -> App e m) -> (AppData e m VALID -> App e m) -> Result GQLError (AppData e m VALID) -> App e m forall err a' a. (NonEmpty err -> a') -> (a -> a') -> Result err a -> a' resultOr NonEmpty GQLError -> App e m forall event (m :: * -> *). NonEmpty GQLError -> App event m FailApp AppData e m VALID -> App e m forall event (m :: * -> *). AppData event m VALID -> App event m App (AppData e m VALID -> AppData e m VALID -> Result GQLError (AppData e m VALID) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch AppData e m VALID x AppData e m VALID y) data AppData event (m :: Type -> Type) s = AppData { AppData event m s -> Config appConfig :: Config, AppData event m s -> RootResolverValue event m appResolvers :: RootResolverValue event m, AppData event m s -> Schema s appSchema :: Schema s } instance RenderGQL (AppData e m s) where renderGQL :: AppData e m s -> Rendering renderGQL = Schema s -> Rendering forall a. RenderGQL a => a -> Rendering renderGQL (Schema s -> Rendering) -> (AppData e m s -> Schema s) -> AppData e m s -> Rendering forall b c a. (b -> c) -> (a -> b) -> a -> c . AppData e m s -> Schema s forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appSchema instance Monad m => Stitching (AppData e m s) where stitch :: AppData e m s -> AppData e m s -> m (AppData e m s) stitch AppData e m s x AppData e m s y = Config -> RootResolverValue e m -> Schema s -> AppData e m s forall event (m :: * -> *) (s :: Stage). Config -> RootResolverValue event m -> Schema s -> AppData event m s AppData (AppData e m s -> Config forall event (m :: * -> *) (s :: Stage). AppData event m s -> Config appConfig AppData e m s y) (RootResolverValue e m -> Schema s -> AppData e m s) -> m (RootResolverValue e m) -> m (Schema s -> AppData e m s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (RootResolverValue e m -> RootResolverValue e m -> m (RootResolverValue e m)) -> (AppData e m s -> RootResolverValue e m) -> AppData e m s -> AppData e m s -> m (RootResolverValue e m) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop RootResolverValue e m -> RootResolverValue e m -> m (RootResolverValue e m) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch AppData e m s -> RootResolverValue e m forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResolverValue event m appResolvers AppData e m s x AppData e m s y m (Schema s -> AppData e m s) -> m (Schema s) -> m (AppData e m s) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> (Schema s -> Schema s -> m (Schema s)) -> (AppData e m s -> Schema s) -> AppData e m s -> AppData e m s -> m (Schema s) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop Schema s -> Schema s -> m (Schema s) forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch AppData e m s -> Schema s forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appSchema AppData e m s x AppData e m s y runAppData :: (Monad m, ValidateSchema s) => AppData event m s -> GQLRequest -> ResponseStream event m (Value VALID) runAppData :: AppData event m s -> GQLRequest -> ResponseStream event m (Value VALID) runAppData AppData {Config appConfig :: Config appConfig :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> Config appConfig, Schema s appSchema :: Schema s appSchema :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appSchema, RootResolverValue event m appResolvers :: RootResolverValue event m appResolvers :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResolverValue event m appResolvers} GQLRequest request = do ResolverContext validRequest <- Schema s -> Config -> GQLRequest -> ResponseStream event m ResolverContext forall (m :: * -> *) (s :: Stage) event. (Monad m, ValidateSchema s) => Schema s -> Config -> GQLRequest -> ResponseStream event m ResolverContext validateReq Schema s appSchema Config appConfig GQLRequest request RootResolverValue event m -> ResolverContext -> ResponseStream event m (Value VALID) forall (m :: * -> *) e. Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m (Value VALID) runRootResolverValue RootResolverValue event m appResolvers ResolverContext validRequest validateReq :: ( Monad m, ValidateSchema s ) => Schema s -> Config -> GQLRequest -> ResponseStream event m ResolverContext validateReq :: Schema s -> Config -> GQLRequest -> ResponseStream event m ResolverContext validateReq Schema s inputSchema Config config GQLRequest request = m (Result GQLError ([ResponseEvent event m], ResolverContext)) -> ResponseStream event m ResolverContext forall event (m :: * -> *) a. m (Result GQLError ([event], a)) -> ResultT event m a ResultT (m (Result GQLError ([ResponseEvent event m], ResolverContext)) -> ResponseStream event m ResolverContext) -> m (Result GQLError ([ResponseEvent event m], ResolverContext)) -> ResponseStream event m ResolverContext forall a b. (a -> b) -> a -> b $ Result GQLError ([ResponseEvent event m], ResolverContext) -> m (Result GQLError ([ResponseEvent event m], ResolverContext)) forall (f :: * -> *) a. Applicative f => a -> f a pure (Result GQLError ([ResponseEvent event m], ResolverContext) -> m (Result GQLError ([ResponseEvent event m], ResolverContext))) -> Result GQLError ([ResponseEvent event m], ResolverContext) -> m (Result GQLError ([ResponseEvent event m], ResolverContext)) forall a b. (a -> b) -> a -> b $ do Schema VALID validSchema <- Bool -> Config -> Schema s -> Result GQLError (Schema VALID) forall (s :: Stage). ValidateSchema s => Bool -> Config -> Schema s -> Result GQLError (Schema VALID) validateSchema Bool True Config config Schema s inputSchema Schema VALID schema <- Schema VALID forall (s :: Stage). Schema s internalSchema Schema VALID -> Schema VALID -> Result GQLError (Schema VALID) forall (m :: * -> *) a. (Merge (HistoryT m) a, Monad m) => a -> a -> m a <:> Schema VALID validSchema Operation VALID operation <- Config -> Schema VALID -> GQLRequest -> GQLResult (Operation VALID) parseRequestWith Config config Schema VALID validSchema GQLRequest request ([ResponseEvent event m], ResolverContext) -> Result GQLError ([ResponseEvent event m], ResolverContext) forall (f :: * -> *) a. Applicative f => a -> f a pure ( [], ResolverContext :: Selection VALID -> Schema VALID -> Operation VALID -> Config -> TypeDefinition ANY VALID -> ResolverContext ResolverContext { Schema VALID schema :: Schema VALID schema :: Schema VALID schema, Config config :: Config config :: Config config, Operation VALID operation :: Operation VALID operation :: Operation VALID operation, currentType :: TypeDefinition ANY VALID currentType = TypeDefinition OBJECT VALID -> TypeDefinition ANY VALID forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory) (s :: Stage). ToCategory a k ANY => a k s -> a ANY s toAny (TypeDefinition OBJECT VALID -> TypeDefinition ANY VALID) -> TypeDefinition OBJECT VALID -> TypeDefinition ANY VALID forall a b. (a -> b) -> a -> b $ TypeDefinition OBJECT VALID -> Maybe (TypeDefinition OBJECT VALID) -> TypeDefinition OBJECT VALID forall a. a -> Maybe a -> a fromMaybe (Schema VALID -> TypeDefinition OBJECT VALID forall (s :: Stage). Schema s -> TypeDefinition OBJECT s AST.query Schema VALID schema) (OperationType -> Schema VALID -> Maybe (TypeDefinition OBJECT VALID) forall (s :: Stage). OperationType -> Schema s -> Maybe (TypeDefinition OBJECT s) rootType (Operation VALID -> OperationType forall (s :: Stage). Operation s -> OperationType operationType Operation VALID operation) Schema VALID schema), currentSelection :: Selection VALID currentSelection = Selection :: forall (s :: Stage). Position -> Maybe FieldName -> FieldName -> Arguments s -> Directives s -> SelectionContent s -> Selection s Selection { selectionName :: FieldName selectionName = FieldName "Root", selectionArguments :: Arguments VALID selectionArguments = Arguments VALID forall coll. Empty coll => coll empty, selectionPosition :: Position selectionPosition = Operation VALID -> Position forall (s :: Stage). Operation s -> Position operationPosition Operation VALID operation, selectionAlias :: Maybe FieldName selectionAlias = Maybe FieldName forall a. Maybe a Nothing, selectionContent :: SelectionContent VALID selectionContent = SelectionSet VALID -> SelectionContent VALID forall (s :: Stage). SelectionSet s -> SelectionContent s SelectionSet (Operation VALID -> SelectionSet VALID forall (s :: Stage). Operation s -> SelectionSet s operationSelection Operation VALID operation), selectionDirectives :: Directives VALID selectionDirectives = Directives VALID forall coll. Empty coll => coll empty } } ) rootType :: OperationType -> Schema s -> Maybe (AST.TypeDefinition AST.OBJECT s) rootType :: OperationType -> Schema s -> Maybe (TypeDefinition OBJECT s) rootType OperationType Query = TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s) forall a. a -> Maybe a Just (TypeDefinition OBJECT s -> Maybe (TypeDefinition OBJECT s)) -> (Schema s -> TypeDefinition OBJECT s) -> Schema s -> Maybe (TypeDefinition OBJECT s) forall b c a. (b -> c) -> (a -> b) -> a -> c . Schema s -> TypeDefinition OBJECT s forall (s :: Stage). Schema s -> TypeDefinition OBJECT s AST.query rootType OperationType Mutation = Schema s -> Maybe (TypeDefinition OBJECT s) forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) mutation rootType OperationType Subscription = Schema s -> Maybe (TypeDefinition OBJECT s) forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) subscription stateless :: Functor m => ResponseStream event m (Value VALID) -> m GQLResponse stateless :: ResponseStream event m (Value VALID) -> m GQLResponse stateless = (Result GQLError ([ResponseEvent event m], Value VALID) -> GQLResponse) -> m (Result GQLError ([ResponseEvent event m], Value VALID)) -> m GQLResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Result GQLError (Value VALID) -> GQLResponse renderResponse (Result GQLError (Value VALID) -> GQLResponse) -> (Result GQLError ([ResponseEvent event m], Value VALID) -> Result GQLError (Value VALID)) -> Result GQLError ([ResponseEvent event m], Value VALID) -> GQLResponse forall b c a. (b -> c) -> (a -> b) -> a -> c . (([ResponseEvent event m], Value VALID) -> Value VALID) -> Result GQLError ([ResponseEvent event m], Value VALID) -> Result GQLError (Value VALID) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ([ResponseEvent event m], Value VALID) -> Value VALID forall a b. (a, b) -> b snd) (m (Result GQLError ([ResponseEvent event m], Value VALID)) -> m GQLResponse) -> (ResponseStream event m (Value VALID) -> m (Result GQLError ([ResponseEvent event m], Value VALID))) -> ResponseStream event m (Value VALID) -> m GQLResponse forall b c a. (b -> c) -> (a -> b) -> a -> c . ResponseStream event m (Value VALID) -> m (Result GQLError ([ResponseEvent event m], Value VALID)) forall event (m :: * -> *) a. ResultT event m a -> m (Result GQLError ([event], a)) runResultT runAppStream :: Monad m => App event m -> GQLRequest -> ResponseStream event m (Value VALID) runAppStream :: App event m -> GQLRequest -> ResponseStream event m (Value VALID) runAppStream App {AppData event m VALID app :: AppData event m VALID app :: forall event (m :: * -> *). App event m -> AppData event m VALID app} = AppData event m VALID -> GQLRequest -> ResponseStream event m (Value VALID) forall (m :: * -> *) (s :: Stage) event. (Monad m, ValidateSchema s) => AppData event m s -> GQLRequest -> ResponseStream event m (Value VALID) runAppData AppData event m VALID app runAppStream FailApp {NonEmpty GQLError appErrors :: NonEmpty GQLError appErrors :: forall event (m :: * -> *). App event m -> NonEmpty GQLError appErrors} = ResponseStream event m (Value VALID) -> GQLRequest -> ResponseStream event m (Value VALID) forall a b. a -> b -> a const (ResponseStream event m (Value VALID) -> GQLRequest -> ResponseStream event m (Value VALID)) -> ResponseStream event m (Value VALID) -> GQLRequest -> ResponseStream event m (Value VALID) forall a b. (a -> b) -> a -> b $ NonEmpty GQLError -> ResponseStream event m (Value VALID) forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b throwErrors NonEmpty GQLError appErrors runApp :: (MapAPI a b, Monad m) => App e m -> a -> m b runApp :: App e m -> a -> m b runApp App e m app = (GQLRequest -> m GQLResponse) -> a -> m b forall a b (m :: * -> *). (MapAPI a b, Applicative m) => (GQLRequest -> m GQLResponse) -> a -> m b mapAPI (ResponseStream e m (Value VALID) -> m GQLResponse forall (m :: * -> *) event. Functor m => ResponseStream event m (Value VALID) -> m GQLResponse stateless (ResponseStream e m (Value VALID) -> m GQLResponse) -> (GQLRequest -> ResponseStream e m (Value VALID)) -> GQLRequest -> m GQLResponse forall b c a. (b -> c) -> (a -> b) -> a -> c . App e m -> GQLRequest -> ResponseStream e m (Value VALID) forall (m :: * -> *) event. Monad m => App event m -> GQLRequest -> ResponseStream event m (Value VALID) runAppStream App e m app) withDebugger :: App e m -> App e m withDebugger :: App e m -> App e m withDebugger App {app :: forall event (m :: * -> *). App event m -> AppData event m VALID app = AppData {appConfig :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> Config appConfig = Config {Bool VALIDATION_MODE debug :: Config -> Bool validationMode :: Config -> VALIDATION_MODE validationMode :: VALIDATION_MODE debug :: Bool ..}, Schema VALID RootResolverValue e m appSchema :: Schema VALID appResolvers :: RootResolverValue e m appSchema :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appResolvers :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResolverValue event m ..}} = App :: forall event (m :: * -> *). AppData event m VALID -> App event m App {app :: AppData e m VALID app = AppData :: forall event (m :: * -> *) (s :: Stage). Config -> RootResolverValue event m -> Schema s -> AppData event m s AppData {appConfig :: Config appConfig = Config :: Bool -> VALIDATION_MODE -> Config Config {debug :: Bool debug = Bool True, VALIDATION_MODE validationMode :: VALIDATION_MODE validationMode :: VALIDATION_MODE ..}, Schema VALID RootResolverValue e m appSchema :: Schema VALID appResolvers :: RootResolverValue e m appSchema :: Schema VALID appResolvers :: RootResolverValue e m ..}, ..} withDebugger App e m x = App e m x eitherSchema :: App event m -> Either [GQLError] ByteString eitherSchema :: App event m -> Either [GQLError] ByteString eitherSchema (App AppData {Schema VALID appSchema :: Schema VALID appSchema :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appSchema}) = ByteString -> Either [GQLError] ByteString forall a b. b -> Either a b Right (Schema VALID -> ByteString forall a. RenderGQL a => a -> ByteString render Schema VALID appSchema) eitherSchema (FailApp NonEmpty GQLError errors) = [GQLError] -> Either [GQLError] ByteString forall a b. a -> Either a b Left (NonEmpty GQLError -> [GQLError] forall (t :: * -> *) a. Foldable t => t a -> [a] toList NonEmpty GQLError errors)