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