-- | 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 (..),
    mkPGExecCtx,
    mkTxErrorHandler,
    defaultTxErrorHandler,
    dmlTxErrorHandler,

    -- * Execution in a Postgres Source
    PGSourceConfig (..),
    runPgSourceReadTx,
    runPgSourceWriteTx,
  )
where

import Control.Lens
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Data.Aeson.Extended qualified as J
import Database.PG.Query qualified as Q
import Database.PG.Query.Connection qualified as Q
import Hasura.Backends.Postgres.SQL.Error
import Hasura.Base.Error
import Hasura.Incremental (Cacheable (..))
import Hasura.Prelude
import Hasura.SQL.Types (ExtensionsSchema)

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

data PGExecCtx = PGExecCtx
  { -- | Run a Q.ReadOnly transaction
    PGExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
_pecRunReadOnly :: RunTx,
    -- | Run a read only statement without an explicit transaction block
    PGExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
_pecRunReadNoTx :: RunTx,
    -- | Run a Q.ReadWrite transaction
    PGExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
_pecRunReadWrite :: RunTx,
    -- | Destroys connection pools
    PGExecCtx -> IO ()
_pecDestroyConn :: (IO ())
  }

-- | Creates a Postgres execution context for a single Postgres master pool
mkPGExecCtx :: Q.TxIsolation -> Q.PGPool -> PGExecCtx
mkPGExecCtx :: TxIsolation -> PGPool -> PGExecCtx
mkPGExecCtx TxIsolation
isoLevel PGPool
pool =
  PGExecCtx :: (forall (m :: * -> *) a.
 (MonadIO m, MonadBaseControl IO m) =>
 TxET QErr m a -> ExceptT QErr m a)
-> (forall (m :: * -> *) a.
    (MonadIO m, MonadBaseControl IO m) =>
    TxET QErr m a -> ExceptT QErr m a)
-> (forall (m :: * -> *) a.
    (MonadIO m, MonadBaseControl IO m) =>
    TxET QErr m a -> ExceptT QErr m a)
-> IO ()
-> PGExecCtx
PGExecCtx
    { _pecRunReadOnly :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
TxET QErr m a -> ExceptT QErr m a
_pecRunReadOnly = (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
Q.runTx PGPool
pool (TxIsolation
isoLevel, TxAccess -> Maybe TxAccess
forall a. a -> Maybe a
Just TxAccess
Q.ReadOnly)),
      _pecRunReadNoTx :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
TxET QErr m a -> ExceptT QErr m a
_pecRunReadNoTx = (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
Q.runTx' PGPool
pool),
      _pecRunReadWrite :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
TxET QErr m a -> ExceptT QErr m a
_pecRunReadWrite = (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
Q.runTx PGPool
pool (TxIsolation
isoLevel, TxAccess -> Maybe TxAccess
forall a. a -> Maybe a
Just TxAccess
Q.ReadWrite)),
      _pecDestroyConn :: IO ()
_pecDestroyConn = PGPool -> IO ()
Q.destroyPGPool PGPool
pool
    }

defaultTxErrorHandler :: Q.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 :: Q.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 (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) -> Q.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
Q.getPGStmtErr PGTxErr
txe
        Text
message <- PGStmtErrDetail -> Maybe Text
Q.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 (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. Prism (Maybe a) (Maybe b) a 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. Prism (PGErrorCode a1) (PGErrorCode a2) a1 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 (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 PGSourceConfig = PGSourceConfig
  { PGSourceConfig -> PGExecCtx
_pscExecCtx :: PGExecCtx,
    PGSourceConfig -> ConnInfo
_pscConnInfo :: Q.ConnInfo,
    PGSourceConfig -> Maybe (NonEmpty ConnInfo)
_pscReadReplicaConnInfos :: Maybe (NonEmpty Q.ConnInfo),
    PGSourceConfig -> IO ()
_pscPostDropHook :: IO (),
    PGSourceConfig -> ExtensionsSchema
_pscExtensionsSchema :: ExtensionsSchema
  }
  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
$cto :: forall x. Rep PGSourceConfig x -> PGSourceConfig
$cfrom :: forall x. PGSourceConfig -> Rep PGSourceConfig x
Generic)

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)
      (ConnInfo, Maybe (NonEmpty ConnInfo), ExtensionsSchema)
-> (ConnInfo, Maybe (NonEmpty ConnInfo), ExtensionsSchema) -> 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)

instance Cacheable PGSourceConfig where
  unchanged :: Accesses -> PGSourceConfig -> PGSourceConfig -> Bool
unchanged Accesses
_ = PGSourceConfig -> PGSourceConfig -> Bool
forall a. Eq a => a -> a -> Bool
(==)

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

runPgSourceReadTx ::
  (MonadIO m, MonadBaseControl IO m) =>
  PGSourceConfig ->
  Q.TxET QErr m a ->
  m (Either QErr a)
runPgSourceReadTx :: PGSourceConfig -> TxET QErr m a -> m (Either QErr a)
runPgSourceReadTx 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
. PGExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
_pecRunReadNoTx (PGSourceConfig -> PGExecCtx
_pscExecCtx PGSourceConfig
psc)

runPgSourceWriteTx ::
  (MonadIO m, MonadBaseControl IO m) =>
  PGSourceConfig ->
  Q.TxET QErr m a ->
  m (Either QErr a)
runPgSourceWriteTx :: PGSourceConfig -> TxET QErr m a -> m (Either QErr a)
runPgSourceWriteTx 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
. PGExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
_pecRunReadWrite (PGSourceConfig -> PGExecCtx
_pscExecCtx PGSourceConfig
psc)