{-# 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 appSchema appResolvers =
  resultOr
    FailApp
    (App . AppData defaultConfig [] appResolvers)
    (validateSchema True defaultConfig appSchema)

data App event (m :: Type -> Type)
  = App {app :: AppData event m VALID}
  | FailApp {appErrors :: GQLErrors}

instance RenderGQL (App e m) where
  renderGQL App {app} = renderGQL app
  renderGQL FailApp {appErrors} = renderGQL $ A.encode $ toList appErrors

instance Monad m => Semigroup (App e m) where
  (FailApp err1) <> (FailApp err2) = FailApp (err1 <> err2)
  FailApp {appErrors} <> App {} = FailApp appErrors
  App {} <> FailApp {appErrors} = FailApp appErrors
  (App x) <> (App y) = resultOr FailApp App (stitch x y)

type APIConstraint = Schema VALID -> Operation VALID -> Either String ()

data AppData event (m :: Type -> Type) s = AppData
  { appConfig :: Config,
    constraints :: [APIConstraint],
    appResolvers :: RootResolverValue event m,
    appSchema :: Schema s
  }

instance RenderGQL (AppData e m s) where
  renderGQL = renderGQL . appSchema

instance Monad m => Stitching (AppData e m s) where
  stitch x y =
    AppData
      (appConfig y)
      (constraints x <> constraints y)
      <$> prop stitch appResolvers x y
      <*> prop stitch appSchema x y

checkConstraints :: Schema VALID -> Operation VALID -> [APIConstraint] -> GQLResult ()
checkConstraints appSchema validRequest constraints =
  either
    (throwError . fromString . ("API Constraint: " <>))
    (const $ pure ())
    (traverse (\f -> f appSchema validRequest) constraints)

runAppData ::
  (Monad m, ValidateSchema s) =>
  AppData event m s ->
  GQLRequest ->
  ResponseStream event m (Value VALID)
runAppData AppData {appConfig, appSchema, appResolvers, constraints} request = do
  validRequest <- validateReq constraints appSchema appConfig request
  runRootResolverValue appResolvers validRequest

validateReq ::
  ( Monad m,
    ValidateSchema s
  ) =>
  [APIConstraint] ->
  Schema s ->
  Config ->
  GQLRequest ->
  ResponseStream event m ResolverContext
validateReq constraints inputSchema config request = ResultT $
  pure $
    do
      validSchema <- validateSchema True config inputSchema
      schema <- internalSchema <:> validSchema
      operation <- parseRequestWith config validSchema request
      checkConstraints schema operation constraints
      pure
        ( [],
          ResolverContext
            { schema,
              config,
              operation,
              currentType =
                toAny $
                  fromMaybe
                    (AST.query schema)
                    (rootType (operationType operation) schema),
              currentSelection =
                Selection
                  { selectionName = "Root",
                    selectionArguments = empty,
                    selectionPosition = operationPosition operation,
                    selectionAlias = Nothing,
                    selectionContent = SelectionSet (operationSelection operation),
                    selectionDirectives = empty,
                    selectionOrigin = Nothing
                  }
            }
        )

rootType :: OperationType -> Schema s -> Maybe (AST.TypeDefinition AST.OBJECT s)
rootType OPERATION_QUERY = Just . AST.query
rootType OPERATION_MUTATION = mutation
rootType OPERATION_SUBSCRIPTION = subscription

stateless ::
  Functor m =>
  ResponseStream event m (Value VALID) ->
  m GQLResponse
stateless = fmap (renderResponse . fmap snd) . runResultT

runAppStream :: Monad m => App event m -> GQLRequest -> ResponseStream event m (Value VALID)
runAppStream App {app} = runAppData app
runAppStream FailApp {appErrors} = const $ throwErrors appErrors

runApp :: (MapAPI a b, Monad m) => App e m -> a -> m b
runApp app = mapAPI (stateless . runAppStream app)

mapApp :: (AppData e m VALID -> AppData e m VALID) -> App e m -> App e m
mapApp f App {app} =
  App {app = f app}
mapApp _ x = x

withDebugger :: App e m -> App e m
withDebugger = mapApp f
  where
    f AppData {appConfig = Config {..}, ..} = AppData {appConfig = Config {debug = True, ..}, ..}

withConstraint :: APIConstraint -> App e m -> App e m
withConstraint constraint = mapApp f
  where
    f AppData {..} = AppData {constraints = constraint : constraints, ..}

eitherSchema :: App event m -> Either [GQLError] ByteString
eitherSchema (App AppData {appSchema}) = Right (render appSchema)
eitherSchema (FailApp errors) = Left (toList errors)