{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Types.App ( App (..), AppData (..), withDebugger, mkApp, runApp, runAppStream, ) where import qualified Data.Aeson as A import Data.Morpheus.Ext.SemigroupM ((<:>)) import Data.Morpheus.Internal.Utils ( empty, failure, prop, ) import Data.Morpheus.Parser ( parseRequestWith, ) import Data.Morpheus.Rendering.RenderGQL ( RenderGQL (..), ) import Data.Morpheus.Schema.Schema (internalSchema) import Data.Morpheus.Schema.SchemaAPI (withSystemFields) import Data.Morpheus.Types.IO ( GQLRequest (..), GQLResponse, MapAPI (..), renderResponse, ) import Data.Morpheus.Types.Internal.AST ( GQLErrors, Operation (..), Schema (..), Schema (..), Selection (..), SelectionContent (..), VALID, Value, ) import Data.Morpheus.Types.Internal.Config ( Config (..), defaultConfig, ) import Data.Morpheus.Types.Internal.Resolving ( ResolverContext (..), ResponseStream, ResultT (..), RootResModel, cleanEvents, resultOr, runRootResModel, ) import Data.Morpheus.Types.Internal.Stitching (Stitching (..)) import Data.Morpheus.Validation.Document.Validation (ValidateSchema (..)) import Relude hiding (empty) mkApp :: ValidateSchema s => Schema s -> RootResModel e m -> App e m mkApp :: Schema s -> RootResModel e m -> App e m mkApp Schema s appSchema RootResModel e m appResolvers = (GQLErrors -> App e m) -> (Schema VALID -> App e m) -> Result () (Schema VALID) -> App e m forall a' a e. (GQLErrors -> a') -> (a -> a') -> Result e a -> a' resultOr GQLErrors -> App e m forall event (m :: * -> *). GQLErrors -> 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 -> RootResModel e m -> Schema VALID -> AppData e m VALID forall event (m :: * -> *) (s :: Stage). Config -> RootResModel event m -> Schema s -> AppData event m s AppData Config defaultConfig RootResModel e m appResolvers) (Bool -> Config -> Schema s -> Result () (Schema VALID) forall (s :: Stage). ValidateSchema s => Bool -> Config -> Schema s -> Result () (Schema VALID) validateSchema Bool True Config defaultConfig Schema s appSchema) data App event (m :: * -> *) = App {App event m -> AppData event m VALID app :: AppData event m VALID} | FailApp {App event m -> GQLErrors appErrors :: GQLErrors} instance RenderGQL (App e m) where render :: App e m -> Rendering render 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 render AppData e m VALID app render FailApp {GQLErrors appErrors :: GQLErrors appErrors :: forall event (m :: * -> *). App event m -> GQLErrors appErrors} = ByteString -> Rendering forall a. RenderGQL a => a -> Rendering render (GQLErrors -> ByteString forall a. ToJSON a => a -> ByteString A.encode GQLErrors appErrors) instance Monad m => Semigroup (App e m) where (FailApp GQLErrors err1) <> :: App e m -> App e m -> App e m <> (FailApp GQLErrors err2) = GQLErrors -> App e m forall event (m :: * -> *). GQLErrors -> App event m FailApp (GQLErrors err1 GQLErrors -> GQLErrors -> GQLErrors forall a. Semigroup a => a -> a -> a <> GQLErrors err2) FailApp {GQLErrors appErrors :: GQLErrors appErrors :: forall event (m :: * -> *). App event m -> GQLErrors appErrors} <> App {} = GQLErrors -> App e m forall event (m :: * -> *). GQLErrors -> App event m FailApp GQLErrors appErrors App {} <> FailApp {GQLErrors appErrors :: GQLErrors appErrors :: forall event (m :: * -> *). App event m -> GQLErrors appErrors} = GQLErrors -> App e m forall event (m :: * -> *). GQLErrors -> App event m FailApp GQLErrors appErrors (App AppData e m VALID x) <> (App AppData e m VALID y) = (GQLErrors -> App e m) -> (AppData e m VALID -> App e m) -> Result Any (AppData e m VALID) -> App e m forall a' a e. (GQLErrors -> a') -> (a -> a') -> Result e a -> a' resultOr GQLErrors -> App e m forall event (m :: * -> *). GQLErrors -> 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 Any (AppData e m VALID) forall a (m :: * -> *). (Stitching a, Monad m, Failure ValidationErrors m) => a -> a -> m a stitch AppData e m VALID x AppData e m VALID y) data AppData event (m :: * -> *) s = AppData { AppData event m s -> Config appConfig :: Config, AppData event m s -> RootResModel event m appResolvers :: RootResModel event m, AppData event m s -> Schema s appSchema :: Schema s } instance RenderGQL (AppData e m s) where render :: AppData e m s -> Rendering render = Schema s -> Rendering forall a. RenderGQL a => a -> Rendering render (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 -> RootResModel e m -> Schema s -> AppData e m s forall event (m :: * -> *) (s :: Stage). Config -> RootResModel 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) (RootResModel e m -> Schema s -> AppData e m s) -> m (RootResModel e m) -> m (Schema s -> AppData e m s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (RootResModel e m -> RootResModel e m -> m (RootResModel e m)) -> (AppData e m s -> RootResModel e m) -> AppData e m s -> AppData e m s -> m (RootResModel e m) forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop RootResModel e m -> RootResModel e m -> m (RootResModel e m) forall a (m :: * -> *). (Stitching a, Monad m, Failure ValidationErrors m) => a -> a -> m a stitch AppData e m s -> RootResModel e m forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResModel 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, Failure ValidationErrors 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, RootResModel event m appResolvers :: RootResModel event m appResolvers :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResModel 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 RootResModel event m resovers <- Schema VALID -> RootResModel event m -> ResultT (ResponseEvent event m) m (RootResModel event m) forall (m :: * -> *) e e'. Monad m => Schema VALID -> RootResModel e m -> ResultT e' m (RootResModel e m) withSystemFields (ResolverContext -> Schema VALID schema ResolverContext validRequest) RootResModel event m appResolvers RootResModel event m -> ResolverContext -> ResponseStream event m (Value VALID) forall (m :: * -> *) e. Monad m => RootResModel e m -> ResolverContext -> ResponseStream e m (Value VALID) runRootResModel RootResModel event m resovers 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 = ResultT () m ResolverContext -> ResponseStream event m ResolverContext forall (m :: * -> *) e a e'. Functor m => ResultT e m a -> ResultT e' m a cleanEvents (ResultT () m ResolverContext -> ResponseStream event m ResolverContext) -> ResultT () m ResolverContext -> ResponseStream event m ResolverContext forall a b. (a -> b) -> a -> b $ m (Result () ResolverContext) -> ResultT () m ResolverContext forall event (m :: * -> *) a. m (Result event a) -> ResultT event m a ResultT (m (Result () ResolverContext) -> ResultT () m ResolverContext) -> m (Result () ResolverContext) -> ResultT () m ResolverContext forall a b. (a -> b) -> a -> b $ Result () ResolverContext -> m (Result () ResolverContext) forall (f :: * -> *) a. Applicative f => a -> f a pure (Result () ResolverContext -> m (Result () ResolverContext)) -> Result () ResolverContext -> m (Result () ResolverContext) forall a b. (a -> b) -> a -> b $ do Schema VALID validSchema <- Bool -> Config -> Schema s -> Result () (Schema VALID) forall (s :: Stage). ValidateSchema s => Bool -> Config -> Schema s -> Result () (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 () (Schema VALID) forall (m :: * -> *) a. SemigroupM m a => a -> a -> m a <:> Schema VALID validSchema Operation VALID operation <- Config -> Schema VALID -> GQLRequest -> Eventless (Operation VALID) parseRequestWith Config config Schema VALID validSchema GQLRequest request ResolverContext -> Result () ResolverContext forall (f :: * -> *) a. Applicative f => a -> f a pure (ResolverContext -> Result () ResolverContext) -> ResolverContext -> Result () ResolverContext forall a b. (a -> b) -> a -> b $ ResolverContext :: Selection VALID -> Schema VALID -> Operation VALID -> TypeName -> Config -> 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, currentTypeName :: TypeName currentTypeName = TypeName "Root", 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 a coll. Collection a 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 = [] } } stateless :: Functor m => ResponseStream event m (Value VALID) -> m GQLResponse stateless :: ResponseStream event m (Value VALID) -> m GQLResponse stateless = (Result (ResponseEvent event m) (Value VALID) -> GQLResponse) -> m (Result (ResponseEvent event m) (Value VALID)) -> m GQLResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Result (ResponseEvent event m) (Value VALID) -> GQLResponse forall e. Result e (Value VALID) -> GQLResponse renderResponse (m (Result (ResponseEvent event m) (Value VALID)) -> m GQLResponse) -> (ResponseStream event m (Value VALID) -> m (Result (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 (ResponseEvent event m) (Value VALID)) forall event (m :: * -> *) a. ResultT event m a -> m (Result 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 {GQLErrors appErrors :: GQLErrors appErrors :: forall event (m :: * -> *). App event m -> GQLErrors 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 $ GQLErrors -> ResponseStream event m (Value VALID) forall error (f :: * -> *) v. Failure error f => error -> f v failure GQLErrors 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 validationMode :: Config -> VALIDATION_MODE debug :: Config -> Bool validationMode :: VALIDATION_MODE debug :: Bool ..}, Schema VALID RootResModel e m appSchema :: Schema VALID appResolvers :: RootResModel e m appSchema :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appResolvers :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResModel 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 -> RootResModel 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 RootResModel e m appSchema :: Schema VALID appResolvers :: RootResModel e m appSchema :: Schema VALID appResolvers :: RootResModel e m ..}, ..} withDebugger App e m x = App e m x