morpheus-graphql-app-0.28.2: src/Data/Morpheus/App/Internal/Resolving/ResolverState.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.ResolverState
  ( ResolverContext (..),
    ResolverStateT (..),
    resolverFailureMessage,
    clearStateResolverEvents,
    ResolverState,
    toResolverStateT,
    runResolverStateT,
    runResolverStateM,
    runResolverState,
    runResolverStateValueM,
    updateCurrentType,
    askFieldTypeName,
    inField,
    inSelectionField,
  )
where

import Control.Monad.Except (MonadError (..))
import Control.Monad.Trans.Reader (mapReaderT)
import Data.Morpheus.Core
  ( Config (..),
    RenderGQL,
    render,
  )
import Data.Morpheus.Internal.Ext
  ( GQLResult,
    PushEvents (..),
    Result,
    ResultT (..),
    cleanEvents,
  )
import Data.Morpheus.Internal.Utils (selectOr)
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    FieldDefinition (fieldType),
    FieldName,
    GQLError,
    Operation,
    Schema,
    Selection (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    TypeRef (typeConName),
    VALID,
    at,
    internal,
    isInternal,
    lookupDataType,
    msg,
  )
import Relude

data ResolverContext = ResolverContext
  { currentSelection :: Selection VALID,
    schema :: Schema VALID,
    operation :: Operation VALID,
    config :: Config,
    currentType :: TypeDefinition ANY VALID
  }
  deriving (Show)

updateCurrentType ::
  ( MonadReader ResolverContext m,
    MonadError GQLError m
  ) =>
  Maybe TypeName ->
  m a ->
  m a
updateCurrentType = maybe id setCurrentType

setCurrentType ::
  ( MonadReader ResolverContext m,
    MonadError GQLError m
  ) =>
  TypeName ->
  m a ->
  m a
setCurrentType name ma = do
  t <- asks (lookupDataType name . schema)
  maybe
    (const $ throwError $ internal "Unknown type \"" <> msg name <> "\".")
    (\currentType -> local (\ctx -> ctx {currentType}))
    t
    ma

fieldTypeName :: FieldName -> TypeDefinition ANY VALID -> Maybe TypeName
fieldTypeName name t = case typeContent t of
  (DataObject _ fs) -> selectOr Nothing (Just . typeConName . fieldType) name fs
  (DataInterface fs) -> selectOr Nothing (Just . typeConName . fieldType) name fs
  _ -> Nothing

inSelectionField :: (MonadReader ResolverContext m, MonadError GQLError m) => Selection VALID -> m b -> m b
inSelectionField selection m = do
  inField (selectionName selection)
    $ local (\ctx -> ctx {currentSelection = selection}) m

inField :: (MonadReader ResolverContext m, MonadError GQLError m) => FieldName -> m b -> m b
inField fieldName m = do
  fieldType <- askFieldTypeName fieldName
  updateCurrentType fieldType m

askFieldTypeName :: (MonadReader ResolverContext m) => FieldName -> m (Maybe TypeName)
askFieldTypeName name = asks (fieldTypeName name . currentType)

type ResolverState = ResolverStateT () Identity

runResolverStateT :: ResolverStateT e m a -> ResolverContext -> ResultT e m a
runResolverStateT = runReaderT . _runResolverStateT

runResolverStateM :: ResolverStateT e m a -> ResolverContext -> m (Result GQLError ([e], a))
runResolverStateM res = runResultT . runResolverStateT res

runResolverStateValueM :: (Functor m) => ResolverStateT e m a -> ResolverContext -> m (Result GQLError a)
runResolverStateValueM res = fmap (fmap snd) . runResolverStateM res

runResolverState :: ResolverState a -> ResolverContext -> GQLResult a
runResolverState res = fmap snd . runIdentity . runResolverStateM res

-- internal resolver state
newtype ResolverStateT event m a = ResolverStateT
  { _runResolverStateT :: ReaderT ResolverContext (ResultT event m) a
  }
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadReader ResolverContext
    )

instance MonadTrans (ResolverStateT e) where
  lift = ResolverStateT . lift . lift

instance (Monad m) => MonadError GQLError (ResolverStateT e m) where
  throwError err = do
    ctx <- asks id
    let f = if isInternal err then renderInternalResolverError ctx else resolverFailureMessage ctx
    ResolverStateT
      $ lift
      $ throwError
      $ f err
  catchError (ResolverStateT mx) f = ResolverStateT $ catchError mx (_runResolverStateT . f)

instance (Monad m) => PushEvents e (ResolverStateT e m) where
  pushEvents = ResolverStateT . lift . pushEvents

mapResolverState ::
  ( ResultT e m a ->
    ResultT e' m' a'
  ) ->
  ResolverStateT e m a ->
  ResolverStateT e' m' a'
mapResolverState f (ResolverStateT x) = ResolverStateT (mapReaderT f x)

toResolverStateT ::
  (Applicative m) =>
  ResolverState a ->
  ResolverStateT e m a
toResolverStateT = mapResolverState injectResult

injectResult ::
  (Applicative m) =>
  ResultT () Identity a ->
  ResultT e m a
injectResult (ResultT (Identity x)) =
  cleanEvents $ ResultT (pure x)

-- clear events and starts new resolver with different type of events but with same value
-- use properly. only if you know what you are doing
clearStateResolverEvents :: (Functor m) => ResolverStateT e m a -> ResolverStateT e' m a
clearStateResolverEvents = mapResolverState cleanEvents

resolverFailureMessage :: ResolverContext -> GQLError -> GQLError
resolverFailureMessage
  ctx@ResolverContext
    { currentSelection =
        Selection {selectionName, selectionPosition}
    }
  err =
    "Failure on Resolving Field "
      <> msg selectionName
      <> ": "
      <> err
      <> withInternalContext ctx
      `at` selectionPosition

renderInternalResolverError :: ResolverContext -> GQLError -> GQLError
renderInternalResolverError ctx@ResolverContext {currentSelection} err =
  internal
    $ (err <> ". " <> msg (renderContext ctx))
    `at` selectionPosition currentSelection

withInternalContext :: ResolverContext -> GQLError
withInternalContext ResolverContext {config = Config {debug = False}} = ""
withInternalContext resCTX = renderContext resCTX

renderContext :: ResolverContext -> GQLError
renderContext
  ResolverContext
    { currentSelection,
      schema,
      operation,
      currentType
    } =
    renderSection "Current Type" (typeName currentType)
      <> renderSection "Current Selection" currentSelection
      <> renderSection "OperationDefinition" operation
      <> renderSection "SchemaDefinition" schema

renderSection :: (RenderGQL a) => GQLError -> a -> GQLError
renderSection label content =
  "\n\n"
    <> label
    <> ":\n"
    <> line
    <> "\n\n"
    <> msg (render content)
    <> "\n\n"
  where
    line = stimes (50 :: Int) "-"