{-# 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)