{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Postgres Connection MonadTx
--
-- This module contains 'MonadTx' and related combinators.
--
-- 'MonadTx', a class which abstracts the 'QErr' in 'Q.TxE' via 'MonadError'.
--
-- The combinators are used for running, tracing, or otherwise perform database
-- related tasks. Please consult the individual documentation for more
-- information.
module Hasura.Backends.Postgres.Connection.MonadTx
  ( MonadTx (..),
    runTxWithCtx,
    runTxWithCtxAndUserInfo,
    runQueryTx,
    withUserInfo,
    withTraceContext,
    setHeadersTx,
    setTraceContextInTx,
    sessionInfoJsonExp,
    checkDbConnection,
    doesSchemaExist,
    doesTableExist,
    enablePgcryptoExtension,
    dropHdbCatalogSchema,
    ExtensionsSchema (..),
  )
where

import Control.Monad.Morph (hoist)
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Validate
import Data.Aeson
import Data.Aeson.Extended
import Data.Time.Clock.Compat ()
import Database.PG.Query qualified as PG
import Database.PG.Query.Connection qualified as PG
import Hasura.Backends.Postgres.Execute.Types as ET
import Hasura.Backends.Postgres.SQL.DML qualified as S
import Hasura.Backends.Postgres.SQL.Types
import Hasura.Base.Error
import Hasura.Base.Instances ()
import Hasura.Prelude
import Hasura.SQL.Types
import Hasura.Session
import Hasura.Tracing qualified as Tracing
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Instances.Time ()

class (MonadError QErr m) => MonadTx m where
  liftTx :: PG.TxE QErr a -> m a

instance (MonadTx m) => MonadTx (StateT s m) where
  liftTx :: forall a. TxE QErr a -> StateT s m a
liftTx = m a -> StateT s m a
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx

instance (MonadTx m) => MonadTx (ReaderT s m) where
  liftTx :: forall a. TxE QErr a -> ReaderT s m a
liftTx = m a -> ReaderT s m a
forall (m :: * -> *) a. Monad m => m a -> ReaderT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT s m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> ReaderT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx

instance (Monoid w, MonadTx m) => MonadTx (WriterT w m) where
  liftTx :: forall a. TxE QErr a -> WriterT w m a
liftTx = m a -> WriterT w m a
forall (m :: * -> *) a. Monad m => m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> WriterT w m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx

instance (MonadTx m) => MonadTx (ValidateT e m) where
  liftTx :: forall a. TxE QErr a -> ValidateT e m a
liftTx = m a -> ValidateT e m a
forall (m :: * -> *) a. Monad m => m a -> ValidateT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ValidateT e m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> ValidateT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx

instance (MonadTx m) => MonadTx (Tracing.TraceT m) where
  liftTx :: forall a. TxE QErr a -> TraceT m a
liftTx = m a -> TraceT m a
forall (m :: * -> *) a. Monad m => m a -> TraceT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TraceT m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> TraceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx

instance (MonadIO m) => MonadTx (PG.TxET QErr m) where
  liftTx :: forall a. TxE QErr a -> TxET QErr m a
liftTx = (forall a. IO a -> m a) -> TxET QErr IO a -> TxET QErr m a
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> TxET QErr m b -> TxET QErr n b
hoist IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

runTxWithCtx ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadError QErr m,
    Tracing.MonadTrace m,
    UserInfoM m
  ) =>
  PGExecCtx ->
  PGExecTxType ->
  PGExecFrom ->
  PG.TxET QErr m a ->
  m a
runTxWithCtx :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m, MonadTrace m,
 UserInfoM m) =>
PGExecCtx -> PGExecTxType -> PGExecFrom -> TxET QErr m a -> m a
runTxWithCtx PGExecCtx
pgExecCtx PGExecTxType
pgExecTxType PGExecFrom
pgExecFrom TxET QErr m a
tx = do
  UserInfo
userInfo <- m UserInfo
forall (m :: * -> *). UserInfoM m => m UserInfo
askUserInfo
  UserInfo
-> PGExecCtx -> PGExecTxType -> PGExecFrom -> TxET QErr m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
UserInfo
-> PGExecCtx -> PGExecTxType -> PGExecFrom -> TxET QErr m a -> m a
runTxWithCtxAndUserInfo UserInfo
userInfo PGExecCtx
pgExecCtx PGExecTxType
pgExecTxType PGExecFrom
pgExecFrom TxET QErr m a
tx

runTxWithCtxAndUserInfo ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadError QErr m,
    Tracing.MonadTrace m
  ) =>
  UserInfo ->
  PGExecCtx ->
  PGExecTxType ->
  PGExecFrom ->
  PG.TxET QErr m a ->
  m a
runTxWithCtxAndUserInfo :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
UserInfo
-> PGExecCtx -> PGExecTxType -> PGExecFrom -> TxET QErr m a -> m a
runTxWithCtxAndUserInfo UserInfo
userInfo PGExecCtx
pgExecCtx PGExecTxType
pgExecTxType PGExecFrom
pgExecFrom TxET QErr m a
tx = do
  Maybe TraceContext
traceCtx <- m (Maybe TraceContext)
forall (m :: * -> *). MonadTrace m => m (Maybe TraceContext)
Tracing.currentContext
  m (Either QErr a) -> m a
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM
    (m (Either QErr a) -> m a) -> m (Either QErr a) -> m a
forall a b. (a -> b) -> a -> b
$ 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))
-> ExceptT QErr m a -> m (Either QErr a)
forall a b. (a -> b) -> a -> b
$ (PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx PGExecCtx
pgExecCtx) (PGExecTxType -> PGExecFrom -> PGExecCtxInfo
PGExecCtxInfo PGExecTxType
pgExecTxType PGExecFrom
pgExecFrom)
    (TxET QErr m a -> ExceptT QErr m a)
-> TxET QErr m a -> ExceptT QErr m a
forall a b. (a -> b) -> a -> b
$ Maybe TraceContext -> TxET QErr m a -> TxET QErr m a
forall (m :: * -> *) a.
MonadIO m =>
Maybe TraceContext -> TxET QErr m a -> TxET QErr m a
withTraceContext Maybe TraceContext
traceCtx
    (TxET QErr m a -> TxET QErr m a) -> TxET QErr m a -> TxET QErr m a
forall a b. (a -> b) -> a -> b
$ UserInfo -> TxET QErr m a -> TxET QErr m a
forall (m :: * -> *) a.
MonadIO m =>
UserInfo -> TxET QErr m a -> TxET QErr m a
withUserInfo UserInfo
userInfo TxET QErr m a
tx

-- | This runs the given set of statements (Tx) without wrapping them in BEGIN
-- and COMMIT. This should only be used for running a single statement query!
runQueryTx ::
  ( MonadIO m,
    MonadBaseControl IO m,
    MonadError QErr m
  ) =>
  PGExecCtx ->
  PGExecFrom ->
  PG.TxET QErr m a ->
  m a
runQueryTx :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
PGExecCtx -> PGExecFrom -> TxET QErr m a -> m a
runQueryTx PGExecCtx
pgExecCtx PGExecFrom
pgExecFrom TxET QErr m a
tx = do
  let pgExecCtxInfo :: PGExecCtxInfo
pgExecCtxInfo = PGExecTxType -> PGExecFrom -> PGExecCtxInfo
PGExecCtxInfo PGExecTxType
NoTxRead PGExecFrom
pgExecFrom
  m (Either QErr a) -> m a
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM
    (m (Either QErr a) -> m a) -> m (Either QErr a) -> m a
forall a b. (a -> b) -> a -> b
$ 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))
-> ExceptT QErr m a -> m (Either QErr a)
forall a b. (a -> b) -> a -> b
$ (PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx PGExecCtx
pgExecCtx) PGExecCtxInfo
pgExecCtxInfo TxET QErr m a
tx

setHeadersTx :: (MonadIO m) => SessionVariables -> PG.TxET QErr m ()
setHeadersTx :: forall (m :: * -> *).
MonadIO m =>
SessionVariables -> TxET QErr m ()
setHeadersTx SessionVariables
session = do
  (PGTxErr -> QErr) -> Query -> () -> Bool -> TxET QErr m ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE PGTxErr -> QErr
defaultTxErrorHandler Query
setSess () Bool
False
  where
    setSess :: Query
setSess =
      Text -> Query
PG.fromText
        (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$ Text
"SET LOCAL \"hasura.user\" = "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SQLExp -> Text
forall a. ToSQL a => a -> Text
toSQLTxt (SessionVariables -> SQLExp
sessionInfoJsonExp SessionVariables
session)

sessionInfoJsonExp :: SessionVariables -> S.SQLExp
sessionInfoJsonExp :: SessionVariables -> SQLExp
sessionInfoJsonExp = Text -> SQLExp
S.SELit (Text -> SQLExp)
-> (SessionVariables -> Text) -> SessionVariables -> SQLExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionVariables -> Text
forall a. ToJSON a => a -> Text
encodeToStrictText

withUserInfo :: (MonadIO m) => UserInfo -> PG.TxET QErr m a -> PG.TxET QErr m a
withUserInfo :: forall (m :: * -> *) a.
MonadIO m =>
UserInfo -> TxET QErr m a -> TxET QErr m a
withUserInfo UserInfo
uInfo TxET QErr m a
tx = SessionVariables -> TxET QErr m ()
forall (m :: * -> *).
MonadIO m =>
SessionVariables -> TxET QErr m ()
setHeadersTx (UserInfo -> SessionVariables
_uiSession UserInfo
uInfo) TxET QErr m () -> TxET QErr m a -> TxET QErr m a
forall a b. TxET QErr m a -> TxET QErr m b -> TxET QErr m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TxET QErr m a
tx

setTraceContextInTx :: (MonadIO m) => Maybe Tracing.TraceContext -> PG.TxET QErr m ()
setTraceContextInTx :: forall (m :: * -> *).
MonadIO m =>
Maybe TraceContext -> TxET QErr m ()
setTraceContextInTx = \case
  Maybe TraceContext
Nothing -> () -> TxET QErr m ()
forall a. a -> TxET QErr m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Just TraceContext
ctx -> do
    let sql :: Query
sql = Text -> Query
PG.fromText (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$ Text
"SET LOCAL \"hasura.tracecontext\" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SQLExp -> Text
forall a. ToSQL a => a -> Text
toSQLTxt (Text -> SQLExp
S.SELit (Text -> SQLExp)
-> (TraceContext -> Text) -> TraceContext -> SQLExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Text
forall a. ToJSON a => a -> Text
encodeToStrictText (Value -> Text) -> (TraceContext -> Value) -> TraceContext -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceContext -> Value
forall a. ToJSON a => a -> Value
toJSON (TraceContext -> SQLExp) -> TraceContext -> SQLExp
forall a b. (a -> b) -> a -> b
$ TraceContext
ctx)
    (PGTxErr -> QErr) -> Query -> () -> Bool -> TxET QErr m ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE PGTxErr -> QErr
defaultTxErrorHandler Query
sql () Bool
False

-- | Inject the trace context as a transaction-local variable,
-- so that it can be picked up by any triggers (including event triggers).
withTraceContext ::
  (MonadIO m) =>
  Maybe (Tracing.TraceContext) ->
  PG.TxET QErr m a ->
  PG.TxET QErr m a
withTraceContext :: forall (m :: * -> *) a.
MonadIO m =>
Maybe TraceContext -> TxET QErr m a -> TxET QErr m a
withTraceContext Maybe TraceContext
ctx TxET QErr m a
tx = Maybe TraceContext -> TxET QErr m ()
forall (m :: * -> *).
MonadIO m =>
Maybe TraceContext -> TxET QErr m ()
setTraceContextInTx Maybe TraceContext
ctx TxET QErr m () -> TxET QErr m a -> TxET QErr m a
forall a b. TxET QErr m a -> TxET QErr m b -> TxET QErr m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TxET QErr m a
tx

deriving instance (Tracing.MonadTrace m) => Tracing.MonadTrace (PG.TxET e m)

checkDbConnection :: (MonadTx m) => m ()
checkDbConnection :: forall (m :: * -> *). MonadTx m => m ()
checkDbConnection = do
  PG.Discard () <- TxE QErr Discard -> m Discard
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx (TxE QErr Discard -> m Discard) -> TxE QErr Discard -> m Discard
forall a b. (a -> b) -> a -> b
$ (PGTxErr -> QErr) -> Query -> () -> Bool -> TxE QErr Discard
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE PGTxErr -> QErr
defaultTxErrorHandler [PG.sql| SELECT 1; |] () Bool
False
  () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

doesSchemaExist :: (MonadTx m) => SchemaName -> m Bool
doesSchemaExist :: forall (m :: * -> *). MonadTx m => SchemaName -> m Bool
doesSchemaExist SchemaName
schemaName =
  TxE QErr Bool -> m Bool
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
    (TxE QErr Bool -> m Bool) -> TxE QErr Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (SingleRow (Identity Bool) -> Identity Bool)
-> SingleRow (Identity Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity Bool) -> Identity Bool
forall a. SingleRow a -> a
PG.getRow)
    (SingleRow (Identity Bool) -> Bool)
-> TxET QErr IO (SingleRow (Identity Bool)) -> TxE QErr Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> Identity SchemaName
-> Bool
-> TxET QErr IO (SingleRow (Identity Bool))
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
    SELECT EXISTS
    ( SELECT 1 FROM information_schema.schemata
      WHERE schema_name = $1
    ) |]
      (SchemaName -> Identity SchemaName
forall a. a -> Identity a
Identity SchemaName
schemaName)
      Bool
False

doesTableExist :: (MonadTx m) => SchemaName -> TableName -> m Bool
doesTableExist :: forall (m :: * -> *).
MonadTx m =>
SchemaName -> TableName -> m Bool
doesTableExist SchemaName
schemaName TableName
tableName =
  TxE QErr Bool -> m Bool
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
    (TxE QErr Bool -> m Bool) -> TxE QErr Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (SingleRow (Identity Bool) -> Identity Bool)
-> SingleRow (Identity Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity Bool) -> Identity Bool
forall a. SingleRow a -> a
PG.getRow)
    (SingleRow (Identity Bool) -> Bool)
-> TxET QErr IO (SingleRow (Identity Bool)) -> TxE QErr Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> (SchemaName, TableName)
-> Bool
-> TxET QErr IO (SingleRow (Identity Bool))
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
    SELECT EXISTS
    ( SELECT 1 FROM pg_tables
      WHERE schemaname = $1 AND tablename = $2
    ) |]
      (SchemaName
schemaName, TableName
tableName)
      Bool
False

isExtensionAvailable :: (MonadTx m) => Text -> m Bool
isExtensionAvailable :: forall (m :: * -> *). MonadTx m => Text -> m Bool
isExtensionAvailable Text
extensionName =
  TxE QErr Bool -> m Bool
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
    (TxE QErr Bool -> m Bool) -> TxE QErr Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ (Identity Bool -> Bool
forall a. Identity a -> a
runIdentity (Identity Bool -> Bool)
-> (SingleRow (Identity Bool) -> Identity Bool)
-> SingleRow (Identity Bool)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity Bool) -> Identity Bool
forall a. SingleRow a -> a
PG.getRow)
    (SingleRow (Identity Bool) -> Bool)
-> TxET QErr IO (SingleRow (Identity Bool)) -> TxE QErr Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> Identity Text
-> Bool
-> TxET QErr IO (SingleRow (Identity Bool))
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
    SELECT EXISTS
    ( SELECT 1 FROM pg_catalog.pg_available_extensions
      WHERE name = $1
    ) |]
      (Text -> Identity Text
forall a. a -> Identity a
Identity Text
extensionName)
      Bool
False

enablePgcryptoExtension :: forall m. (MonadTx m) => ExtensionsSchema -> m ()
enablePgcryptoExtension :: forall (m :: * -> *). MonadTx m => ExtensionsSchema -> m ()
enablePgcryptoExtension (ExtensionsSchema Text
extensionsSchema) = do
  Bool
pgcryptoAvailable <- Text -> m Bool
forall (m :: * -> *). MonadTx m => Text -> m Bool
isExtensionAvailable Text
"pgcrypto"
  if Bool
pgcryptoAvailable
    then m ()
createPgcryptoExtension
    else
      Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
Unexpected
        (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"pgcrypto extension is required, but could not find the extension in the "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"PostgreSQL server. Please make sure this extension is available."
  where
    createPgcryptoExtension :: m ()
    createPgcryptoExtension :: m ()
createPgcryptoExtension =
      TxE QErr () -> m ()
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
        (TxE QErr () -> m ()) -> TxE QErr () -> m ()
forall a b. (a -> b) -> a -> b
$ (PGTxErr -> QErr) -> Query -> () -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
          PGTxErr -> QErr
needsPGCryptoError
          (Text -> Query
PG.fromText (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$ Text
"CREATE EXTENSION IF NOT EXISTS pgcrypto SCHEMA " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
extensionsSchema)
          ()
          Bool
False
      where
        needsPGCryptoError :: PGTxErr -> QErr
needsPGCryptoError e :: PGTxErr
e@(PG.PGTxErr Text
_ [PrepArg]
_ Bool
_ PGErrInternal
err) =
          case PGErrInternal
err of
            PG.PGIUnexpected Text
_ -> PGTxErr -> QErr
requiredError PGTxErr
e
            PG.PGIStatement PGStmtErrDetail
pgErr -> case PGStmtErrDetail -> Maybe Text
PG.edStatusCode PGStmtErrDetail
pgErr of
              Just Text
"42501" -> Code -> Text -> QErr
err500 Code
PostgresError Text
permissionsMessage
              Just Text
"P0001" -> PGTxErr -> QErr
requiredError (PGStmtErrDetail -> PGTxErr
addHintForExtensionError PGStmtErrDetail
pgErr)
              Maybe Text
_ -> PGTxErr -> QErr
requiredError PGTxErr
e
          where
            addHintForExtensionError :: PGStmtErrDetail -> PGTxErr
addHintForExtensionError PGStmtErrDetail
pgErrDetail =
              PGTxErr
e
                { pgteError :: PGErrInternal
PG.pgteError =
                    PGStmtErrDetail -> PGErrInternal
PG.PGIStatement
                      (PGStmtErrDetail -> PGErrInternal)
-> PGStmtErrDetail -> PGErrInternal
forall a b. (a -> b) -> a -> b
$ PG.PGStmtErrDetail
                        { edExecStatus :: PGExecStatus
PG.edExecStatus = PGStmtErrDetail -> PGExecStatus
PG.edExecStatus PGStmtErrDetail
pgErrDetail,
                          edStatusCode :: Maybe Text
PG.edStatusCode = PGStmtErrDetail -> Maybe Text
PG.edStatusCode PGStmtErrDetail
pgErrDetail,
                          edMessage :: Maybe Text
PG.edMessage =
                            (Text -> Text -> Text) -> Maybe Text -> Maybe Text -> Maybe Text
forall a b c. (a -> b -> c) -> Maybe a -> Maybe b -> Maybe c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>)
                              (PGStmtErrDetail -> Maybe Text
PG.edMessage PGStmtErrDetail
pgErrDetail)
                              (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
". Hint: You can set \"extensions_schema\" to provide the schema to install the extensions. Refer to the documentation here: https://hasura.io/docs/latest/deployment/postgres-requirements/#pgcrypto-in-pg-search-path"),
                          edDescription :: Maybe Text
PG.edDescription = PGStmtErrDetail -> Maybe Text
PG.edDescription PGStmtErrDetail
pgErrDetail,
                          edHint :: Maybe Text
PG.edHint = PGStmtErrDetail -> Maybe Text
PG.edHint PGStmtErrDetail
pgErrDetail
                        }
                }
            requiredError :: PGTxErr -> QErr
requiredError PGTxErr
pgTxErr =
              (Code -> Text -> QErr
err500 Code
PostgresError Text
requiredMessage) {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
toJSON PGTxErr
pgTxErr}
            requiredMessage :: Text
requiredMessage =
              Text
"pgcrypto extension is required, but it could not be created;"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" encountered unknown postgres error"
            permissionsMessage :: Text
permissionsMessage =
              Text
"pgcrypto extension is required, but the current user doesn’t have permission to"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" create it. Please grant superuser permission, or setup the initial schema via"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" https://hasura.io/docs/latest/graphql/core/deployment/postgres-permissions.html"

dropHdbCatalogSchema :: (MonadTx m) => m ()
dropHdbCatalogSchema :: forall (m :: * -> *). MonadTx m => m ()
dropHdbCatalogSchema =
  TxE QErr () -> m ()
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
    (TxE QErr () -> m ()) -> TxE QErr () -> m ()
forall a b. (a -> b) -> a -> b
$
    -- This is where
    -- 1. Metadata storage:- Metadata and its stateful information stored
    -- 2. Postgres source:- Table event trigger related stuff & insert permission check function stored
    (PGTxErr -> QErr) -> Query -> () -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE PGTxErr -> QErr
defaultTxErrorHandler Query
"DROP SCHEMA IF EXISTS hdb_catalog CASCADE" () Bool
False