{-# 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, withConstraint, APIConstraint, ) where import Control.Monad.Except (throwError) 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 (GQLResult, (<:>)) 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 (..), 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 :: forall (s :: Stage) e (m :: * -> *). ValidateSchema s => Schema s -> RootResolverValue e m -> App e m mkApp Schema s appSchema RootResolverValue e m appResolvers = forall err a' a. (NonEmpty err -> a') -> (a -> a') -> Result err a -> a' resultOr forall event (m :: * -> *). GQLErrors -> App event m FailApp (forall event (m :: * -> *). AppData event m VALID -> App event m App forall b c a. (b -> c) -> (a -> b) -> a -> c . forall event (m :: * -> *) (s :: Stage). Config -> [APIConstraint] -> RootResolverValue event m -> Schema s -> AppData event m s AppData Config defaultConfig [] RootResolverValue e m appResolvers) (forall (s :: Stage). ValidateSchema s => Bool -> Config -> Schema s -> GQLResult (Schema VALID) validateSchema Bool True Config defaultConfig Schema s appSchema) data App event (m :: Type -> Type) = App {forall event (m :: * -> *). App event m -> AppData event m VALID app :: AppData event m VALID} | FailApp {forall event (m :: * -> *). App event m -> GQLErrors 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} = forall a. RenderGQL a => a -> Rendering renderGQL AppData e m VALID app renderGQL FailApp {GQLErrors appErrors :: GQLErrors appErrors :: forall event (m :: * -> *). App event m -> GQLErrors appErrors} = forall a. RenderGQL a => a -> Rendering renderGQL forall a b. (a -> b) -> a -> b $ forall a. ToJSON a => a -> ByteString A.encode forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t a -> [a] toList 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) = forall event (m :: * -> *). GQLErrors -> App event m FailApp (GQLErrors err1 forall a. Semigroup a => a -> a -> a <> GQLErrors err2) FailApp {GQLErrors appErrors :: GQLErrors appErrors :: forall event (m :: * -> *). App event m -> GQLErrors appErrors} <> App {} = forall event (m :: * -> *). GQLErrors -> App event m FailApp GQLErrors appErrors App {} <> FailApp {GQLErrors appErrors :: GQLErrors appErrors :: forall event (m :: * -> *). App event m -> GQLErrors appErrors} = forall event (m :: * -> *). GQLErrors -> App event m FailApp GQLErrors appErrors (App AppData e m VALID x) <> (App AppData e m VALID y) = forall err a' a. (NonEmpty err -> a') -> (a -> a') -> Result err a -> a' resultOr forall event (m :: * -> *). GQLErrors -> App event m FailApp forall event (m :: * -> *). AppData event m VALID -> App event m App (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) type APIConstraint = Schema VALID -> Operation VALID -> Either String () data AppData event (m :: Type -> Type) s = AppData { forall event (m :: * -> *) (s :: Stage). AppData event m s -> Config appConfig :: Config, forall event (m :: * -> *) (s :: Stage). AppData event m s -> [APIConstraint] constraints :: [APIConstraint], forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResolverValue event m appResolvers :: RootResolverValue event m, forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appSchema :: Schema s } instance RenderGQL (AppData e m s) where renderGQL :: AppData e m s -> Rendering renderGQL = forall a. RenderGQL a => a -> Rendering renderGQL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appSchema instance Monad m => Stitching (AppData e m s) where stitch :: forall (m :: * -> *). (Monad m, MonadError GQLError m) => AppData e m s -> AppData e m s -> m (AppData e m s) stitch AppData e m s x AppData e m s y = forall event (m :: * -> *) (s :: Stage). Config -> [APIConstraint] -> RootResolverValue event m -> Schema s -> AppData event m s AppData (forall event (m :: * -> *) (s :: Stage). AppData event m s -> Config appConfig AppData e m s y) (forall event (m :: * -> *) (s :: Stage). AppData event m s -> [APIConstraint] constraints AppData e m s x forall a. Semigroup a => a -> a -> a <> forall event (m :: * -> *) (s :: Stage). AppData event m s -> [APIConstraint] constraints AppData e m s y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch forall event (m :: * -> *) (s :: Stage). AppData event m s -> RootResolverValue event m appResolvers AppData e m s x AppData e m s y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> forall b (m :: * -> *) a. (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop forall a (m :: * -> *). (Stitching a, Monad m, MonadError GQLError m) => a -> a -> m a stitch forall event (m :: * -> *) (s :: Stage). AppData event m s -> Schema s appSchema AppData e m s x AppData e m s y checkConstraints :: Schema VALID -> Operation VALID -> [APIConstraint] -> GQLResult () checkConstraints :: Schema VALID -> Operation VALID -> [APIConstraint] -> GQLResult () checkConstraints Schema VALID appSchema Operation VALID validRequest [APIConstraint] constraints = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. IsString a => String -> a fromString forall b c a. (b -> c) -> (a -> b) -> a -> c . (String "API Constraint: " forall a. Semigroup a => a -> a -> a <>)) (forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure ()) (forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (\APIConstraint f -> APIConstraint f Schema VALID appSchema Operation VALID validRequest) [APIConstraint] constraints) runAppData :: (Monad m, ValidateSchema s) => AppData event m s -> GQLRequest -> ResponseStream event m (Value VALID) runAppData :: forall (m :: * -> *) (s :: Stage) event. (Monad m, ValidateSchema s) => 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, [APIConstraint] constraints :: [APIConstraint] constraints :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> [APIConstraint] constraints} GQLRequest request = do ResolverContext validRequest <- forall (m :: * -> *) (s :: Stage) event. (Monad m, ValidateSchema s) => [APIConstraint] -> Schema s -> Config -> GQLRequest -> ResponseStream event m ResolverContext validateReq [APIConstraint] constraints Schema s appSchema Config appConfig GQLRequest request 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 ) => [APIConstraint] -> Schema s -> Config -> GQLRequest -> ResponseStream event m ResolverContext validateReq :: forall (m :: * -> *) (s :: Stage) event. (Monad m, ValidateSchema s) => [APIConstraint] -> Schema s -> Config -> GQLRequest -> ResponseStream event m ResolverContext validateReq [APIConstraint] constraints Schema s inputSchema Config config GQLRequest request = forall event (m :: * -> *) a. m (Result GQLError ([event], a)) -> ResultT event m a ResultT forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ do Schema VALID validSchema <- forall (s :: Stage). ValidateSchema s => Bool -> Config -> Schema s -> GQLResult (Schema VALID) validateSchema Bool True Config config Schema s inputSchema Schema VALID schema <- forall (s :: Stage). Schema s internalSchema 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 Schema VALID -> Operation VALID -> [APIConstraint] -> GQLResult () checkConstraints Schema VALID schema Operation VALID operation [APIConstraint] constraints forall (f :: * -> *) a. Applicative f => a -> f a pure ( [], 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 = forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory) (s :: Stage). ToCategory a k ANY => a k s -> a ANY s toAny forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a -> a fromMaybe (forall (s :: Stage). Schema s -> TypeDefinition OBJECT s AST.query Schema VALID schema) (forall (s :: Stage). OperationType -> Schema s -> Maybe (TypeDefinition OBJECT s) rootType (forall (s :: Stage). Operation s -> OperationType operationType Operation VALID operation) Schema VALID schema), currentSelection :: Selection VALID currentSelection = Selection { selectionName :: FieldName selectionName = FieldName "Root", selectionArguments :: Arguments VALID selectionArguments = forall coll. Empty coll => coll empty, selectionPosition :: Position selectionPosition = forall (s :: Stage). Operation s -> Position operationPosition Operation VALID operation, selectionAlias :: Maybe FieldName selectionAlias = forall a. Maybe a Nothing, selectionContent :: SelectionContent VALID selectionContent = forall (s :: Stage). SelectionSet s -> SelectionContent s SelectionSet (forall (s :: Stage). Operation s -> SelectionSet s operationSelection Operation VALID operation), selectionDirectives :: Directives VALID selectionDirectives = forall coll. Empty coll => coll empty, selectionOrigin :: Maybe FragmentName selectionOrigin = forall a. Maybe a Nothing } } ) rootType :: OperationType -> Schema s -> Maybe (AST.TypeDefinition AST.OBJECT s) rootType :: forall (s :: Stage). OperationType -> Schema s -> Maybe (TypeDefinition OBJECT s) rootType OperationType OPERATION_QUERY = forall a. a -> Maybe a Just forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (s :: Stage). Schema s -> TypeDefinition OBJECT s AST.query rootType OperationType OPERATION_MUTATION = forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) mutation rootType OperationType OPERATION_SUBSCRIPTION = forall (s :: Stage). Schema s -> Maybe (TypeDefinition OBJECT s) subscription stateless :: Functor m => ResponseStream event m (Value VALID) -> m GQLResponse stateless :: forall (m :: * -> *) event. Functor m => ResponseStream event m (Value VALID) -> m GQLResponse stateless = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Result GQLError (Value VALID) -> GQLResponse renderResponse forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall a b. (a, b) -> b snd) forall b c a. (b -> c) -> (a -> b) -> a -> c . 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 :: forall (m :: * -> *) event. Monad m => 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} = 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} = forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b throwErrors GQLErrors appErrors runApp :: (MapAPI a b, Monad m) => App e m -> a -> m b runApp :: forall a b (m :: * -> *) e. (MapAPI a b, Monad m) => App e m -> a -> m b runApp App e m app = forall a b (m :: * -> *). (MapAPI a b, Applicative m) => (GQLRequest -> m GQLResponse) -> a -> m b mapAPI (forall (m :: * -> *) event. Functor m => ResponseStream event m (Value VALID) -> m GQLResponse stateless forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) event. Monad m => App event m -> GQLRequest -> ResponseStream event m (Value VALID) runAppStream App e m app) mapApp :: (AppData e m VALID -> AppData e m VALID) -> App e m -> App e m mapApp :: forall e (m :: * -> *). (AppData e m VALID -> AppData e m VALID) -> App e m -> App e m mapApp AppData e m VALID -> AppData e m VALID f App {AppData e m VALID app :: AppData e m VALID app :: forall event (m :: * -> *). App event m -> AppData event m VALID app} = App {app :: AppData e m VALID app = AppData e m VALID -> AppData e m VALID f AppData e m VALID app} mapApp AppData e m VALID -> AppData e m VALID _ App e m x = App e m x withDebugger :: App e m -> App e m withDebugger :: forall e (m :: * -> *). App e m -> App e m withDebugger = forall e (m :: * -> *). (AppData e m VALID -> AppData e m VALID) -> App e m -> App e m mapApp forall {event} {m :: * -> *} {s :: Stage}. AppData event m s -> AppData event m s f where f :: AppData event m s -> AppData event m s f 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 ..}, [APIConstraint] Schema s RootResolverValue event m appSchema :: Schema s appResolvers :: RootResolverValue event m constraints :: [APIConstraint] 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 constraints :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> [APIConstraint] ..} = AppData {appConfig :: Config appConfig = Config {debug :: Bool debug = Bool True, VALIDATION_MODE validationMode :: VALIDATION_MODE validationMode :: VALIDATION_MODE ..}, [APIConstraint] Schema s RootResolverValue event m appSchema :: Schema s appResolvers :: RootResolverValue event m constraints :: [APIConstraint] appSchema :: Schema s appResolvers :: RootResolverValue event m constraints :: [APIConstraint] ..} withConstraint :: APIConstraint -> App e m -> App e m withConstraint :: forall e (m :: * -> *). APIConstraint -> App e m -> App e m withConstraint APIConstraint constraint = forall e (m :: * -> *). (AppData e m VALID -> AppData e m VALID) -> App e m -> App e m mapApp forall {event} {m :: * -> *} {s :: Stage}. AppData event m s -> AppData event m s f where f :: AppData event m s -> AppData event m s f AppData {[APIConstraint] Config Schema s RootResolverValue event m appSchema :: Schema s appResolvers :: RootResolverValue event m constraints :: [APIConstraint] appConfig :: Config 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 constraints :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> [APIConstraint] appConfig :: forall event (m :: * -> *) (s :: Stage). AppData event m s -> Config ..} = AppData {constraints :: [APIConstraint] constraints = APIConstraint constraint forall a. a -> [a] -> [a] : [APIConstraint] constraints, Config Schema s RootResolverValue event m appSchema :: Schema s appResolvers :: RootResolverValue event m appConfig :: Config appSchema :: Schema s appResolvers :: RootResolverValue event m appConfig :: Config ..} eitherSchema :: App event m -> Either [GQLError] ByteString eitherSchema :: forall event (m :: * -> *). 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}) = forall a b. b -> Either a b Right (forall a. RenderGQL a => a -> ByteString render Schema VALID appSchema) eitherSchema (FailApp GQLErrors errors) = forall a b. a -> Either a b Left (forall (t :: * -> *) a. Foldable t => t a -> [a] toList GQLErrors errors)