-- | Postgres Execute Types
--
-- Execution context and source configuration for Postgres databases.
-- Provides support for things such as read-only transactions and read replicas.
module Hasura.Backends.Postgres.Execute.Types
  ( PGExecCtx (..),
    PGExecFrom (..),
    PGExecCtxInfo (..),
    PGExecTxType (..),
    mkPGExecCtx,
    mkTxErrorHandler,
    defaultTxErrorHandler,
    dmlTxErrorHandler,
    resizePostgresPool,
    PostgresResolvedConnectionTemplate (..),

    -- * Execution in a Postgres Source
    PGSourceConfig (..),
    ConnectionTemplateConfig (..),
    connectionTemplateConfigResolver,
    ConnectionTemplateResolver (..),
    runPgSourceReadTx,
    runPgSourceWriteTx,
    applyConnectionTemplateResolverNonAdmin,
    pgResolveConnectionTemplate,
    resolvePostgresConnectionTemplate,
    sourceConfigNumReadReplicas,
    sourceConfigConnectonTemplateEnabled,
  )
where

import Control.Lens
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Data.Aeson.Extended qualified as J
import Data.CaseInsensitive qualified as CI
import Data.Has
import Data.HashMap.Internal.Strict qualified as Map
import Data.List.NonEmpty qualified as List.NonEmpty
import Database.PG.Query qualified as PG
import Database.PG.Query.Connection qualified as PG
import Hasura.Backends.Postgres.Connection.Settings (ConnectionTemplate (..), PostgresConnectionSetMemberName)
import Hasura.Backends.Postgres.Execute.ConnectionTemplate
import Hasura.Backends.Postgres.SQL.Error
import Hasura.Base.Error
import Hasura.EncJSON (EncJSON, encJFromJValue)
import Hasura.Prelude
import Hasura.RQL.Types.ResizePool
import Hasura.RQL.Types.Roles (adminRoleName)
import Hasura.SQL.Types (ExtensionsSchema)
import Hasura.Session (SessionVariables, UserInfo (_uiRole, _uiSession), maybeRoleFromSessionVariables)
import Kriti.Error qualified as Kriti
import Network.HTTP.Types qualified as HTTP

-- See Note [Existentially Quantified Types]
type RunTx =
  forall m a. (MonadIO m, MonadBaseControl IO m) => PG.TxET QErr m a -> ExceptT QErr m a

data PGExecCtx = PGExecCtx
  { -- | Run a PG transaction using the information provided by PGExecCtxInfo
    PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx :: PGExecCtxInfo -> RunTx,
    -- | Destroy connection pools
    PGExecCtx -> IO ()
_pecDestroyConnections :: IO (),
    -- | Resize pools based on number of server instances and return the summary
    PGExecCtx -> ServerReplicas -> IO SourceResizePoolSummary
_pecResizePools :: ServerReplicas -> IO SourceResizePoolSummary
  }

-- | Holds the information required to exceute a PG transaction
data PGExecCtxInfo = PGExecCtxInfo
  { -- | The tranasction mode for executing the transaction
    PGExecCtxInfo -> PGExecTxType
_peciTxType :: PGExecTxType,
    -- | The level from where the PG transaction is being executed from
    PGExecCtxInfo -> PGExecFrom
_peciFrom :: PGExecFrom
  }

-- | The tranasction mode (isolation level, transaction access) for executing the
--   transaction
data PGExecTxType
  = -- | a transaction without an explicit tranasction block
    NoTxRead
  | -- | a transaction block with custom transaction access and isolation level.
    --  Choose defaultIsolationLevel defined in 'SourceConnConfiguration' if
    --  "Nothing" is provided for isolation level.
    Tx PG.TxAccess (Maybe PG.TxIsolation)

-- | The level from where the transaction is being run
data PGExecFrom
  = -- | transaction initated via a GraphQLRequest
    GraphQLQuery (Maybe PostgresResolvedConnectionTemplate)
  | -- | transaction initiated during run_sql
    RunSQLQuery
  | -- | custom transaction Hasura runs on the database. This is usually used in
    -- event_trigger and actions
    InternalRawQuery
  | -- | transactions initiated via other API's other than 'run_sql' in  /v1/query or
    -- /v2/query
    LegacyRQLQuery

-- | Creates a Postgres execution context for a single Postgres master pool
mkPGExecCtx :: PG.TxIsolation -> PG.PGPool -> ResizePoolStrategy -> PGExecCtx
mkPGExecCtx :: TxIsolation -> PGPool -> ResizePoolStrategy -> PGExecCtx
mkPGExecCtx TxIsolation
defaultIsoLevel PGPool
pool ResizePoolStrategy
resizeStrategy =
  PGExecCtx
    { _pecDestroyConnections :: IO ()
_pecDestroyConnections =
        -- \| Destroys connection pools
        PGPool -> IO ()
PG.destroyPGPool PGPool
pool,
      _pecResizePools :: ServerReplicas -> IO SourceResizePoolSummary
_pecResizePools = \ServerReplicas
serverReplicas ->
        -- \| Resize pools based on number of server instances
        case ResizePoolStrategy
resizeStrategy of
          ResizePoolStrategy
NeverResizePool -> SourceResizePoolSummary -> IO SourceResizePoolSummary
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SourceResizePoolSummary
noPoolsResizedSummary
          ResizePool Int
maxConnections -> Int -> ServerReplicas -> IO SourceResizePoolSummary
resizePostgresPool' Int
maxConnections ServerReplicas
serverReplicas,
      _pecRunTx :: PGExecCtxInfo -> RunTx
_pecRunTx = \case
        -- \| Run a read only statement without an explicit transaction block
        (PGExecCtxInfo PGExecTxType
NoTxRead PGExecFrom
_) -> PGPool -> TxET QErr m a -> ExceptT QErr m a
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m, FromPGConnErr e) =>
PGPool -> TxET e m a -> ExceptT e m a
PG.runTx' PGPool
pool
        -- \| Run a transaction
        (PGExecCtxInfo (Tx TxAccess
txAccess (Just TxIsolation
isolationLevel)) PGExecFrom
_) -> PGPool -> TxMode -> TxET QErr m a -> ExceptT QErr m a
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m, FromPGTxErr e,
 FromPGConnErr e) =>
PGPool -> TxMode -> TxET e m a -> ExceptT e m a
PG.runTx PGPool
pool (TxIsolation
isolationLevel, TxAccess -> Maybe TxAccess
forall a. a -> Maybe a
Just TxAccess
txAccess)
        (PGExecCtxInfo (Tx TxAccess
txAccess Maybe TxIsolation
Nothing) PGExecFrom
_) -> PGPool -> TxMode -> TxET QErr m a -> ExceptT QErr m a
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m, FromPGTxErr e,
 FromPGConnErr e) =>
PGPool -> TxMode -> TxET e m a -> ExceptT e m a
PG.runTx PGPool
pool (TxIsolation
defaultIsoLevel, TxAccess -> Maybe TxAccess
forall a. a -> Maybe a
Just TxAccess
txAccess)
    }
  where
    resizePostgresPool' :: Int -> ServerReplicas -> IO SourceResizePoolSummary
resizePostgresPool' Int
maxConnections ServerReplicas
serverReplicas = do
      -- Resize the pool
      PGPool -> Int -> ServerReplicas -> IO ()
resizePostgresPool PGPool
pool Int
maxConnections ServerReplicas
serverReplicas
      -- Return the summary. Only the primary pool is resized
      SourceResizePoolSummary -> IO SourceResizePoolSummary
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (SourceResizePoolSummary -> IO SourceResizePoolSummary)
-> SourceResizePoolSummary -> IO SourceResizePoolSummary
forall a b. (a -> b) -> a -> b
$ SourceResizePoolSummary
          { _srpsPrimaryResized :: Bool
_srpsPrimaryResized = Bool
True,
            _srpsReadReplicasResized :: Bool
_srpsReadReplicasResized = Bool
False,
            _srpsConnectionSet :: [Text]
_srpsConnectionSet = []
          }

-- | Resize Postgres pool by setting the number of connections equal to
-- allowed maximum connections across all server instances divided by
-- number of instances
resizePostgresPool :: PG.PGPool -> Int -> ServerReplicas -> IO ()
resizePostgresPool :: PGPool -> Int -> ServerReplicas -> IO ()
resizePostgresPool PGPool
pool Int
maxConnections ServerReplicas
serverReplicas =
  PGPool -> Int -> IO ()
PG.resizePGPool PGPool
pool (Int
maxConnections Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` ServerReplicas -> Int
getServerReplicasInt ServerReplicas
serverReplicas)

defaultTxErrorHandler :: PG.PGTxErr -> QErr
defaultTxErrorHandler :: PGTxErr -> QErr
defaultTxErrorHandler = (PGErrorType -> Bool) -> PGTxErr -> QErr
mkTxErrorHandler ((PGErrorType -> Bool) -> PGTxErr -> QErr)
-> (PGErrorType -> Bool) -> PGTxErr -> QErr
forall a b. (a -> b) -> a -> b
$ \case
  PGTransactionRollback Maybe (PGErrorCode PGTransactionRollback)
_ -> Bool
True
  PGErrorType
_ -> Bool
False

-- | Constructs a transaction error handler tailored for the needs of RQL's DML.
dmlTxErrorHandler :: PG.PGTxErr -> QErr
dmlTxErrorHandler :: PGTxErr -> QErr
dmlTxErrorHandler = (PGErrorType -> Bool) -> PGTxErr -> QErr
mkTxErrorHandler ((PGErrorType -> Bool) -> PGTxErr -> QErr)
-> (PGErrorType -> Bool) -> PGTxErr -> QErr
forall a b. (a -> b) -> a -> b
$ \case
  PGIntegrityConstraintViolation Maybe (PGErrorCode PGIntegrityConstraintViolation)
_ -> Bool
True
  PGDataException Maybe (PGErrorCode PGDataException)
_ -> Bool
True
  PGSyntaxErrorOrAccessRuleViolation (Just (PGErrorSpecific PGSyntaxErrorOrAccessRuleViolation
code)) ->
    PGSyntaxErrorOrAccessRuleViolation
code
      PGSyntaxErrorOrAccessRuleViolation
-> [PGSyntaxErrorOrAccessRuleViolation] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ PGSyntaxErrorOrAccessRuleViolation
PGUndefinedObject,
               PGSyntaxErrorOrAccessRuleViolation
PGInvalidColumnReference
             ]
  PGErrorType
_ -> Bool
False

-- | Constructs a transaction error handler given a predicate that determines which errors are
-- expected and should be reported to the user. All other errors are considered internal errors.
mkTxErrorHandler :: (PGErrorType -> Bool) -> PG.PGTxErr -> QErr
mkTxErrorHandler :: (PGErrorType -> Bool) -> PGTxErr -> QErr
mkTxErrorHandler PGErrorType -> Bool
isExpectedError PGTxErr
txe = QErr -> Maybe QErr -> QErr
forall a. a -> Maybe a -> a
fromMaybe QErr
unexpectedError Maybe QErr
expectedError
  where
    unexpectedError :: QErr
unexpectedError = (Text -> QErr
internalError Text
"database query error") {qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ PGTxErr -> Value
forall a. ToJSON a => a -> Value
J.toJSON PGTxErr
txe}
    expectedError :: Maybe QErr
expectedError =
      (Code -> Text -> QErr) -> (Code, Text) -> QErr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Code -> Text -> QErr
err400 ((Code, Text) -> QErr) -> Maybe (Code, Text) -> Maybe QErr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        PGStmtErrDetail
errorDetail <- PGTxErr -> Maybe PGStmtErrDetail
PG.getPGStmtErr PGTxErr
txe
        Text
message <- PGStmtErrDetail -> Maybe Text
PG.edMessage PGStmtErrDetail
errorDetail
        PGErrorType
errorType <- PGStmtErrDetail -> Maybe PGErrorType
pgErrorType PGStmtErrDetail
errorDetail
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ PGErrorType -> Bool
isExpectedError PGErrorType
errorType
        (Code, Text) -> Maybe (Code, Text)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Code, Text) -> Maybe (Code, Text))
-> (Code, Text) -> Maybe (Code, Text)
forall a b. (a -> b) -> a -> b
$ case PGErrorType
errorType of
          PGIntegrityConstraintViolation Maybe (PGErrorCode PGIntegrityConstraintViolation)
code ->
            let cv :: t -> (Code, t)
cv = (Code
ConstraintViolation,)
                customMessage :: Maybe (Code, Text)
customMessage =
                  (Maybe (PGErrorCode PGIntegrityConstraintViolation)
code Maybe (PGErrorCode PGIntegrityConstraintViolation)
-> Getting
     (First PGIntegrityConstraintViolation)
     (Maybe (PGErrorCode PGIntegrityConstraintViolation))
     PGIntegrityConstraintViolation
-> Maybe PGIntegrityConstraintViolation
forall s a. s -> Getting (First a) s a -> Maybe a
^? (PGErrorCode PGIntegrityConstraintViolation
 -> Const
      (First PGIntegrityConstraintViolation)
      (PGErrorCode PGIntegrityConstraintViolation))
-> Maybe (PGErrorCode PGIntegrityConstraintViolation)
-> Const
     (First PGIntegrityConstraintViolation)
     (Maybe (PGErrorCode PGIntegrityConstraintViolation))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((PGErrorCode PGIntegrityConstraintViolation
  -> Const
       (First PGIntegrityConstraintViolation)
       (PGErrorCode PGIntegrityConstraintViolation))
 -> Maybe (PGErrorCode PGIntegrityConstraintViolation)
 -> Const
      (First PGIntegrityConstraintViolation)
      (Maybe (PGErrorCode PGIntegrityConstraintViolation)))
-> ((PGIntegrityConstraintViolation
     -> Const
          (First PGIntegrityConstraintViolation)
          PGIntegrityConstraintViolation)
    -> PGErrorCode PGIntegrityConstraintViolation
    -> Const
         (First PGIntegrityConstraintViolation)
         (PGErrorCode PGIntegrityConstraintViolation))
-> Getting
     (First PGIntegrityConstraintViolation)
     (Maybe (PGErrorCode PGIntegrityConstraintViolation))
     PGIntegrityConstraintViolation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PGIntegrityConstraintViolation
 -> Const
      (First PGIntegrityConstraintViolation)
      PGIntegrityConstraintViolation)
-> PGErrorCode PGIntegrityConstraintViolation
-> Const
     (First PGIntegrityConstraintViolation)
     (PGErrorCode PGIntegrityConstraintViolation)
forall a1 a2 (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a1 (f a2) -> p (PGErrorCode a1) (f (PGErrorCode a2))
_PGErrorSpecific) Maybe PGIntegrityConstraintViolation
-> (PGIntegrityConstraintViolation -> (Code, Text))
-> Maybe (Code, Text)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                    PGIntegrityConstraintViolation
PGRestrictViolation -> Text -> (Code, Text)
forall {t}. t -> (Code, t)
cv Text
"Can not delete or update due to data being referred. "
                    PGIntegrityConstraintViolation
PGNotNullViolation -> Text -> (Code, Text)
forall {t}. t -> (Code, t)
cv Text
"Not-NULL violation. "
                    PGIntegrityConstraintViolation
PGForeignKeyViolation -> Text -> (Code, Text)
forall {t}. t -> (Code, t)
cv Text
"Foreign key violation. "
                    PGIntegrityConstraintViolation
PGUniqueViolation -> Text -> (Code, Text)
forall {t}. t -> (Code, t)
cv Text
"Uniqueness violation. "
                    PGIntegrityConstraintViolation
PGCheckViolation -> (Code
PermissionError, Text
"Check constraint violation. ")
                    PGIntegrityConstraintViolation
PGExclusionViolation -> Text -> (Code, Text)
forall {t}. t -> (Code, t)
cv Text
"Exclusion violation. "
             in (Code, Text)
-> ((Code, Text) -> (Code, Text))
-> Maybe (Code, Text)
-> (Code, Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Code
ConstraintViolation, Text
message) ((Text -> Text) -> (Code, Text) -> (Code, Text)
forall a b. (a -> b) -> (Code, a) -> (Code, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
message)) Maybe (Code, Text)
customMessage
          PGDataException Maybe (PGErrorCode PGDataException)
code -> case Maybe (PGErrorCode PGDataException)
code of
            Just (PGErrorSpecific PGDataException
PGInvalidEscapeSequence) -> (Code
BadRequest, Text
message)
            Maybe (PGErrorCode PGDataException)
_ -> (Code
DataException, Text
message)
          PGSyntaxErrorOrAccessRuleViolation Maybe (PGErrorCode PGSyntaxErrorOrAccessRuleViolation)
code -> (Code
ConstraintError,) (Text -> (Code, Text)) -> Text -> (Code, Text)
forall a b. (a -> b) -> a -> b
$ case Maybe (PGErrorCode PGSyntaxErrorOrAccessRuleViolation)
code of
            Just (PGErrorSpecific PGSyntaxErrorOrAccessRuleViolation
PGInvalidColumnReference) ->
              Text
"there is no unique or exclusion constraint on target column(s)"
            Maybe (PGErrorCode PGSyntaxErrorOrAccessRuleViolation)
_ -> Text
message
          PGTransactionRollback Maybe (PGErrorCode PGTransactionRollback)
code -> (Code
ConcurrentUpdate,) (Text -> (Code, Text)) -> Text -> (Code, Text)
forall a b. (a -> b) -> a -> b
$ case Maybe (PGErrorCode PGTransactionRollback)
code of
            Just (PGErrorSpecific PGTransactionRollback
PGSerializationFailure) ->
              Text
"serialization failure due to concurrent update"
            Maybe (PGErrorCode PGTransactionRollback)
_ -> Text
message

data ConnectionTemplateConfig
  = -- | Connection templates are disabled for Hasura CE
    ConnTemplate_NotApplicable
  | ConnTemplate_NotConfigured
  | ConnTemplate_Resolver ConnectionTemplateResolver

connectionTemplateConfigResolver :: ConnectionTemplateConfig -> Maybe ConnectionTemplateResolver
connectionTemplateConfigResolver :: ConnectionTemplateConfig -> Maybe ConnectionTemplateResolver
connectionTemplateConfigResolver = \case
  ConnectionTemplateConfig
ConnTemplate_NotApplicable -> Maybe ConnectionTemplateResolver
forall a. Maybe a
Nothing
  ConnectionTemplateConfig
ConnTemplate_NotConfigured -> Maybe ConnectionTemplateResolver
forall a. Maybe a
Nothing
  ConnTemplate_Resolver ConnectionTemplateResolver
resolver -> ConnectionTemplateResolver -> Maybe ConnectionTemplateResolver
forall a. a -> Maybe a
Just ConnectionTemplateResolver
resolver

-- | A hook to resolve connection template
newtype ConnectionTemplateResolver = ConnectionTemplateResolver
  { -- | Runs the connection template resolver.
    ConnectionTemplateResolver
-> forall (m :: * -> *).
   MonadError QErr m =>
   SessionVariables
   -> [Header]
   -> Maybe QueryContext
   -> m PostgresResolvedConnectionTemplate
_runResolver ::
      forall m.
      (MonadError QErr m) =>
      SessionVariables ->
      [HTTP.Header] ->
      Maybe QueryContext ->
      m PostgresResolvedConnectionTemplate
  }

data PGSourceConfig = PGSourceConfig
  { PGSourceConfig -> PGExecCtx
_pscExecCtx :: PGExecCtx,
    PGSourceConfig -> ConnInfo
_pscConnInfo :: PG.ConnInfo,
    PGSourceConfig -> Maybe (NonEmpty ConnInfo)
_pscReadReplicaConnInfos :: Maybe (NonEmpty PG.ConnInfo),
    PGSourceConfig -> IO ()
_pscPostDropHook :: IO (),
    PGSourceConfig -> ExtensionsSchema
_pscExtensionsSchema :: ExtensionsSchema,
    PGSourceConfig -> HashMap PostgresConnectionSetMemberName ConnInfo
_pscConnectionSet :: HashMap PostgresConnectionSetMemberName PG.ConnInfo,
    PGSourceConfig -> ConnectionTemplateConfig
_pscConnectionTemplateConfig :: ConnectionTemplateConfig
  }
  deriving ((forall x. PGSourceConfig -> Rep PGSourceConfig x)
-> (forall x. Rep PGSourceConfig x -> PGSourceConfig)
-> Generic PGSourceConfig
forall x. Rep PGSourceConfig x -> PGSourceConfig
forall x. PGSourceConfig -> Rep PGSourceConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PGSourceConfig -> Rep PGSourceConfig x
from :: forall x. PGSourceConfig -> Rep PGSourceConfig x
$cto :: forall x. Rep PGSourceConfig x -> PGSourceConfig
to :: forall x. Rep PGSourceConfig x -> PGSourceConfig
Generic)

instance Show PGSourceConfig where
  show :: PGSourceConfig -> String
show PGSourceConfig
_ = String
"(PGSourceConfig <details>)"

instance Eq PGSourceConfig where
  PGSourceConfig
lconf == :: PGSourceConfig -> PGSourceConfig -> Bool
== PGSourceConfig
rconf =
    (PGSourceConfig -> ConnInfo
_pscConnInfo PGSourceConfig
lconf, PGSourceConfig -> Maybe (NonEmpty ConnInfo)
_pscReadReplicaConnInfos PGSourceConfig
lconf, PGSourceConfig -> ExtensionsSchema
_pscExtensionsSchema PGSourceConfig
lconf, PGSourceConfig -> HashMap PostgresConnectionSetMemberName ConnInfo
_pscConnectionSet PGSourceConfig
lconf)
      (ConnInfo, Maybe (NonEmpty ConnInfo), ExtensionsSchema,
 HashMap PostgresConnectionSetMemberName ConnInfo)
-> (ConnInfo, Maybe (NonEmpty ConnInfo), ExtensionsSchema,
    HashMap PostgresConnectionSetMemberName ConnInfo)
-> Bool
forall a. Eq a => a -> a -> Bool
== (PGSourceConfig -> ConnInfo
_pscConnInfo PGSourceConfig
rconf, PGSourceConfig -> Maybe (NonEmpty ConnInfo)
_pscReadReplicaConnInfos PGSourceConfig
rconf, PGSourceConfig -> ExtensionsSchema
_pscExtensionsSchema PGSourceConfig
rconf, PGSourceConfig -> HashMap PostgresConnectionSetMemberName ConnInfo
_pscConnectionSet PGSourceConfig
rconf)

instance J.ToJSON PGSourceConfig where
  toJSON :: PGSourceConfig -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
J.toJSON (String -> Value)
-> (PGSourceConfig -> String) -> PGSourceConfig -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConnInfo -> String
forall a. Show a => a -> String
show (ConnInfo -> String)
-> (PGSourceConfig -> ConnInfo) -> PGSourceConfig -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGSourceConfig -> ConnInfo
_pscConnInfo

instance Has () PGSourceConfig where
  hasLens :: Lens PGSourceConfig ()
hasLens = (() -> f ()) -> PGSourceConfig -> f PGSourceConfig
forall a (f :: * -> *). Functor f => (() -> f ()) -> a -> f a
united

runPgSourceReadTx ::
  (MonadIO m, MonadBaseControl IO m) =>
  PGSourceConfig ->
  PG.TxET QErr m a ->
  m (Either QErr a)
runPgSourceReadTx :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
PGSourceConfig -> TxET QErr m a -> m (Either QErr a)
runPgSourceReadTx PGSourceConfig
psc = do
  let pgRunTx :: PGExecCtxInfo -> RunTx
pgRunTx = PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx (PGSourceConfig -> PGExecCtx
_pscExecCtx PGSourceConfig
psc)
  ExceptT QErr m a -> m (Either QErr a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m a -> m (Either QErr a))
-> (TxET QErr m a -> ExceptT QErr m a)
-> TxET QErr m a
-> m (Either QErr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGExecCtxInfo -> RunTx
pgRunTx (PGExecTxType -> PGExecFrom -> PGExecCtxInfo
PGExecCtxInfo PGExecTxType
NoTxRead PGExecFrom
InternalRawQuery)

runPgSourceWriteTx ::
  (MonadIO m, MonadBaseControl IO m) =>
  PGSourceConfig ->
  PGExecFrom ->
  PG.TxET QErr m a ->
  m (Either QErr a)
runPgSourceWriteTx :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
PGSourceConfig -> PGExecFrom -> TxET QErr m a -> m (Either QErr a)
runPgSourceWriteTx PGSourceConfig
psc PGExecFrom
pgExecFrom = do
  let pgRunTx :: PGExecCtxInfo -> RunTx
pgRunTx = PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx (PGSourceConfig -> PGExecCtx
_pscExecCtx PGSourceConfig
psc)
  ExceptT QErr m a -> m (Either QErr a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m a -> m (Either QErr a))
-> (TxET QErr m a -> ExceptT QErr m a)
-> TxET QErr m a
-> m (Either QErr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGExecCtxInfo -> RunTx
pgRunTx (PGExecTxType -> PGExecFrom -> PGExecCtxInfo
PGExecCtxInfo (TxAccess -> Maybe TxIsolation -> PGExecTxType
Tx TxAccess
PG.ReadWrite Maybe TxIsolation
forall a. Maybe a
Nothing) PGExecFrom
pgExecFrom)

-- | Resolve connection templates only for non-admin roles
applyConnectionTemplateResolverNonAdmin ::
  (MonadError QErr m) =>
  Maybe ConnectionTemplateResolver ->
  UserInfo ->
  [HTTP.Header] ->
  Maybe QueryContext ->
  m (Maybe PostgresResolvedConnectionTemplate)
applyConnectionTemplateResolverNonAdmin :: forall (m :: * -> *).
MonadError QErr m =>
Maybe ConnectionTemplateResolver
-> UserInfo
-> [Header]
-> Maybe QueryContext
-> m (Maybe PostgresResolvedConnectionTemplate)
applyConnectionTemplateResolverNonAdmin Maybe ConnectionTemplateResolver
connectionTemplateResolver UserInfo
userInfo [Header]
requestHeaders Maybe QueryContext
queryContext =
  if UserInfo -> RoleName
_uiRole UserInfo
userInfo RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
== RoleName
adminRoleName
    then Maybe PostgresResolvedConnectionTemplate
-> m (Maybe PostgresResolvedConnectionTemplate)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PostgresResolvedConnectionTemplate
forall a. Maybe a
Nothing
    else Maybe ConnectionTemplateResolver
-> SessionVariables
-> [Header]
-> Maybe QueryContext
-> m (Maybe PostgresResolvedConnectionTemplate)
forall (m :: * -> *).
MonadError QErr m =>
Maybe ConnectionTemplateResolver
-> SessionVariables
-> [Header]
-> Maybe QueryContext
-> m (Maybe PostgresResolvedConnectionTemplate)
applyConnectionTemplateResolver Maybe ConnectionTemplateResolver
connectionTemplateResolver (UserInfo -> SessionVariables
_uiSession UserInfo
userInfo) [Header]
requestHeaders Maybe QueryContext
queryContext

-- | Execute @'ConnectionTemplateResolver' with required parameters
applyConnectionTemplateResolver ::
  (MonadError QErr m) =>
  Maybe ConnectionTemplateResolver ->
  SessionVariables ->
  [HTTP.Header] ->
  Maybe QueryContext ->
  m (Maybe PostgresResolvedConnectionTemplate)
applyConnectionTemplateResolver :: forall (m :: * -> *).
MonadError QErr m =>
Maybe ConnectionTemplateResolver
-> SessionVariables
-> [Header]
-> Maybe QueryContext
-> m (Maybe PostgresResolvedConnectionTemplate)
applyConnectionTemplateResolver Maybe ConnectionTemplateResolver
connectionTemplateResolver SessionVariables
sessionVariables [Header]
requestHeaders Maybe QueryContext
queryContext =
  Maybe ConnectionTemplateResolver
-> (ConnectionTemplateResolver
    -> m PostgresResolvedConnectionTemplate)
-> m (Maybe PostgresResolvedConnectionTemplate)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe ConnectionTemplateResolver
connectionTemplateResolver ((ConnectionTemplateResolver
  -> m PostgresResolvedConnectionTemplate)
 -> m (Maybe PostgresResolvedConnectionTemplate))
-> (ConnectionTemplateResolver
    -> m PostgresResolvedConnectionTemplate)
-> m (Maybe PostgresResolvedConnectionTemplate)
forall a b. (a -> b) -> a -> b
$ \ConnectionTemplateResolver
resolver ->
    ConnectionTemplateResolver
-> forall (m :: * -> *).
   MonadError QErr m =>
   SessionVariables
   -> [Header]
   -> Maybe QueryContext
   -> m PostgresResolvedConnectionTemplate
_runResolver ConnectionTemplateResolver
resolver SessionVariables
sessionVariables [Header]
requestHeaders Maybe QueryContext
queryContext

pgResolveConnectionTemplate :: (MonadError QErr m) => PGSourceConfig -> RequestContext -> Maybe ConnectionTemplate -> m EncJSON
pgResolveConnectionTemplate :: forall (m :: * -> *).
MonadError QErr m =>
PGSourceConfig
-> RequestContext -> Maybe ConnectionTemplate -> m EncJSON
pgResolveConnectionTemplate PGSourceConfig
sourceConfig (RequestContext (RequestContextHeaders HashMap Text Text
headersMap) SessionVariables
sessionVariables Maybe QueryContext
queryContext) Maybe ConnectionTemplate
connectionTemplateMaybe = do
  ConnectionTemplateResolver
connectionTemplateResolver <-
    case Maybe ConnectionTemplate
connectionTemplateMaybe of
      Maybe ConnectionTemplate
Nothing ->
        case PGSourceConfig -> ConnectionTemplateConfig
_pscConnectionTemplateConfig PGSourceConfig
sourceConfig of
          ConnectionTemplateConfig
ConnTemplate_NotApplicable -> m ConnectionTemplateResolver
forall {a}. m a
connectionTemplateNotApplicableError
          ConnectionTemplateConfig
ConnTemplate_NotConfigured ->
            Code -> Text -> m ConnectionTemplateResolver
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
TemplateResolutionFailed Text
"Connection template not defined for the source"
          ConnTemplate_Resolver ConnectionTemplateResolver
resolver ->
            ConnectionTemplateResolver -> m ConnectionTemplateResolver
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnectionTemplateResolver
resolver
      Just ConnectionTemplate
connectionTemplate ->
        case PGSourceConfig -> ConnectionTemplateConfig
_pscConnectionTemplateConfig PGSourceConfig
sourceConfig of
          -- connection template is an enterprise edition only feature. `ConnTemplate_NotApplicable` error is thrown
          -- when community edition engine is used to test the connection template
          ConnectionTemplateConfig
ConnTemplate_NotApplicable -> m ConnectionTemplateResolver
forall {a}. m a
connectionTemplateNotApplicableError
          ConnectionTemplateConfig
_ -> ConnectionTemplateResolver -> m ConnectionTemplateResolver
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionTemplateResolver -> m ConnectionTemplateResolver)
-> ConnectionTemplateResolver -> m ConnectionTemplateResolver
forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *).
 MonadError QErr m =>
 SessionVariables
 -> [Header]
 -> Maybe QueryContext
 -> m PostgresResolvedConnectionTemplate)
-> ConnectionTemplateResolver
ConnectionTemplateResolver ((forall (m :: * -> *).
  MonadError QErr m =>
  SessionVariables
  -> [Header]
  -> Maybe QueryContext
  -> m PostgresResolvedConnectionTemplate)
 -> ConnectionTemplateResolver)
-> (forall (m :: * -> *).
    MonadError QErr m =>
    SessionVariables
    -> [Header]
    -> Maybe QueryContext
    -> m PostgresResolvedConnectionTemplate)
-> ConnectionTemplateResolver
forall a b. (a -> b) -> a -> b
$ \SessionVariables
sessionVariables' [Header]
reqHeaders Maybe QueryContext
queryContext' ->
            ConnectionTemplate
-> [PostgresConnectionSetMemberName]
-> SessionVariables
-> [Header]
-> Maybe QueryContext
-> m PostgresResolvedConnectionTemplate
forall (m :: * -> *).
MonadError QErr m =>
ConnectionTemplate
-> [PostgresConnectionSetMemberName]
-> SessionVariables
-> [Header]
-> Maybe QueryContext
-> m PostgresResolvedConnectionTemplate
resolvePostgresConnectionTemplate ConnectionTemplate
connectionTemplate (HashMap PostgresConnectionSetMemberName ConnInfo
-> [PostgresConnectionSetMemberName]
forall k v. HashMap k v -> [k]
Map.keys (PGSourceConfig -> HashMap PostgresConnectionSetMemberName ConnInfo
_pscConnectionSet PGSourceConfig
sourceConfig)) SessionVariables
sessionVariables' [Header]
reqHeaders Maybe QueryContext
queryContext'
  let headers :: [Header]
headers = ((Text, Text) -> Header) -> [(Text, Text)] -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
hName, Text
hVal) -> (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
txtToBs Text
hName), Text -> ByteString
txtToBs Text
hVal)) ([(Text, Text)] -> [Header]) -> [(Text, Text)] -> [Header]
forall a b. (a -> b) -> a -> b
$ HashMap Text Text -> [(Text, Text)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap Text Text
headersMap
  case SessionVariables -> Maybe RoleName
maybeRoleFromSessionVariables SessionVariables
sessionVariables of
    Maybe RoleName
Nothing -> Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
InvalidParams Text
"No `x-hasura-role` found in session variables. Please try again with non-admin 'x-hasura-role' in the session context."
    Just RoleName
roleName ->
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RoleName
roleName RoleName -> RoleName -> Bool
forall a. Eq a => a -> a -> Bool
== RoleName
adminRoleName) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
InvalidParams Text
"Only requests made with a non-admin context can resolve the connection template. Please try again with non-admin 'x-hasura-role' in the session context."
  PostgresResolvedConnectionTemplate
resolvedTemplate <- ConnectionTemplateResolver
-> forall (m :: * -> *).
   MonadError QErr m =>
   SessionVariables
   -> [Header]
   -> Maybe QueryContext
   -> m PostgresResolvedConnectionTemplate
_runResolver ConnectionTemplateResolver
connectionTemplateResolver SessionVariables
sessionVariables [Header]
headers Maybe QueryContext
queryContext
  EncJSON -> m EncJSON
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EncJSON -> m EncJSON) -> (Value -> EncJSON) -> Value -> m EncJSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (Value -> m EncJSON) -> Value -> m EncJSON
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
J.object [Key
"result" Key -> PostgresResolvedConnectionTemplate -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
J..= PostgresResolvedConnectionTemplate
resolvedTemplate]
  where
    connectionTemplateNotApplicableError :: m a
connectionTemplateNotApplicableError = Code -> Text -> m a
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotSupported Text
"Connection templating feature is enterprise edition only"

resolvePostgresConnectionTemplate ::
  (MonadError QErr m) =>
  ConnectionTemplate ->
  [PostgresConnectionSetMemberName] ->
  SessionVariables ->
  [HTTP.Header] ->
  Maybe QueryContext ->
  m (PostgresResolvedConnectionTemplate)
resolvePostgresConnectionTemplate :: forall (m :: * -> *).
MonadError QErr m =>
ConnectionTemplate
-> [PostgresConnectionSetMemberName]
-> SessionVariables
-> [Header]
-> Maybe QueryContext
-> m PostgresResolvedConnectionTemplate
resolvePostgresConnectionTemplate (ConnectionTemplate Int
_templateSrc KritiTemplate
connectionTemplate) [PostgresConnectionSetMemberName]
connectionSetMembers SessionVariables
sessionVariables [Header]
reqHeaders Maybe QueryContext
queryContext = do
  let requestContext :: RequestContext
requestContext = Maybe QueryContext
-> [Header] -> SessionVariables -> RequestContext
makeRequestContext Maybe QueryContext
queryContext [Header]
reqHeaders SessionVariables
sessionVariables
      connectionTemplateCtx :: PostgresConnectionTemplateContext
connectionTemplateCtx = RequestContext
-> [PostgresConnectionSetMemberName]
-> PostgresConnectionTemplateContext
makeConnectionTemplateContext RequestContext
requestContext [PostgresConnectionSetMemberName]
connectionSetMembers

  case PostgresConnectionTemplateContext
-> KritiTemplate -> Either EvalError Value
runKritiEval PostgresConnectionTemplateContext
connectionTemplateCtx KritiTemplate
connectionTemplate of
    Left EvalError
err ->
      let serializedErr :: SerializedError
serializedErr = EvalError -> SerializedError
forall e. SerializeError e => e -> SerializedError
Kriti.serialize EvalError
err
       in Code -> Text -> Value -> m PostgresResolvedConnectionTemplate
forall (m :: * -> *) a. QErrM m => Code -> Text -> Value -> m a
throw400WithDetail Code
TemplateResolutionFailed (Text
"Connection template evaluation failed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SerializedError -> Text
Kriti._message SerializedError
serializedErr) (SerializedError -> Value
forall a. ToJSON a => a -> Value
J.toJSON (SerializedError -> Value) -> SerializedError -> Value
forall a b. (a -> b) -> a -> b
$ SerializedError
serializedErr)
    Right Value
val -> (Value -> Parser PostgresResolvedConnectionTemplate)
-> Value -> m PostgresResolvedConnectionTemplate
forall (m :: * -> *) v a. QErrM m => (v -> Parser a) -> v -> m a
runAesonParser (forall a. FromJSON a => Value -> Parser a
J.parseJSON @PostgresResolvedConnectionTemplate) Value
val

sourceConfigNumReadReplicas :: PGSourceConfig -> Int
sourceConfigNumReadReplicas :: PGSourceConfig -> Int
sourceConfigNumReadReplicas =
  Int
-> (NonEmpty ConnInfo -> Int) -> Maybe (NonEmpty ConnInfo) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 NonEmpty ConnInfo -> Int
forall a. NonEmpty a -> Int
List.NonEmpty.length (Maybe (NonEmpty ConnInfo) -> Int)
-> (PGSourceConfig -> Maybe (NonEmpty ConnInfo))
-> PGSourceConfig
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGSourceConfig -> Maybe (NonEmpty ConnInfo)
_pscReadReplicaConnInfos

sourceConfigConnectonTemplateEnabled :: PGSourceConfig -> Bool
sourceConfigConnectonTemplateEnabled :: PGSourceConfig -> Bool
sourceConfigConnectonTemplateEnabled PGSourceConfig
pgSourceConfig =
  case PGSourceConfig -> ConnectionTemplateConfig
_pscConnectionTemplateConfig PGSourceConfig
pgSourceConfig of
    ConnectionTemplateConfig
ConnTemplate_NotApplicable -> Bool
False
    ConnectionTemplateConfig
ConnTemplate_NotConfigured -> Bool
False
    ConnTemplate_Resolver ConnectionTemplateResolver
_ -> Bool
True