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