insert rewards & epoch stake to use manual constraint lower number of indexes in tests fourmolurize
startDBSync,
withDBSyncEnv,
withFullConfig,
withFullConfigAndLogs,
withCustomConfig,
withCustomConfigAndLogs,
withFullConfig',
IO a
withFullConfig = withFullConfig' True False initCommandLineArgs
withFullConfigAndLogs ::
FilePath ->
FilePath ->
(Interpreter -> ServerHandle IO CardanoBlock -> DBSyncEnv -> IO a) ->
IOManager ->
[(Text, Text)] ->
IO a
withFullConfigAndLogs = withFullConfig' True True initCommandLineArgs
withCustomConfig ::
CommandLineArgs ->
-- | config filepath
withCustomConfig commandLineForceIndexArgs babbageConfigDir testLabel $ \_ _ dbSyncEnv -> do
startDBSync dbSyncEnv
threadDelay 3_000_000
assertEqQuery dbSyncEnv DB.queryPgIndexesCount 160 "there wasn't the correct number of indexes"
assertEqQuery dbSyncEnv DB.queryPgIndexesCount 159 "there wasn't the correct number of indexes"
where
testLabel = "CLAcheckForceIndexesArg"
commandLineForceIndexArgs =
withCustomConfig commandLineNoForceIndexArgs babbageConfigDir testLabel $ \_ _ dbSyncEnv -> do
startDBSync dbSyncEnv
threadDelay 3_000_000
assertEqQuery dbSyncEnv DB.queryPgIndexesCount 95 "there wasn't the correct number of indexes"
assertEqQuery dbSyncEnv DB.queryPgIndexesCount 94 "there wasn't the correct number of indexes"
where
testLabel = "CLAcheckNoForceIndexesArg"
commandLineNoForceIndexArgs =
block2 <- forgeNext interpreter mockBlock2
let blkNo = blockNo block2
assertBool (show blkNo <> " /= " <> "3") $
blkNo == BlockNo 3
blkNo
== BlockNo 3
where
testLabel = "forgeBlocks"
Cardano.DbSync.Util.Address
Cardano.DbSync.Util.Bech32
Cardano.DbSync.Util.Cbor
Cardano.DbSync.Util.Constraint
Paths_cardano_db_sync
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE RankNTypes #-}
module Cardano.DbSync.Default (
insertListBlocks,
import Cardano.DbSync.Rollback
import Cardano.DbSync.Types
import Cardano.DbSync.Util
import Cardano.DbSync.Util.Constraint (epochStakeConstraintName, rewardConstraintName)
import qualified Cardano.Ledger.Alonzo.Scripts as Ledger
import Cardano.Ledger.Shelley.AdaPots as Shelley
import Cardano.Prelude
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Strict.Maybe as Strict
import Database.Persist.Postgresql (ConstraintNameDB (..), FieldNameDB (..), PersistEntity (entityDef))
import Database.Persist.Postgresql (FieldNameDB (..), PersistEntity (entityDef))
import Database.Persist.SqlBackend.Internal
import Database.Persist.SqlBackend.Internal.StatementCache
import Ouroboros.Consensus.Cardano.Block (HardForkBlock (..))
-- equal, insert the block and restore consistency between ledger and db.
case eiBlockInDbAlreadyId of
Left _ -> do
liftIO . logInfo tracer $
mconcat
liftIO
. logInfo tracer
$ mconcat
[ "Received block which is not in the db with "
, textShow (getHeaderFields cblk)
, ". Time to restore consistency."
-- we can put the constraints on rewards table
lift addRewardTableConstraint
lift addEpochStakeTableConstraint
Right blockId | Just (adaPots, slotNo, epochNo) <- getAdaPots applyRes -> do
replaced <- lift $ DB.replaceAdaPots blockId $ mkAdaPots blockId slotNo epochNo adaPots
if replaced
Generic.neEpoch <$> maybeFromStrict (apNewEpoch appRes)
addRewardTableConstraint ::
forall m. ( MonadBaseControl IO m , MonadIO m) => ReaderT SqlBackend m ()
forall m. (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
addRewardTableConstraint = do
let entityD = entityDef $ Proxy @DB.Reward
DB.alterTable
entityD
( DB.AddUniqueConstraint
(ConstraintNameDB "unique_reward")
rewardConstraintName
[ FieldNameDB "addr_id"
, FieldNameDB "type"
, FieldNameDB "earned_epoch"
)
addEpochStakeTableConstraint ::
forall m. ( MonadBaseControl IO m , MonadIO m) => ReaderT SqlBackend m ()
forall m. (MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
addEpochStakeTableConstraint = do
let entityD = entityDef $ Proxy @DB.EpochStake
DB.alterTable
entityD
( DB.AddUniqueConstraint
(ConstraintNameDB "epoch_no")
[ FieldNameDB "addr_id"
epochStakeConstraintName
[ FieldNameDB "epoch_no"
, FieldNameDB "addr_id"
, FieldNameDB "pool_id"
]
)
-- update the epoch
updateEpoch details isNewEpochEvent
whenPruneTxOut syncEnv $
when (unBlockNo blkNo `mod` getPruneInterval syncEnv == 0) $ do
lift $ DB.deleteConsumedTxOut tracer (getSafeBlockNoDiff syncEnv)
when (unBlockNo blkNo `mod` getPruneInterval syncEnv == 0) $
do
lift $ DB.deleteConsumedTxOut tracer (getSafeBlockNoDiff syncEnv)
lift $ commitOrIndexes withinTwoMin withinHalfHour
where
tracer = getTrace syncEnv
-- What we do here is completely independent of Shelley/Allegra/Mary eras.
epochSlotTimecheck :: ReaderT SqlBackend (LoggingT IO) (Either SyncNodeError ())
epochSlotTimecheck = do
when (sdSlotTime details > sdCurrentTime details) $
liftIO . logError trce $
mconcat
["Slot time '", textShow (sdSlotTime details), "' is in the future"]
when (sdSlotTime details > sdCurrentTime details)
$ liftIO
. logError trce
$ mconcat
["Slot time '", textShow (sdSlotTime details), "' is in the future"]
updateEpochStart syncEnv cache details isNewEpochEvent False
updateEpochStart ::
import Cardano.DbSync.Era.Util (liftLookupFail)
import Cardano.DbSync.Error
import Cardano.DbSync.Types
import Cardano.DbSync.Util.Constraint (epochStakeConstraintName, rewardConstraintName)
import Cardano.Ledger.BaseTypes (Network)
import qualified Cardano.Ledger.Coin as Shelley
import Cardano.Prelude
ExceptT SyncNodeError (ReaderT SqlBackend m) ()
insertStakeSlice _ Generic.NoSlices = pure ()
insertStakeSlice syncEnv (Generic.Slice slice finalSlice) = do
insertEpochStake (envCache syncEnv) network (Generic.sliceEpochNo slice) (Map.toList $ Generic.sliceDistr slice)
insertEpochStake syncEnv network (Generic.sliceEpochNo slice) (Map.toList $ Generic.sliceDistr slice)
when finalSlice $ do
lift $ DB.updateSetComplete $ unEpochNo $ Generic.sliceEpochNo slice
size <- lift $ DB.queryEpochStakeCount (unEpochNo $ Generic.sliceEpochNo slice)
liftIO . logInfo tracer $
mconcat ["Inserted ", show size, " EpochStake for ", show (Generic.sliceEpochNo slice)]
liftIO
. logInfo tracer
$ mconcat ["Inserted ", show size, " EpochStake for ", show (Generic.sliceEpochNo slice)]
where
tracer :: Trace IO Text
tracer = getTrace syncEnv
insertEpochStake ::
(MonadBaseControl IO m, MonadIO m) =>
Cache ->
SyncEnv ->
Network ->
EpochNo ->
[(StakeCred, (Shelley.Coin, PoolKeyHash))] ->
ExceptT SyncNodeError (ReaderT SqlBackend m) ()
insertEpochStake cache nw epochNo stakeChunk = do
dbStakes <- mapM mkStake stakeChunk
lift $ DB.insertManyEpochStakes dbStakes
insertEpochStake syncEnv nw epochNo stakeChunk = do
let cache = envCache syncEnv
dbStakes <- mapM (mkStake cache) stakeChunk
lift $ DB.insertManyEpochStakes epochStakeConstraintName dbStakes
where
mkStake ::
(MonadBaseControl IO m, MonadIO m) =>
Cache ->
(StakeCred, (Shelley.Coin, PoolKeyHash)) ->
ExceptT SyncNodeError (ReaderT SqlBackend m) DB.EpochStake
mkStake (saddr, (coin, pool)) = do
mkStake cache (saddr, (coin, pool)) = do
saId <- liftLookupFail "insertEpochStake.queryStakeAddrWithCache" $ queryStakeAddrWithCache cache CacheNew nw saddr
poolId <- liftLookupFail "insertEpochStake.queryPoolKeyWithCache" $ queryPoolKeyWithCache cache CacheNew pool
pure $
dbRewards <- concatMapM mkRewards rewardsChunk
let chunckDbRewards = splittRewardsEvery 100000 dbRewards
-- minimising the bulk inserts into hundred thousand chunks to improve performance
forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyRewards rws
forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyRewards rewardConstraintName rws
where
mkRewards ::
(MonadBaseControl IO m, MonadIO m) =>
{-# LANGUAGE OverloadedStrings #-}
module Cardano.DbSync.Util.Constraint (
epochStakeConstraintName,
rewardConstraintName,
) where
import Database.Persist.Names (ConstraintNameDB (..))
epochStakeConstraintName :: ConstraintNameDB
epochStakeConstraintName = ConstraintNameDB "unique_epoch_stake"
rewardConstraintName :: ConstraintNameDB
rewardConstraintName = ConstraintNameDB "unique_reward"
queryTxOutConsumedCount,
) where
import Cardano.Db.AlterTable as X
import Cardano.Db.Delete as X
import Cardano.Db.Error as X
import Cardano.Db.Insert as X
import Cardano.Db.AlterTable as X
import Cardano.Db.Migration as X
import Cardano.Db.Migration.Extra.CosnumedTxOut.Queries (migrateTxOut, queryTxConsumedColumnExists, queryTxOutConsumedCount, queryTxOutConsumedNullCount)
import Cardano.Db.Migration.Version as X
{-# OPTIONS_GHC -Wno-unused-local-binds #-}
module Cardano.Db.AlterTable (
AlterTable(..),
DbAlterTableException(..),
AlterTable (..),
DbAlterTableException (..),
alterTable,
) where
import Control.Exception.Lifted (Exception, handle, throwIO)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Reader (ReaderT)
import qualified Data.Text as T
import Database.Persist.Postgresql (ConstraintNameDB (..), EntityNameDB (..), FieldNameDB (..), SqlBackend, rawExecute, EntityDef, getEntityFields, fieldDB)
import Database.PostgreSQL.Simple (SqlError (..), ExecStatus (..))
import qualified Data.Text as Text
import Database.Persist.EntityDef.Internal (entityDB)
import Database.Persist.Postgresql (ConstraintNameDB (..), EntityDef, EntityNameDB (..), FieldNameDB (..), Single (..), SqlBackend, fieldDB, getEntityFields, rawExecute, rawSql)
import Database.PostgreSQL.Simple (ExecStatus (..), SqlError (..))
-- The ability to `ALTER TABLE` currently dealing with `CONSTRAINT` but can be extended
data AlterTable
AlterTable ->
ReaderT SqlBackend m ()
alterTable entity (AddUniqueConstraint cname cols) = do
-- Check that input fields are indeed present
if checkAllFieldsValid entity cols
then handle alterTableExceptHandler (rawExecute query [])
else liftIO $ throwIO (DbAlterTableException "Constraint field does not exist" sqlError)
then do
constraintRes <- queryHasConstraint cname
if constraintRes
then -- the constraint already exists so do nothing
pure ()
else -- if it doesn't exist then add a new constraint
handle alterTableExceptHandler (rawExecute queryAddConstraint [])
else throwErr "Some of the unique values which that are being added to the constraint don't correlate with what exists"
where
query :: T.Text
query =
T.concat
queryAddConstraint :: Text.Text
queryAddConstraint =
Text.concat
[ "ALTER TABLE "
, unEntityNameDB (entityDB entity)
, " ADD CONSTRAINT IF NOT EXISTS "
, " ADD CONSTRAINT "
, unConstraintNameDB cname
, " UNIQUE("
, T.intercalate "," $ map escapeDBName' cols
, Text.intercalate "," $ map escapeDBName' cols
, ")"
]
escapeDBName' :: FieldNameDB -> T.Text
escapeDBName' name = unFieldNameDB name
escapeDBName' :: FieldNameDB -> Text.Text
escapeDBName' = unFieldNameDB
throwErr :: forall m'. MonadIO m' => [Char] -> ReaderT SqlBackend m' ()
throwErr e = liftIO $ throwIO (DbAlterTableException e sqlError)
alterTable entity (DropUniqueConstraint cname) =
handle alterTableExceptHandler (rawExecute query [])
where
query :: T.Text
query :: Text.Text
query =
T.concat
Text.concat
[ "ALTER TABLE "
, unEntityNameDB (entityDB entity)
, " DROP CONSTRAINT IF EXISTS "
, unConstraintNameDB cname
]
-- check if a constraint is already present
queryHasConstraint ::
MonadIO m =>
ConstraintNameDB ->
ReaderT SqlBackend m Bool
queryHasConstraint cname = do
constraintRes :: [Single Int] <- rawSql queryCheckConstraint []
if constraintRes == [Single 1]
then pure True
else pure False
where
queryCheckConstraint :: Text.Text
queryCheckConstraint =
Text.concat
[ "SELECT COUNT(*) FROM pg_constraint WHERE conname ='"
, unConstraintNameDB cname
, "'"
]
-- check to see that the field inputs exist
checkAllFieldsValid :: Foldable t => EntityDef -> t FieldNameDB -> Bool
checkAllFieldsValid entity cols = do
alterTableExceptHandler e = liftIO $ throwIO (DbAlterTableException "" e)
sqlError :: SqlError
sqlError = SqlError
{ sqlState = ""
, sqlExecStatus = FatalError
, sqlErrorMsg = ""
, sqlErrorDetail = ""
, sqlErrorHint = ""
}
sqlError =
SqlError
{ sqlState = ""
, sqlExecStatus = FatalError
, sqlErrorMsg = ""
, sqlErrorDetail = ""
, sqlErrorHint = ""
}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Cardano.Db.Insert (
insertAdaPots,
toPersistFields,
toPersistValue,
uniqueDBName,
uniqueFields, getEntityForeignDefs,
uniqueFields,
)
import qualified Database.Persist.Sql.Util as Util
import Database.Persist.Types (
ConstraintNameDB (..),
Entity (..),
EntityNameDB (..),
FieldNameDB (..),
ForeignDef (..),
PersistValue,
entityKey,
)
insertExtraKeyWitness :: (MonadBaseControl IO m, MonadIO m) => ExtraKeyWitness -> ReaderT SqlBackend m ExtraKeyWitnessId
insertExtraKeyWitness = insertUnchecked "ExtraKeyWitness"
insertManyEpochStakes :: (MonadBaseControl IO m, MonadIO m) => [EpochStake] -> ReaderT SqlBackend m ()
insertManyEpochStakes = insertManyWithUnique "Many EpochStake"
insertManyEpochStakes :: (MonadBaseControl IO m, MonadIO m) => ConstraintNameDB -> [EpochStake] -> ReaderT SqlBackend m ()
insertManyEpochStakes = insertManyWithManualUnique "Many EpochStake"
insertManyRewards :: (MonadBaseControl IO m, MonadIO m) => [Reward] -> ReaderT SqlBackend m ()
insertManyRewards = insertManyWithUnique "Many Rewards"
insertManyRewards :: (MonadBaseControl IO m, MonadIO m) => ConstraintNameDB -> [Reward] -> ReaderT SqlBackend m ()
insertManyRewards = insertManyWithManualUnique "Many Rewards"
insertManyTxIn :: (MonadBaseControl IO m, MonadIO m) => [TxIn] -> ReaderT SqlBackend m [TxInId]
insertManyTxIn = insertMany' "Many TxIn"
insertEpochStakeProgress :: (MonadBaseControl IO m, MonadIO m) => [EpochStakeProgress] -> ReaderT SqlBackend m ()
insertEpochStakeProgress =
insertManyWithUnique "Many EpochStakeProgress"
insertManyUncheckedUnique "Many EpochStakeProgress"
updateSetComplete :: MonadIO m => Word64 -> ReaderT SqlBackend m ()
updateSetComplete epoch = do
exceptHandler e =
liftIO $ throwIO (DbInsertException vtype e)
insertManyWithUnique ::
insertManyWithManualUnique ::
forall m record.
( MonadBaseControl IO m
, MonadIO m
, PersistRecordBackend record SqlBackend
) =>
String ->
ConstraintNameDB ->
[record] ->
ReaderT SqlBackend m ()
insertManyWithUnique vtype records = do
let foreingDefs = getEntityForeignDefs $ entityDef $ Proxy @record
unless (null records || null foreingDefs) $
handle exceptHandler (rawExecute (query foreingDefs) values)
insertManyWithManualUnique vtype constraintName records = do
-- let foreingDefs = getEntityForeignDefs $ entityDef $ Proxy @record
unless (null records) $
handle exceptHandler (rawExecute query values)
where
query :: [ForeignDef] -> Text
query :: Text
-- the pattern is incomplete but the list will not be empty due to null check
query [ForeignDef {..}] =
query =
Text.concat
[ "INSERT INTO "
, unEntityNameDB (entityDB . entityDef $ records)
. Util.commaSeparated
$ placeholders
, " ON CONFLICT ON CONSTRAINT "
, unConstraintNameDB foreignConstraintNameDBName
, unConstraintNameDB constraintName
, " DO NOTHING"
]
values :: [PersistValue]
values = concatMap (map toPersistValue . toPersistFields) records
fieldNames, placeholders :: [Text]
(fieldNames, placeholders) =
unzip (Util.mkInsertPlaceholders (entityDef (Proxy @record)) escapeFieldName)
exceptHandler :: SqlError -> ReaderT SqlBackend m a
exceptHandler e =
liftIO $ throwIO (DbInsertException vtype e)
insertManyUncheckedUnique ::
forall m record.
( MonadBaseControl IO m
, MonadIO m
, OnlyOneUniqueKey record
) =>
String ->
[record] ->
ReaderT SqlBackend m ()
insertManyUncheckedUnique vtype records =
unless (null records) $
handle exceptHandler (rawExecute query values)
where
query :: Text
query =
Text.concat
[ "INSERT INTO "
, unEntityNameDB (entityDB . entityDef $ records)
, " ("
, Util.commaSeparated fieldNames
, ") VALUES "
, Util.commaSeparated
. replicate (length records)
. Util.parenWrapped
. Util.commaSeparated
$ placeholders
, " ON CONFLICT ON CONSTRAINT "
, unConstraintNameDB (uniqueDBName $ onlyOneUniqueDef (Proxy @record))
, " DO NOTHING"
]
* Removed call to tail, and the 'watchPulser' test Co-authored-by: Alexey Kuleshevich <[email protected]>
![github-actions[bot]](https://avatars.githubusercontent.com/in/15368?v=4&s=80)
* Add `pvCanFollow` check to `GOV` STS * Add that `validHFAction` also looks at the current `EnactState`
Reimplementation of #496 targetting #819, which include the more general changes of #500.
Introduces `IOSimThreadIdMap` data type as an optimization over the previous time and memory innefficient Map data structure.
To prevent aborting the wrong Head `headId` was added to the `OnAbortTx`. Logic layer now aborts the head that is seen as initialized.
Co-authored-by: Torsten Schmits <[email protected]>
