{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Hasura.Backends.Postgres.DDL.Source
( ToMetadataFetchQuery,
FetchTableMetadata (..),
FetchFunctionMetadata (..),
prepareCatalog,
postDropSourceHook,
resolveDatabaseMetadata,
resolveSourceConfig,
logPGSourceCatalogMigrationLockedQueries,
pgFetchTableMetadata,
)
where
import Control.Concurrent.Extended (sleep)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToEncoding, genericToJSON, toJSON)
import Data.Environment qualified as Env
import Data.FileEmbed (makeRelativeToProject)
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.HashSet qualified as Set
import Data.List.Extended qualified as LE
import Data.List.NonEmpty qualified as NE
import Data.Time.Clock (UTCTime, getCurrentTime)
import Database.PG.Query qualified as PG
import Hasura.Backends.Postgres.Connection
import Hasura.Backends.Postgres.DDL.EventTrigger (dropTriggerQ)
import Hasura.Backends.Postgres.DDL.Source.Version
import Hasura.Backends.Postgres.SQL.Types hiding (FunctionName)
import Hasura.Backends.Postgres.Types.ComputedField
import Hasura.Base.Error
import Hasura.Function.Cache
import Hasura.Logging
import Hasura.Prelude
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.BackendType
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.EventTrigger (RecreateEventTriggers (..))
import Hasura.RQL.Types.Metadata (SourceMetadata (..), _cfmDefinition)
import Hasura.RQL.Types.Source
import Hasura.Server.Migrate.Internal
import Hasura.Server.Migrate.Version qualified as Version
import Hasura.Table.Cache
import Hasura.Table.Metadata (TableMetadata (..))
import Language.Haskell.TH.Lib qualified as TH
import Language.Haskell.TH.Syntax qualified as TH
class ToMetadataFetchQuery (pgKind :: PostgresKind) where
tableMetadata :: PG.Query
instance ToMetadataFetchQuery 'Vanilla where
tableMetadata :: Query
tableMetadata = $(makeRelativeToProject "src-rsr/pg_table_metadata.sql" >>= PG.sqlFromFile)
instance ToMetadataFetchQuery 'Citus where
tableMetadata :: Query
tableMetadata = $(makeRelativeToProject "src-rsr/citus_table_metadata.sql" >>= PG.sqlFromFile)
instance ToMetadataFetchQuery 'Cockroach where
tableMetadata :: Query
tableMetadata = $(makeRelativeToProject "src-rsr/cockroach_table_metadata.sql" >>= PG.sqlFromFile)
resolveSourceConfig ::
(MonadIO m, MonadResolveSource m) =>
SourceName ->
PostgresConnConfiguration ->
BackendSourceKind ('Postgres pgKind) ->
BackendConfig ('Postgres pgKind) ->
Env.Environment ->
manager ->
m (Either QErr (SourceConfig ('Postgres pgKind)))
resolveSourceConfig :: forall (m :: * -> *) (pgKind :: PostgresKind) manager.
(MonadIO m, MonadResolveSource m) =>
SourceName
-> PostgresConnConfiguration
-> BackendSourceKind ('Postgres pgKind)
-> BackendConfig ('Postgres pgKind)
-> Environment
-> manager
-> m (Either QErr (SourceConfig ('Postgres pgKind)))
resolveSourceConfig SourceName
name PostgresConnConfiguration
config BackendSourceKind ('Postgres pgKind)
_backendKind BackendConfig ('Postgres pgKind)
_backendConfig Environment
env manager
_manager = ExceptT QErr m PGSourceConfig -> m (Either QErr PGSourceConfig)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
Environment
-> SourceName
-> PostgresConnConfiguration
-> IO (Either QErr PGSourceConfig)
sourceResolver <- ExceptT QErr m (SourceResolver ('Postgres 'Vanilla))
ExceptT
QErr
m
(Environment
-> SourceName
-> PostgresConnConfiguration
-> IO (Either QErr PGSourceConfig))
forall (m :: * -> *).
MonadResolveSource m =>
m (SourceResolver ('Postgres 'Vanilla))
getPGSourceResolver
ExceptT QErr m (Either QErr PGSourceConfig)
-> ExceptT QErr m PGSourceConfig
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM (ExceptT QErr m (Either QErr PGSourceConfig)
-> ExceptT QErr m PGSourceConfig)
-> ExceptT QErr m (Either QErr PGSourceConfig)
-> ExceptT QErr m PGSourceConfig
forall a b. (a -> b) -> a -> b
$ IO (Either QErr PGSourceConfig)
-> ExceptT QErr m (Either QErr PGSourceConfig)
forall a. IO a -> ExceptT QErr m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QErr PGSourceConfig)
-> ExceptT QErr m (Either QErr PGSourceConfig))
-> IO (Either QErr PGSourceConfig)
-> ExceptT QErr m (Either QErr PGSourceConfig)
forall a b. (a -> b) -> a -> b
$ Environment
-> SourceName
-> PostgresConnConfiguration
-> IO (Either QErr PGSourceConfig)
sourceResolver Environment
env SourceName
name PostgresConnConfiguration
config
data PGSourceLockQuery = PGSourceLockQuery
{ PGSourceLockQuery -> Text
_psqaQuery :: Text,
PGSourceLockQuery -> Maybe Bool
_psqaLockGranted :: Maybe Bool,
PGSourceLockQuery -> Text
_psqaLockMode :: Text,
PGSourceLockQuery -> UTCTime
_psqaTransactionStartTime :: UTCTime,
PGSourceLockQuery -> UTCTime
_psqaQueryStartTime :: UTCTime,
PGSourceLockQuery -> Text
_psqaWaitEventType :: Text,
PGSourceLockQuery -> Text
_psqaBlockingQuery :: Text
}
deriving stock ((forall x. PGSourceLockQuery -> Rep PGSourceLockQuery x)
-> (forall x. Rep PGSourceLockQuery x -> PGSourceLockQuery)
-> Generic PGSourceLockQuery
forall x. Rep PGSourceLockQuery x -> PGSourceLockQuery
forall x. PGSourceLockQuery -> Rep PGSourceLockQuery x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PGSourceLockQuery -> Rep PGSourceLockQuery x
from :: forall x. PGSourceLockQuery -> Rep PGSourceLockQuery x
$cto :: forall x. Rep PGSourceLockQuery x -> PGSourceLockQuery
to :: forall x. Rep PGSourceLockQuery x -> PGSourceLockQuery
Generic)
instance FromJSON PGSourceLockQuery where
parseJSON :: Value -> Parser PGSourceLockQuery
parseJSON = Options -> Value -> Parser PGSourceLockQuery
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
hasuraJSON
instance ToJSON PGSourceLockQuery where
toJSON :: PGSourceLockQuery -> Value
toJSON = Options -> PGSourceLockQuery -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
hasuraJSON
toEncoding :: PGSourceLockQuery -> Encoding
toEncoding = Options -> PGSourceLockQuery -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
hasuraJSON
instance ToEngineLog [PGSourceLockQuery] Hasura where
toEngineLog :: [PGSourceLockQuery] -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog [PGSourceLockQuery]
resp = (LogLevel
LevelInfo, EngineLogType Hasura
sourceCatalogMigrationLogType, [PGSourceLockQuery] -> Value
forall a. ToJSON a => a -> Value
toJSON [PGSourceLockQuery]
resp)
newtype PGSourceLockQueryError = PGSourceLockQueryError QErr
deriving ([PGSourceLockQueryError] -> Value
[PGSourceLockQueryError] -> Encoding
PGSourceLockQueryError -> Value
PGSourceLockQueryError -> Encoding
(PGSourceLockQueryError -> Value)
-> (PGSourceLockQueryError -> Encoding)
-> ([PGSourceLockQueryError] -> Value)
-> ([PGSourceLockQueryError] -> Encoding)
-> ToJSON PGSourceLockQueryError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: PGSourceLockQueryError -> Value
toJSON :: PGSourceLockQueryError -> Value
$ctoEncoding :: PGSourceLockQueryError -> Encoding
toEncoding :: PGSourceLockQueryError -> Encoding
$ctoJSONList :: [PGSourceLockQueryError] -> Value
toJSONList :: [PGSourceLockQueryError] -> Value
$ctoEncodingList :: [PGSourceLockQueryError] -> Encoding
toEncodingList :: [PGSourceLockQueryError] -> Encoding
ToJSON)
instance ToEngineLog PGSourceLockQueryError Hasura where
toEngineLog :: PGSourceLockQueryError -> (LogLevel, EngineLogType Hasura, Value)
toEngineLog PGSourceLockQueryError
resp = (LogLevel
LevelError, EngineLogType Hasura
sourceCatalogMigrationLogType, PGSourceLockQueryError -> Value
forall a. ToJSON a => a -> Value
toJSON PGSourceLockQueryError
resp)
logPGSourceCatalogMigrationLockedQueries ::
(MonadIO m) =>
Logger Hasura ->
PGSourceConfig ->
m Void
logPGSourceCatalogMigrationLockedQueries :: forall (m :: * -> *).
MonadIO m =>
Logger Hasura -> PGSourceConfig -> m Void
logPGSourceCatalogMigrationLockedQueries Logger Hasura
logger PGSourceConfig
sourceConfig = m () -> m Void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
Either QErr (Maybe [PGSourceLockQuery])
dbStats <- IO (Either QErr (Maybe [PGSourceLockQuery]))
-> m (Either QErr (Maybe [PGSourceLockQuery]))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either QErr (Maybe [PGSourceLockQuery]))
-> m (Either QErr (Maybe [PGSourceLockQuery])))
-> IO (Either QErr (Maybe [PGSourceLockQuery]))
-> m (Either QErr (Maybe [PGSourceLockQuery]))
forall a b. (a -> b) -> a -> b
$ PGSourceConfig
-> TxET QErr IO (Maybe [PGSourceLockQuery])
-> IO (Either QErr (Maybe [PGSourceLockQuery]))
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
PGSourceConfig -> TxET QErr m a -> m (Either QErr a)
runPgSourceReadTx PGSourceConfig
sourceConfig TxET QErr IO (Maybe [PGSourceLockQuery])
fetchLockedQueriesTx
case Either QErr (Maybe [PGSourceLockQuery])
dbStats of
Left QErr
err -> Logger Hasura
-> forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
(ToEngineLog a impl, MonadIO m) =>
a -> m ()
unLogger Logger Hasura
logger (PGSourceLockQueryError -> m ()) -> PGSourceLockQueryError -> m ()
forall a b. (a -> b) -> a -> b
$ QErr -> PGSourceLockQueryError
PGSourceLockQueryError QErr
err
Right (Maybe [PGSourceLockQuery]
val :: (Maybe [PGSourceLockQuery])) ->
case Maybe [PGSourceLockQuery]
val of
Maybe [PGSourceLockQuery]
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just [] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just [PGSourceLockQuery]
val' -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> forall a (m :: * -> *).
(ToEngineLog a Hasura, MonadIO m) =>
a -> m ()
forall impl.
Logger impl
-> forall a (m :: * -> *).
(ToEngineLog a impl, MonadIO m) =>
a -> m ()
unLogger Logger Hasura
logger ([PGSourceLockQuery] -> IO ()) -> [PGSourceLockQuery] -> IO ()
forall a b. (a -> b) -> a -> b
$ [PGSourceLockQuery]
val'
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> IO ()
sleep (DiffTime -> IO ()) -> DiffTime -> IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> DiffTime
seconds Seconds
5
where
fetchLockedQueriesTx :: TxET QErr IO (Maybe [PGSourceLockQuery])
fetchLockedQueriesTx =
(ViaJSON (Maybe [PGSourceLockQuery]) -> Maybe [PGSourceLockQuery]
forall a. ViaJSON a -> a
PG.getViaJSON (ViaJSON (Maybe [PGSourceLockQuery]) -> Maybe [PGSourceLockQuery])
-> (SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery])))
-> ViaJSON (Maybe [PGSourceLockQuery]))
-> SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery])))
-> Maybe [PGSourceLockQuery]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (ViaJSON (Maybe [PGSourceLockQuery]))
-> ViaJSON (Maybe [PGSourceLockQuery])
forall a. Identity a -> a
runIdentity (Identity (ViaJSON (Maybe [PGSourceLockQuery]))
-> ViaJSON (Maybe [PGSourceLockQuery]))
-> (SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery])))
-> Identity (ViaJSON (Maybe [PGSourceLockQuery])))
-> SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery])))
-> ViaJSON (Maybe [PGSourceLockQuery])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery])))
-> Identity (ViaJSON (Maybe [PGSourceLockQuery]))
forall a. SingleRow a -> a
PG.getRow)
(SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery])))
-> Maybe [PGSourceLockQuery])
-> TxET
QErr
IO
(SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery]))))
-> TxET QErr IO (Maybe [PGSourceLockQuery])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> ()
-> Bool
-> TxET
QErr
IO
(SingleRow (Identity (ViaJSON (Maybe [PGSourceLockQuery]))))
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 COALESCE(json_agg(DISTINCT jsonb_build_object('query', psa.query, 'lock_granted', pl.granted, 'lock_mode', pl.mode, 'transaction_start_time', psa.xact_start, 'query_start_time', psa.query_start, 'wait_event_type', psa.wait_event_type, 'blocking_query', (SUBSTRING(blocking.query, 1, 20) || '...') )), '[]'::json)
FROM pg_stat_activity psa
JOIN pg_stat_activity blocking ON blocking.pid = ANY(pg_blocking_pids(psa.pid))
LEFT JOIN pg_locks pl ON psa.pid = pl.pid
WHERE psa.query ILIKE '%hdb_catalog%' AND psa.wait_event_type IS NOT NULL
AND psa.query ILIKE any (array ['%create%', '%drop%', '%alter%']);
|]
()
Bool
False
resolveDatabaseMetadata ::
forall pgKind m.
( Backend ('Postgres pgKind),
ToMetadataFetchQuery pgKind,
FetchFunctionMetadata pgKind,
FetchTableMetadata pgKind,
MonadIO m,
MonadBaseControl IO m
) =>
SourceMetadata ('Postgres pgKind) ->
SourceConfig ('Postgres pgKind) ->
m (Either QErr (DBObjectsIntrospection ('Postgres pgKind)))
resolveDatabaseMetadata :: forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind,
FetchFunctionMetadata pgKind, FetchTableMetadata pgKind, MonadIO m,
MonadBaseControl IO m) =>
SourceMetadata ('Postgres pgKind)
-> SourceConfig ('Postgres pgKind)
-> m (Either QErr (DBObjectsIntrospection ('Postgres pgKind)))
resolveDatabaseMetadata SourceMetadata ('Postgres pgKind)
sourceMetadata SourceConfig ('Postgres pgKind)
sourceConfig =
ExceptT QErr m (DBObjectsIntrospection ('Postgres pgKind))
-> m (Either QErr (DBObjectsIntrospection ('Postgres pgKind)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m (DBObjectsIntrospection ('Postgres pgKind))
-> m (Either QErr (DBObjectsIntrospection ('Postgres pgKind))))
-> ExceptT QErr m (DBObjectsIntrospection ('Postgres pgKind))
-> m (Either QErr (DBObjectsIntrospection ('Postgres pgKind)))
forall a b. (a -> b) -> a -> b
$ PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx (PGSourceConfig -> PGExecCtx
_pscExecCtx SourceConfig ('Postgres pgKind)
PGSourceConfig
sourceConfig) (PGExecTxType -> PGExecFrom -> PGExecCtxInfo
PGExecCtxInfo (TxAccess -> Maybe TxIsolation -> PGExecTxType
Tx TxAccess
PG.ReadOnly Maybe TxIsolation
forall a. Maybe a
Nothing) PGExecFrom
InternalRawQuery) do
HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
tablesMeta <- HashSet QualifiedTable
-> TxET QErr m (DBTablesMetadata ('Postgres pgKind))
forall (pgKind :: PostgresKind) (m :: * -> *).
(FetchTableMetadata pgKind, Backend ('Postgres pgKind),
ToMetadataFetchQuery pgKind, MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres pgKind))
forall (m :: * -> *).
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres pgKind))
fetchTableMetadata (HashSet QualifiedTable
-> TxET QErr m (DBTablesMetadata ('Postgres pgKind)))
-> HashSet QualifiedTable
-> TxET QErr m (DBTablesMetadata ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ HashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> HashSet QualifiedTable
forall k a. HashMap k a -> HashSet k
HashMap.keysSet (HashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> HashSet QualifiedTable)
-> HashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> HashSet QualifiedTable
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> HashMap QualifiedTable (TableMetadata ('Postgres pgKind))
forall k v. InsOrdHashMap k v -> HashMap k v
InsOrdHashMap.toHashMap (InsOrdHashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> HashMap QualifiedTable (TableMetadata ('Postgres pgKind)))
-> InsOrdHashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> HashMap QualifiedTable (TableMetadata ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ SourceMetadata ('Postgres pgKind) -> Tables ('Postgres pgKind)
forall (b :: BackendType). SourceMetadata b -> Tables b
_smTables SourceMetadata ('Postgres pgKind)
sourceMetadata
let allFunctions :: HashSet QualifiedFunction
allFunctions =
[QualifiedFunction] -> HashSet QualifiedFunction
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList
([QualifiedFunction] -> HashSet QualifiedFunction)
-> [QualifiedFunction] -> HashSet QualifiedFunction
forall a b. (a -> b) -> a -> b
$ InsOrdHashMap
QualifiedFunction (FunctionMetadata ('Postgres pgKind))
-> [QualifiedFunction]
forall k v. InsOrdHashMap k v -> [k]
InsOrdHashMap.keys (SourceMetadata ('Postgres pgKind) -> Functions ('Postgres pgKind)
forall (b :: BackendType). SourceMetadata b -> Functions b
_smFunctions SourceMetadata ('Postgres pgKind)
sourceMetadata)
[QualifiedFunction] -> [QualifiedFunction] -> [QualifiedFunction]
forall a. Semigroup a => a -> a -> a
<> (TableMetadata ('Postgres pgKind) -> [QualifiedFunction])
-> [TableMetadata ('Postgres pgKind)] -> [QualifiedFunction]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TableMetadata ('Postgres pgKind)
-> [FunctionName ('Postgres pgKind)]
TableMetadata ('Postgres pgKind) -> [QualifiedFunction]
getComputedFieldFunctionsMetadata (InsOrdHashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> [TableMetadata ('Postgres pgKind)]
forall k v. InsOrdHashMap k v -> [v]
InsOrdHashMap.elems (InsOrdHashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> [TableMetadata ('Postgres pgKind)])
-> InsOrdHashMap QualifiedTable (TableMetadata ('Postgres pgKind))
-> [TableMetadata ('Postgres pgKind)]
forall a b. (a -> b) -> a -> b
$ SourceMetadata ('Postgres pgKind) -> Tables ('Postgres pgKind)
forall (b :: BackendType). SourceMetadata b -> Tables b
_smTables SourceMetadata ('Postgres pgKind)
sourceMetadata)
HashMap QualifiedFunction (FunctionOverloads ('Postgres pgKind))
functionsMeta <- forall (pgKind :: PostgresKind) (m :: * -> *).
(FetchFunctionMetadata pgKind, MonadTx m) =>
HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres pgKind))
fetchFunctionMetadata @pgKind HashSet QualifiedFunction
allFunctions
HashSet PGScalarType
pgScalars <- TxET QErr m (HashSet PGScalarType)
forall (m :: * -> *). MonadTx m => m (HashSet PGScalarType)
fetchPgScalars
let scalarsMap :: HashMap Name PGScalarType
scalarsMap = [(Name, PGScalarType)] -> HashMap Name PGScalarType
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList do
PGScalarType
scalar <- HashSet PGScalarType -> [PGScalarType]
forall a. HashSet a -> [a]
Set.toList HashSet PGScalarType
pgScalars
Name
name <- forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t a -> f a
afold @(Either QErr) (Either QErr Name -> [Name]) -> Either QErr Name -> [Name]
forall a b. (a -> b) -> a -> b
$ PGScalarType -> Either QErr Name
forall (m :: * -> *). MonadError QErr m => PGScalarType -> m Name
mkScalarTypeName PGScalarType
scalar
(Name, PGScalarType) -> [(Name, PGScalarType)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, PGScalarType
scalar)
DBObjectsIntrospection ('Postgres pgKind)
-> TxET QErr m (DBObjectsIntrospection ('Postgres pgKind))
forall a. a -> TxET QErr m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DBObjectsIntrospection ('Postgres pgKind)
-> TxET QErr m (DBObjectsIntrospection ('Postgres pgKind)))
-> DBObjectsIntrospection ('Postgres pgKind)
-> TxET QErr m (DBObjectsIntrospection ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ DBTablesMetadata ('Postgres pgKind)
-> DBFunctionsMetadata ('Postgres pgKind)
-> ScalarMap ('Postgres pgKind)
-> LogicalModels ('Postgres pgKind)
-> DBObjectsIntrospection ('Postgres pgKind)
forall (b :: BackendType).
DBTablesMetadata b
-> DBFunctionsMetadata b
-> ScalarMap b
-> LogicalModels b
-> DBObjectsIntrospection b
DBObjectsIntrospection DBTablesMetadata ('Postgres pgKind)
HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
tablesMeta DBFunctionsMetadata ('Postgres pgKind)
HashMap QualifiedFunction (FunctionOverloads ('Postgres pgKind))
functionsMeta (HashMap Name (ScalarType ('Postgres pgKind))
-> ScalarMap ('Postgres pgKind)
forall (b :: BackendType).
HashMap Name (ScalarType b) -> ScalarMap b
ScalarMap HashMap Name (ScalarType ('Postgres pgKind))
HashMap Name PGScalarType
scalarsMap) LogicalModels ('Postgres pgKind)
forall a. Monoid a => a
mempty
where
getComputedFieldFunctionsMetadata :: TableMetadata ('Postgres pgKind) -> [FunctionName ('Postgres pgKind)]
getComputedFieldFunctionsMetadata :: TableMetadata ('Postgres pgKind)
-> [FunctionName ('Postgres pgKind)]
getComputedFieldFunctionsMetadata =
(ComputedFieldMetadata ('Postgres pgKind) -> QualifiedFunction)
-> [ComputedFieldMetadata ('Postgres pgKind)]
-> [QualifiedFunction]
forall a b. (a -> b) -> [a] -> [b]
map (ComputedFieldDefinition -> QualifiedFunction
_cfdFunction (ComputedFieldDefinition -> QualifiedFunction)
-> (ComputedFieldMetadata ('Postgres pgKind)
-> ComputedFieldDefinition)
-> ComputedFieldMetadata ('Postgres pgKind)
-> QualifiedFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComputedFieldMetadata ('Postgres pgKind)
-> ComputedFieldDefinition ('Postgres pgKind)
ComputedFieldMetadata ('Postgres pgKind) -> ComputedFieldDefinition
forall (b :: BackendType).
ComputedFieldMetadata b -> ComputedFieldDefinition b
_cfmDefinition) ([ComputedFieldMetadata ('Postgres pgKind)] -> [QualifiedFunction])
-> (TableMetadata ('Postgres pgKind)
-> [ComputedFieldMetadata ('Postgres pgKind)])
-> TableMetadata ('Postgres pgKind)
-> [QualifiedFunction]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InsOrdHashMap
ComputedFieldName (ComputedFieldMetadata ('Postgres pgKind))
-> [ComputedFieldMetadata ('Postgres pgKind)]
forall k v. InsOrdHashMap k v -> [v]
InsOrdHashMap.elems (InsOrdHashMap
ComputedFieldName (ComputedFieldMetadata ('Postgres pgKind))
-> [ComputedFieldMetadata ('Postgres pgKind)])
-> (TableMetadata ('Postgres pgKind)
-> InsOrdHashMap
ComputedFieldName (ComputedFieldMetadata ('Postgres pgKind)))
-> TableMetadata ('Postgres pgKind)
-> [ComputedFieldMetadata ('Postgres pgKind)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableMetadata ('Postgres pgKind)
-> InsOrdHashMap
ComputedFieldName (ComputedFieldMetadata ('Postgres pgKind))
forall (b :: BackendType). TableMetadata b -> ComputedFields b
_tmComputedFields
prepareCatalog ::
(MonadIO m, MonadBaseControl IO m) =>
SourceConfig ('Postgres pgKind) ->
ExceptT QErr m (RecreateEventTriggers, Version.SourceCatalogMigrationState)
prepareCatalog :: forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadIO m, MonadBaseControl IO m) =>
SourceConfig ('Postgres pgKind)
-> ExceptT
QErr m (RecreateEventTriggers, SourceCatalogMigrationState)
prepareCatalog SourceConfig ('Postgres pgKind)
sourceConfig = PGExecCtx -> PGExecCtxInfo -> RunTx
_pecRunTx (PGSourceConfig -> PGExecCtx
_pscExecCtx SourceConfig ('Postgres pgKind)
PGSourceConfig
sourceConfig) (PGExecTxType -> PGExecFrom -> PGExecCtxInfo
PGExecCtxInfo (TxAccess -> Maybe TxIsolation -> PGExecTxType
Tx TxAccess
PG.ReadWrite Maybe TxIsolation
forall a. Maybe a
Nothing) PGExecFrom
InternalRawQuery) do
Bool
hdbCatalogExist <- SchemaName -> TxET QErr m Bool
forall (m :: * -> *). MonadTx m => SchemaName -> m Bool
doesSchemaExist SchemaName
"hdb_catalog"
Bool
eventLogTableExist <- SchemaName -> TableName -> TxET QErr m Bool
forall (m :: * -> *).
MonadTx m =>
SchemaName -> TableName -> m Bool
doesTableExist SchemaName
"hdb_catalog" TableName
"event_log"
Bool
sourceVersionTableExist <- SchemaName -> TableName -> TxET QErr m Bool
forall (m :: * -> *).
MonadTx m =>
SchemaName -> TableName -> m Bool
doesTableExist SchemaName
"hdb_catalog" TableName
"hdb_source_catalog_version"
if
| Bool -> Bool
not Bool
hdbCatalogExist -> TxE QErr (RecreateEventTriggers, SourceCatalogMigrationState)
-> TxET QErr m (RecreateEventTriggers, SourceCatalogMigrationState)
forall a. TxE QErr a -> TxET QErr m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx do
(PGTxErr -> QErr) -> Query -> () -> Bool -> TxET QErr IO ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE PGTxErr -> QErr
defaultTxErrorHandler Query
"CREATE SCHEMA hdb_catalog" () Bool
False
ExtensionsSchema -> TxET QErr IO ()
forall (m :: * -> *). MonadTx m => ExtensionsSchema -> m ()
enablePgcryptoExtension (ExtensionsSchema -> TxET QErr IO ())
-> ExtensionsSchema -> TxET QErr IO ()
forall a b. (a -> b) -> a -> b
$ PGSourceConfig -> ExtensionsSchema
_pscExtensionsSchema SourceConfig ('Postgres pgKind)
PGSourceConfig
sourceConfig
TxET QErr IO ()
initPgSourceCatalog
(RecreateEventTriggers, SourceCatalogMigrationState)
-> TxE QErr (RecreateEventTriggers, SourceCatalogMigrationState)
forall a. a -> TxET QErr IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecreateEventTriggers
RETDoNothing, Int -> SourceCatalogMigrationState
Version.SCMSInitialized (Int -> SourceCatalogMigrationState)
-> Int -> SourceCatalogMigrationState
forall a b. (a -> b) -> a -> b
$ SourceCatalogVersion ('Postgres Any) -> Int
forall (backend :: BackendType).
SourceCatalogVersion backend -> Int
Version.unSourceCatalogVersion SourceCatalogVersion ('Postgres Any)
forall (pgKind :: PostgresKind). SourceCatalogVersion pgKind
latestSourceCatalogVersion)
| Bool -> Bool
not (Bool
sourceVersionTableExist Bool -> Bool -> Bool
|| Bool
eventLogTableExist) -> do
TxET QErr IO () -> TxET QErr m ()
forall a. TxE QErr a -> TxET QErr m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx TxET QErr IO ()
initPgSourceCatalog
(RecreateEventTriggers, SourceCatalogMigrationState)
-> TxET QErr m (RecreateEventTriggers, SourceCatalogMigrationState)
forall a. a -> TxET QErr m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecreateEventTriggers
RETDoNothing, Int -> SourceCatalogMigrationState
Version.SCMSInitialized (Int -> SourceCatalogMigrationState)
-> Int -> SourceCatalogMigrationState
forall a b. (a -> b) -> a -> b
$ SourceCatalogVersion ('Postgres Any) -> Int
forall (backend :: BackendType).
SourceCatalogVersion backend -> Int
Version.unSourceCatalogVersion SourceCatalogVersion ('Postgres Any)
forall (pgKind :: PostgresKind). SourceCatalogVersion pgKind
latestSourceCatalogVersion)
| Bool -> Bool
not Bool
sourceVersionTableExist Bool -> Bool -> Bool
&& Bool
eventLogTableExist -> do
MetadataCatalogVersion
currMetadataCatalogVersion <- TxE QErr MetadataCatalogVersion
-> TxET QErr m MetadataCatalogVersion
forall a. TxE QErr a -> TxET QErr m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx TxE QErr MetadataCatalogVersion
getCatalogVersion
MetadataCatalogVersion -> TxET QErr m ()
forall {m :: * -> *}.
(MonadIO m, MonadTx m) =>
MetadataCatalogVersion -> m ()
migrateTo43MetadataCatalog MetadataCatalogVersion
currMetadataCatalogVersion
TxET QErr IO () -> TxET QErr m ()
forall a. TxE QErr a -> TxET QErr m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx TxET QErr IO ()
createVersionTable
SourceCatalogVersion ('Postgres Any)
-> TxET QErr m (RecreateEventTriggers, SourceCatalogMigrationState)
forall (m :: * -> *) (pgKind :: PostgresKind).
MonadTx m =>
SourceCatalogVersion pgKind
-> m (RecreateEventTriggers, SourceCatalogMigrationState)
migrateSourceCatalogFrom SourceCatalogVersion ('Postgres Any)
forall (pgKind :: PostgresKind). SourceCatalogVersion pgKind
initialSourceCatalogVersion
| Bool
otherwise -> TxET QErr m (RecreateEventTriggers, SourceCatalogMigrationState)
forall (m :: * -> *).
MonadTx m =>
m (RecreateEventTriggers, SourceCatalogMigrationState)
migrateSourceCatalog
where
initPgSourceCatalog :: TxET QErr IO ()
initPgSourceCatalog = do
() <- (PGTxErr -> QErr) -> Query -> TxET QErr IO ()
forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> TxET e m a
PG.multiQE PGTxErr -> QErr
defaultTxErrorHandler $(makeRelativeToProject "src-rsr/init_pg_source.sql" >>= PG.sqlFromFile)
TxET QErr IO ()
forall (m :: * -> *). MonadTx m => m ()
setSourceCatalogVersion
createVersionTable :: TxET QErr IO ()
createVersionTable = do
() <-
(PGTxErr -> QErr) -> Query -> TxET QErr IO ()
forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> TxET e m a
PG.multiQE
PGTxErr -> QErr
defaultTxErrorHandler
[PG.sql|
CREATE TABLE hdb_catalog.hdb_source_catalog_version(
version TEXT NOT NULL,
upgraded_on TIMESTAMPTZ NOT NULL
);
CREATE UNIQUE INDEX hdb_source_catalog_version_one_row
ON hdb_catalog.hdb_source_catalog_version((version IS NOT NULL));
|]
() -> TxET QErr IO ()
forall a. a -> TxET QErr IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
migrateTo43MetadataCatalog :: MetadataCatalogVersion -> m ()
migrateTo43MetadataCatalog MetadataCatalogVersion
prevVersion = do
let neededMigrations :: [(MetadataCatalogVersion, TxET QErr IO ())]
neededMigrations = ((MetadataCatalogVersion, TxET QErr IO ()) -> Bool)
-> [(MetadataCatalogVersion, TxET QErr IO ())]
-> [(MetadataCatalogVersion, TxET QErr IO ())]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((MetadataCatalogVersion -> MetadataCatalogVersion -> Bool
forall a. Ord a => a -> a -> Bool
< MetadataCatalogVersion
prevVersion) (MetadataCatalogVersion -> Bool)
-> ((MetadataCatalogVersion, TxET QErr IO ())
-> MetadataCatalogVersion)
-> (MetadataCatalogVersion, TxET QErr IO ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MetadataCatalogVersion, TxET QErr IO ()) -> MetadataCatalogVersion
forall a b. (a, b) -> a
fst) [(MetadataCatalogVersion, TxET QErr IO ())]
upMigrationsUntil43
case [(MetadataCatalogVersion, TxET QErr IO ())]
-> Maybe (NonEmpty (MetadataCatalogVersion, TxET QErr IO ()))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(MetadataCatalogVersion, TxET QErr IO ())]
neededMigrations of
Just NonEmpty (MetadataCatalogVersion, TxET QErr IO ())
nonEmptyNeededMigrations -> do
UTCTime
migrationTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
TxET QErr IO () -> m ()
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx (TxET QErr IO () -> m ()) -> TxET QErr IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ((MetadataCatalogVersion, TxET QErr IO ()) -> TxET QErr IO ())
-> NonEmpty (MetadataCatalogVersion, TxET QErr IO ())
-> TxET QErr IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (MetadataCatalogVersion, TxET QErr IO ()) -> TxET QErr IO ()
forall a b. (a, b) -> b
snd NonEmpty (MetadataCatalogVersion, TxET QErr IO ())
nonEmptyNeededMigrations
Text -> UTCTime -> m ()
forall (m :: * -> *). MonadTx m => Text -> UTCTime -> m ()
setCatalogVersion Text
"43" UTCTime
migrationTime
Maybe (NonEmpty (MetadataCatalogVersion, TxET QErr IO ()))
Nothing ->
() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
migrateSourceCatalog :: (MonadTx m) => m (RecreateEventTriggers, Version.SourceCatalogMigrationState)
migrateSourceCatalog :: forall (m :: * -> *).
MonadTx m =>
m (RecreateEventTriggers, SourceCatalogMigrationState)
migrateSourceCatalog =
m (SourceCatalogVersion ('Postgres Any))
forall (m :: * -> *) (postgres :: PostgresKind).
MonadTx m =>
m (SourceCatalogVersion postgres)
getSourceCatalogVersion m (SourceCatalogVersion ('Postgres Any))
-> (SourceCatalogVersion ('Postgres Any)
-> m (RecreateEventTriggers, SourceCatalogMigrationState))
-> m (RecreateEventTriggers, SourceCatalogMigrationState)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SourceCatalogVersion ('Postgres Any)
-> m (RecreateEventTriggers, SourceCatalogMigrationState)
forall (m :: * -> *) (pgKind :: PostgresKind).
MonadTx m =>
SourceCatalogVersion pgKind
-> m (RecreateEventTriggers, SourceCatalogMigrationState)
migrateSourceCatalogFrom
migrateSourceCatalogFrom ::
(MonadTx m) =>
SourceCatalogVersion pgKind ->
m (RecreateEventTriggers, Version.SourceCatalogMigrationState)
migrateSourceCatalogFrom :: forall (m :: * -> *) (pgKind :: PostgresKind).
MonadTx m =>
SourceCatalogVersion pgKind
-> m (RecreateEventTriggers, SourceCatalogMigrationState)
migrateSourceCatalogFrom SourceCatalogVersion pgKind
prevVersion
| SourceCatalogVersion pgKind
prevVersion SourceCatalogVersion pgKind -> SourceCatalogVersion pgKind -> Bool
forall a. Eq a => a -> a -> Bool
== SourceCatalogVersion pgKind
forall (pgKind :: PostgresKind). SourceCatalogVersion pgKind
latestSourceCatalogVersion = (RecreateEventTriggers, SourceCatalogMigrationState)
-> m (RecreateEventTriggers, SourceCatalogMigrationState)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RecreateEventTriggers
RETDoNothing, Int -> SourceCatalogMigrationState
Version.SCMSNothingToDo (Int -> SourceCatalogMigrationState)
-> Int -> SourceCatalogMigrationState
forall a b. (a -> b) -> a -> b
$ SourceCatalogVersion ('Postgres Any) -> Int
forall (backend :: BackendType).
SourceCatalogVersion backend -> Int
Version.unSourceCatalogVersion SourceCatalogVersion ('Postgres Any)
forall (pgKind :: PostgresKind). SourceCatalogVersion pgKind
latestSourceCatalogVersion)
| [] <- [(SourceCatalogVersion pgKind, TxET QErr IO ())]
neededMigrations =
Code
-> Text -> m (RecreateEventTriggers, SourceCatalogMigrationState)
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotSupported
(Text -> m (RecreateEventTriggers, SourceCatalogMigrationState))
-> Text -> m (RecreateEventTriggers, SourceCatalogMigrationState)
forall a b. (a -> b) -> a -> b
$ Text
"Expected source catalog version <= "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceCatalogVersion ('Postgres Any) -> Text
forall a. Show a => a -> Text
tshow SourceCatalogVersion ('Postgres Any)
forall (pgKind :: PostgresKind). SourceCatalogVersion pgKind
latestSourceCatalogVersion
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but the current version is "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SourceCatalogVersion pgKind -> Text
forall a. Show a => a -> Text
tshow SourceCatalogVersion pgKind
prevVersion
| Bool
otherwise = do
TxET QErr IO () -> m ()
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx (TxET QErr IO () -> m ()) -> TxET QErr IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ((SourceCatalogVersion pgKind, TxET QErr IO ()) -> TxET QErr IO ())
-> [(SourceCatalogVersion pgKind, TxET QErr IO ())]
-> TxET QErr IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SourceCatalogVersion pgKind, TxET QErr IO ()) -> TxET QErr IO ()
forall a b. (a, b) -> b
snd [(SourceCatalogVersion pgKind, TxET QErr IO ())]
neededMigrations
m ()
forall (m :: * -> *). MonadTx m => m ()
setSourceCatalogVersion
(RecreateEventTriggers, SourceCatalogMigrationState)
-> m (RecreateEventTriggers, SourceCatalogMigrationState)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( RecreateEventTriggers
RETRecreate,
Int -> Int -> SourceCatalogMigrationState
Version.SCMSMigratedTo
(SourceCatalogVersion pgKind -> Int
forall (backend :: BackendType).
SourceCatalogVersion backend -> Int
Version.unSourceCatalogVersion SourceCatalogVersion pgKind
prevVersion)
(SourceCatalogVersion ('Postgres Any) -> Int
forall (backend :: BackendType).
SourceCatalogVersion backend -> Int
Version.unSourceCatalogVersion SourceCatalogVersion ('Postgres Any)
forall (pgKind :: PostgresKind). SourceCatalogVersion pgKind
latestSourceCatalogVersion)
)
where
neededMigrations :: [(SourceCatalogVersion pgKind, TxET QErr IO ())]
neededMigrations =
((SourceCatalogVersion pgKind, TxET QErr IO ()) -> Bool)
-> [(SourceCatalogVersion pgKind, TxET QErr IO ())]
-> [(SourceCatalogVersion pgKind, TxET QErr IO ())]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((SourceCatalogVersion pgKind -> SourceCatalogVersion pgKind -> Bool
forall a. Eq a => a -> a -> Bool
/= SourceCatalogVersion pgKind
prevVersion) (SourceCatalogVersion pgKind -> Bool)
-> ((SourceCatalogVersion pgKind, TxET QErr IO ())
-> SourceCatalogVersion pgKind)
-> (SourceCatalogVersion pgKind, TxET QErr IO ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceCatalogVersion pgKind, TxET QErr IO ())
-> SourceCatalogVersion pgKind
forall a b. (a, b) -> a
fst) [(SourceCatalogVersion pgKind, TxET QErr IO ())]
forall (pgKind :: PostgresKind).
[(SourceCatalogVersion pgKind, TxET QErr IO ())]
sourceMigrations
sourceMigrations :: [(SourceCatalogVersion pgKind, PG.TxE QErr ())]
sourceMigrations :: forall (pgKind :: PostgresKind).
[(SourceCatalogVersion pgKind, TxET QErr IO ())]
sourceMigrations =
$( let migrationFromFile from =
let to = succ from
path = "src-rsr/pg_source_migrations/" <> show from <> "_to_" <> show to <> ".sql"
in [|PG.multiQE defaultTxErrorHandler $(makeRelativeToProject path >>= PG.sqlFromFile)|]
migrationsFromFile = map $ \from ->
[|($(TH.lift from), $(migrationFromFile from))|]
in TH.listE $ migrationsFromFile previousSourceCatalogVersions
)
upMigrationsUntil43 :: [(Version.MetadataCatalogVersion, PG.TxE QErr ())]
upMigrationsUntil43 :: [(MetadataCatalogVersion, TxET QErr IO ())]
upMigrationsUntil43 =
$( let migrationFromFile from to =
let path = "src-rsr/migrations/" <> from <> "_to_" <> to <> ".sql"
in [|PG.multiQE defaultTxErrorHandler $(makeRelativeToProject path >>= PG.sqlFromFile)|]
migrationsFromFile = map $ \(to :: Int) ->
let from = pred to
in [|
( $(TH.lift (Version.MetadataCatalogVersion from)),
$(migrationFromFile (show from) (show to))
)
|]
in TH.listE
$ [|(Version.MetadataCatalogVersion08, $(migrationFromFile "08" "1"))|]
: migrationsFromFile [2 .. 3]
++ [|(Version.MetadataCatalogVersion 3, from3To4)|]
: migrationsFromFile [5 .. 40]
++ migrationsFromFile [42 .. 43]
)
class FetchTableMetadata (pgKind :: PostgresKind) where
fetchTableMetadata ::
forall m.
( Backend ('Postgres pgKind),
ToMetadataFetchQuery pgKind,
MonadTx m
) =>
Set.HashSet QualifiedTable ->
m (DBTablesMetadata ('Postgres pgKind))
instance FetchTableMetadata 'Vanilla where
fetchTableMetadata :: forall (m :: * -> *).
(Backend ('Postgres 'Vanilla), ToMetadataFetchQuery 'Vanilla,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres 'Vanilla))
fetchTableMetadata = HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres 'Vanilla))
forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres pgKind))
pgFetchTableMetadata
instance FetchTableMetadata 'Citus where
fetchTableMetadata :: forall (m :: * -> *).
(Backend ('Postgres 'Citus), ToMetadataFetchQuery 'Citus,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres 'Citus))
fetchTableMetadata = HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres 'Citus))
forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres pgKind))
pgFetchTableMetadata
instance FetchTableMetadata 'Cockroach where
fetchTableMetadata :: forall (m :: * -> *).
(Backend ('Postgres 'Cockroach), ToMetadataFetchQuery 'Cockroach,
MonadTx m) =>
HashSet QualifiedTable
-> m (DBTablesMetadata ('Postgres 'Cockroach))
fetchTableMetadata = HashSet QualifiedTable
-> m (DBTablesMetadata ('Postgres 'Cockroach))
forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres pgKind))
cockroachFetchTableMetadata
pgFetchTableMetadata ::
forall pgKind m.
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind, MonadTx m) =>
Set.HashSet QualifiedTable ->
m (DBTablesMetadata ('Postgres pgKind))
pgFetchTableMetadata :: forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres pgKind))
pgFetchTableMetadata HashSet QualifiedTable
tables = do
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
results <-
TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> m [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
(TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> m [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))])
-> TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> m [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
forall a b. (a -> b) -> a -> b
$ (PGTxErr -> QErr)
-> Query
-> [ViaJSON [QualifiedTable]]
-> Bool
-> TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
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
(forall (pgKind :: PostgresKind).
ToMetadataFetchQuery pgKind =>
Query
tableMetadata @pgKind)
[[QualifiedTable] -> ViaJSON [QualifiedTable]
forall a. a -> ViaJSON a
PG.ViaJSON ([QualifiedTable] -> ViaJSON [QualifiedTable])
-> [QualifiedTable] -> ViaJSON [QualifiedTable]
forall a b. (a -> b) -> a -> b
$ [QualifiedTable] -> [QualifiedTable]
forall a. Ord a => [a] -> [a]
LE.uniques ([QualifiedTable] -> [QualifiedTable])
-> [QualifiedTable] -> [QualifiedTable]
forall a b. (a -> b) -> a -> b
$ HashSet QualifiedTable -> [QualifiedTable]
forall a. HashSet a -> [a]
Set.toList HashSet QualifiedTable
tables]
Bool
True
HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
-> m (HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
-> m (HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))))
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
-> m (HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind)))
forall a b. (a -> b) -> a -> b
$ [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
([(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ (((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))])
-> [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> ((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
forall a b. (a -> b) -> [a] -> [b]
map [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
results
(((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))])
-> ((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
forall a b. (a -> b) -> a -> b
$ \(SchemaName
schema, TableName
table, PG.ViaJSON DBTableMetadata ('Postgres pgKind)
info) -> (SchemaName -> TableName -> QualifiedTable
forall a. SchemaName -> a -> QualifiedObject a
QualifiedObject SchemaName
schema TableName
table, DBTableMetadata ('Postgres pgKind)
info)
cockroachFetchTableMetadata ::
forall pgKind m.
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind, MonadTx m) =>
Set.HashSet QualifiedTable ->
m (DBTablesMetadata ('Postgres pgKind))
cockroachFetchTableMetadata :: forall (pgKind :: PostgresKind) (m :: * -> *).
(Backend ('Postgres pgKind), ToMetadataFetchQuery pgKind,
MonadTx m) =>
HashSet QualifiedTable -> m (DBTablesMetadata ('Postgres pgKind))
cockroachFetchTableMetadata HashSet QualifiedTable
_tables = do
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
results <-
TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> m [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
(TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> m [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))])
-> TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> m [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
forall a b. (a -> b) -> a -> b
$ (PGTxErr -> QErr)
-> Query
-> [PrepArg]
-> Bool
-> TxE
QErr
[(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> [PrepArg] -> Bool -> TxET e m a
PG.rawQE
PGTxErr -> QErr
defaultTxErrorHandler
(forall (pgKind :: PostgresKind).
ToMetadataFetchQuery pgKind =>
Query
tableMetadata @pgKind)
[]
Bool
True
HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
-> m (HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
-> m (HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))))
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
-> m (HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind)))
forall a b. (a -> b) -> a -> b
$ [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
([(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
-> HashMap QualifiedTable (DBTableMetadata ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ (((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))])
-> [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> ((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
forall a b. (a -> b) -> [a] -> [b]
map [(SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))]
results
(((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))])
-> ((SchemaName, TableName,
ViaJSON (DBTableMetadata ('Postgres pgKind)))
-> (QualifiedTable, DBTableMetadata ('Postgres pgKind)))
-> [(QualifiedTable, DBTableMetadata ('Postgres pgKind))]
forall a b. (a -> b) -> a -> b
$ \(SchemaName
schema, TableName
table, PG.ViaJSON DBTableMetadata ('Postgres pgKind)
info) -> (SchemaName -> TableName -> QualifiedTable
forall a. SchemaName -> a -> QualifiedObject a
QualifiedObject SchemaName
schema TableName
table, DBTableMetadata ('Postgres pgKind)
info)
class FetchFunctionMetadata (pgKind :: PostgresKind) where
fetchFunctionMetadata ::
(MonadTx m) =>
Set.HashSet QualifiedFunction ->
m (DBFunctionsMetadata ('Postgres pgKind))
instance FetchFunctionMetadata 'Vanilla where
fetchFunctionMetadata :: forall (m :: * -> *).
MonadTx m =>
HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres 'Vanilla))
fetchFunctionMetadata = HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres 'Vanilla))
forall (m :: * -> *) (pgKind :: PostgresKind).
MonadTx m =>
HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres pgKind))
pgFetchFunctionMetadata
instance FetchFunctionMetadata 'Citus where
fetchFunctionMetadata :: forall (m :: * -> *).
MonadTx m =>
HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres 'Citus))
fetchFunctionMetadata = HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres 'Citus))
forall (m :: * -> *) (pgKind :: PostgresKind).
MonadTx m =>
HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres pgKind))
pgFetchFunctionMetadata
instance FetchFunctionMetadata 'Cockroach where
fetchFunctionMetadata :: forall (m :: * -> *).
MonadTx m =>
HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres 'Cockroach))
fetchFunctionMetadata HashSet QualifiedFunction
_ = HashMap
QualifiedFunction (FunctionOverloads ('Postgres 'Cockroach))
-> m (HashMap
QualifiedFunction (FunctionOverloads ('Postgres 'Cockroach)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap
QualifiedFunction (FunctionOverloads ('Postgres 'Cockroach))
forall a. Monoid a => a
mempty
pgFetchFunctionMetadata :: (MonadTx m) => Set.HashSet QualifiedFunction -> m (DBFunctionsMetadata ('Postgres pgKind))
pgFetchFunctionMetadata :: forall (m :: * -> *) (pgKind :: PostgresKind).
MonadTx m =>
HashSet QualifiedFunction
-> m (DBFunctionsMetadata ('Postgres pgKind))
pgFetchFunctionMetadata HashSet QualifiedFunction
functions = do
[(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
results <-
TxE
QErr
[(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
-> m [(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
(TxE
QErr
[(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
-> m [(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))])
-> TxE
QErr
[(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
-> m [(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
forall a b. (a -> b) -> a -> b
$ (PGTxErr -> QErr)
-> Query
-> [ViaJSON (HashSet QualifiedFunction)]
-> Bool
-> TxE
QErr
[(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
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
$(makeRelativeToProject "src-rsr/pg_function_metadata.sql" >>= PG.sqlFromFile)
[HashSet QualifiedFunction -> ViaJSON (HashSet QualifiedFunction)
forall a. a -> ViaJSON a
PG.ViaJSON HashSet QualifiedFunction
functions]
Bool
True
HashMap QualifiedFunction (FunctionOverloads ('Postgres pgKind))
-> m (HashMap
QualifiedFunction (FunctionOverloads ('Postgres pgKind)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(HashMap QualifiedFunction (FunctionOverloads ('Postgres pgKind))
-> m (HashMap
QualifiedFunction (FunctionOverloads ('Postgres pgKind))))
-> HashMap QualifiedFunction (FunctionOverloads ('Postgres pgKind))
-> m (HashMap
QualifiedFunction (FunctionOverloads ('Postgres pgKind)))
forall a b. (a -> b) -> a -> b
$ [(QualifiedFunction, FunctionOverloads ('Postgres pgKind))]
-> HashMap QualifiedFunction (FunctionOverloads ('Postgres pgKind))
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
([(QualifiedFunction, FunctionOverloads ('Postgres pgKind))]
-> HashMap
QualifiedFunction (FunctionOverloads ('Postgres pgKind)))
-> [(QualifiedFunction, FunctionOverloads ('Postgres pgKind))]
-> HashMap QualifiedFunction (FunctionOverloads ('Postgres pgKind))
forall a b. (a -> b) -> a -> b
$ (((SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))
-> (QualifiedFunction, FunctionOverloads ('Postgres pgKind)))
-> [(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
-> [(QualifiedFunction, FunctionOverloads ('Postgres pgKind))])
-> [(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
-> ((SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))
-> (QualifiedFunction, FunctionOverloads ('Postgres pgKind)))
-> [(QualifiedFunction, FunctionOverloads ('Postgres pgKind))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))
-> (QualifiedFunction, FunctionOverloads ('Postgres pgKind)))
-> [(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
-> [(QualifiedFunction, FunctionOverloads ('Postgres pgKind))]
forall a b. (a -> b) -> [a] -> [b]
map [(SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))]
results
(((SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))
-> (QualifiedFunction, FunctionOverloads ('Postgres pgKind)))
-> [(QualifiedFunction, FunctionOverloads ('Postgres pgKind))])
-> ((SchemaName, FunctionName,
ViaJSON (FunctionOverloads ('Postgres pgKind)))
-> (QualifiedFunction, FunctionOverloads ('Postgres pgKind)))
-> [(QualifiedFunction, FunctionOverloads ('Postgres pgKind))]
forall a b. (a -> b) -> a -> b
$ \(SchemaName
schema, FunctionName
table, PG.ViaJSON FunctionOverloads ('Postgres pgKind)
infos) -> (SchemaName -> FunctionName -> QualifiedFunction
forall a. SchemaName -> a -> QualifiedObject a
QualifiedObject SchemaName
schema FunctionName
table, FunctionOverloads ('Postgres pgKind)
infos)
fetchPgScalars :: (MonadTx m) => m (HashSet PGScalarType)
fetchPgScalars :: forall (m :: * -> *). MonadTx m => m (HashSet PGScalarType)
fetchPgScalars =
TxE QErr (HashSet PGScalarType) -> m (HashSet PGScalarType)
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
(TxE QErr (HashSet PGScalarType) -> m (HashSet PGScalarType))
-> TxE QErr (HashSet PGScalarType) -> m (HashSet PGScalarType)
forall a b. (a -> b) -> a -> b
$ ViaJSON (HashSet PGScalarType) -> HashSet PGScalarType
forall a. ViaJSON a -> a
PG.getViaJSON
(ViaJSON (HashSet PGScalarType) -> HashSet PGScalarType)
-> (SingleRow (Identity (ViaJSON (HashSet PGScalarType)))
-> ViaJSON (HashSet PGScalarType))
-> SingleRow (Identity (ViaJSON (HashSet PGScalarType)))
-> HashSet PGScalarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (ViaJSON (HashSet PGScalarType))
-> ViaJSON (HashSet PGScalarType)
forall a. Identity a -> a
runIdentity
(Identity (ViaJSON (HashSet PGScalarType))
-> ViaJSON (HashSet PGScalarType))
-> (SingleRow (Identity (ViaJSON (HashSet PGScalarType)))
-> Identity (ViaJSON (HashSet PGScalarType)))
-> SingleRow (Identity (ViaJSON (HashSet PGScalarType)))
-> ViaJSON (HashSet PGScalarType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity (ViaJSON (HashSet PGScalarType)))
-> Identity (ViaJSON (HashSet PGScalarType))
forall a. SingleRow a -> a
PG.getRow
(SingleRow (Identity (ViaJSON (HashSet PGScalarType)))
-> HashSet PGScalarType)
-> TxET
QErr IO (SingleRow (Identity (ViaJSON (HashSet PGScalarType))))
-> TxE QErr (HashSet PGScalarType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> ()
-> Bool
-> TxET
QErr IO (SingleRow (Identity (ViaJSON (HashSet PGScalarType))))
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 coalesce(json_agg(typname), '[]')
FROM pg_catalog.pg_type where typtype = 'b'
|]
()
Bool
True
postDropSourceHook ::
(MonadIO m, MonadError QErr m, MonadBaseControl IO m) =>
SourceConfig ('Postgres pgKind) ->
TableEventTriggers ('Postgres pgKind) ->
m ()
postDropSourceHook :: forall (m :: * -> *) (pgKind :: PostgresKind).
(MonadIO m, MonadError QErr m, MonadBaseControl IO m) =>
SourceConfig ('Postgres pgKind)
-> TableEventTriggers ('Postgres pgKind) -> m ()
postDropSourceHook SourceConfig ('Postgres pgKind)
sourceConfig TableEventTriggers ('Postgres pgKind)
tableTriggersMap = do
m (Either QErr ()) -> m ()
forall e (m :: * -> *) a. MonadError e m => m (Either e a) -> m a
liftEitherM
(m (Either QErr ()) -> m ()) -> m (Either QErr ()) -> m ()
forall a b. (a -> b) -> a -> b
$ PGSourceConfig
-> PGExecFrom -> TxET QErr m () -> m (Either QErr ())
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
PGSourceConfig -> PGExecFrom -> TxET QErr m a -> m (Either QErr a)
runPgSourceWriteTx SourceConfig ('Postgres pgKind)
PGSourceConfig
sourceConfig PGExecFrom
InternalRawQuery
(TxET QErr m () -> m (Either QErr ()))
-> TxET QErr m () -> m (Either QErr ())
forall a b. (a -> b) -> a -> b
$ do
Bool
hdbMetadataTableExist <- SchemaName -> TableName -> TxET QErr m Bool
forall (m :: * -> *).
MonadTx m =>
SchemaName -> TableName -> m Bool
doesTableExist SchemaName
"hdb_catalog" TableName
"hdb_metadata"
if
| Bool
hdbMetadataTableExist -> do
[(QualifiedTable, [TriggerName])]
-> ((QualifiedTable, [TriggerName]) -> TxET QErr m ())
-> TxET QErr m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (HashMap QualifiedTable [TriggerName]
-> [(QualifiedTable, [TriggerName])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList TableEventTriggers ('Postgres pgKind)
HashMap QualifiedTable [TriggerName]
tableTriggersMap) (((QualifiedTable, [TriggerName]) -> TxET QErr m ())
-> TxET QErr m ())
-> ((QualifiedTable, [TriggerName]) -> TxET QErr m ())
-> TxET QErr m ()
forall a b. (a -> b) -> a -> b
$ \(QualifiedTable
_table, [TriggerName]
triggers) ->
[TriggerName] -> (TriggerName -> TxET QErr m ()) -> TxET QErr m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TriggerName]
triggers ((TriggerName -> TxET QErr m ()) -> TxET QErr m ())
-> (TriggerName -> TxET QErr m ()) -> TxET QErr m ()
forall a b. (a -> b) -> a -> b
$ \TriggerName
triggerName ->
TxET QErr IO () -> TxET QErr m ()
forall a. TxE QErr a -> TxET QErr m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx (TxET QErr IO () -> TxET QErr m ())
-> TxET QErr IO () -> TxET QErr m ()
forall a b. (a -> b) -> a -> b
$ TriggerName -> TxET QErr IO ()
dropTriggerQ TriggerName
triggerName
(PGTxErr -> QErr) -> Query -> TxET QErr m ()
forall (m :: * -> *) a e.
(MonadIO m, FromRes a) =>
(PGTxErr -> e) -> Query -> TxET e m a
PG.multiQE
PGTxErr -> QErr
defaultTxErrorHandler
$(makeRelativeToProject "src-rsr/drop_pg_source.sql" >>= PG.sqlFromFile)
| Bool
otherwise ->
TxET QErr m ()
forall (m :: * -> *). MonadTx m => m ()
dropHdbCatalogSchema
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ PGExecCtx -> IO ()
_pecDestroyConnections (PGSourceConfig -> PGExecCtx
_pscExecCtx SourceConfig ('Postgres pgKind)
PGSourceConfig
sourceConfig)
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ PGSourceConfig -> IO ()
_pscPostDropHook SourceConfig ('Postgres pgKind)
PGSourceConfig
sourceConfig