From 68dbf7ba0b9d430dca4f4c199812fb593013ce11 Mon Sep 17 00:00:00 2001 From: Cmdv Date: Tue, 5 Mar 2024 13:37:33 +0000 Subject: [PATCH] create a Universal & Conway Era --- cardano-db-sync/cardano-db-sync.cabal | 27 +- .../src/Cardano/DbSync/Api/Ledger.hs | 4 +- cardano-db-sync/src/Cardano/DbSync/Default.hs | 128 +------ .../{Shelley/Insert => Conway}/GovAction.hs | 4 +- .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 6 +- .../src/Cardano/DbSync/Era/Shelley/Insert.hs | 284 -------------- .../DbSync/Era/Shelley/Insert/Epoch.hs | 211 ---------- .../Era/{Shelley => Universal}/Adjust.hs | 2 +- .../src/Cardano/DbSync/Era/Universal/Block.hs | 185 +++++++++ .../src/Cardano/DbSync/Era/Universal/Epoch.hs | 339 +++++++++++++++++ .../Insert/Certificate.hs | 6 +- .../DbSync/Era/Universal/Insert/GovAction.hs | 360 ++++++++++++++++++ .../{Shelley => Universal}/Insert/Grouped.hs | 2 +- .../Era/Universal/Insert/LedgerEvent.hs | 101 +++++ .../{Shelley => Universal}/Insert/Other.hs | 4 +- .../Era/{Shelley => Universal}/Insert/Pool.hs | 3 +- .../Era/{Shelley => Universal}/Insert/Tx.hs | 12 +- .../Era/{Shelley => Universal}/Validate.hs | 2 +- .../src/Cardano/DbSync/Fix/EpochStake.hs | 2 +- 19 files changed, 1039 insertions(+), 643 deletions(-) rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley/Insert => Conway}/GovAction.hs (99%) delete mode 100644 cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs delete mode 100644 cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley => Universal}/Adjust.hs (98%) create mode 100644 cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs create mode 100644 cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley => Universal}/Insert/Certificate.hs (98%) create mode 100644 cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley => Universal}/Insert/Grouped.hs (99%) create mode 100644 cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley => Universal}/Insert/Other.hs (98%) rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley => Universal}/Insert/Pool.hs (99%) rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley => Universal}/Insert/Tx.hs (97%) rename cardano-db-sync/src/Cardano/DbSync/Era/{Shelley => Universal}/Validate.hs (99%) diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index 4cbf94f21..f6524707e 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -63,17 +63,16 @@ library Cardano.DbSync.Era.Byron.Util Cardano.DbSync.Era.Cardano.Insert Cardano.DbSync.Era.Cardano.Util - Cardano.DbSync.Era.Shelley.Adjust Cardano.DbSync.Era.Shelley.Generic Cardano.DbSync.Era.Shelley.Generic.Block Cardano.DbSync.Era.Shelley.Generic.EpochUpdate + Cardano.DbSync.Era.Shelley.Generic.Metadata + Cardano.DbSync.Era.Shelley.Generic.ParamProposal Cardano.DbSync.Era.Shelley.Generic.ProtoParams Cardano.DbSync.Era.Shelley.Generic.Rewards Cardano.DbSync.Era.Shelley.Generic.Script Cardano.DbSync.Era.Shelley.Generic.ScriptData Cardano.DbSync.Era.Shelley.Generic.StakeDist - Cardano.DbSync.Era.Shelley.Generic.Metadata - Cardano.DbSync.Era.Shelley.Generic.ParamProposal Cardano.DbSync.Era.Shelley.Generic.Tx Cardano.DbSync.Era.Shelley.Generic.Tx.Allegra Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo @@ -85,17 +84,19 @@ library Cardano.DbSync.Era.Shelley.Generic.Util Cardano.DbSync.Era.Shelley.Generic.Witness Cardano.DbSync.Era.Shelley.Genesis - Cardano.DbSync.Era.Shelley.Insert - Cardano.DbSync.Era.Shelley.Insert.Certificate - Cardano.DbSync.Era.Shelley.Insert.Epoch - Cardano.DbSync.Era.Shelley.Insert.GovAction - Cardano.DbSync.Era.Shelley.Insert.Grouped - Cardano.DbSync.Era.Shelley.Insert.Other - Cardano.DbSync.Era.Shelley.Insert.Pool - Cardano.DbSync.Era.Shelley.Insert.Tx - Cardano.DbSync.Era.Shelley.Query - Cardano.DbSync.Era.Shelley.Validate + Cardano.DbSync.Era.Universal.Adjust + Cardano.DbSync.Era.Universal.Block + Cardano.DbSync.Era.Universal.Epoch + Cardano.DbSync.Era.Universal.Validate + Cardano.DbSync.Era.Universal.Insert.Certificate + Cardano.DbSync.Era.Universal.Insert.GovAction + Cardano.DbSync.Era.Universal.Insert.Grouped + Cardano.DbSync.Era.Universal.Insert.LedgerEvent + Cardano.DbSync.Era.Universal.Insert.Other + Cardano.DbSync.Era.Universal.Insert.Pool + Cardano.DbSync.Era.Universal.Insert.Tx + -- Temporary debugging validation Cardano.DbSync.Era.Shelley.ValidateWithdrawal diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs index f9f9fab42..6731070c5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs @@ -13,8 +13,8 @@ import Cardano.DbSync.Api.Types import Cardano.DbSync.Era.Shelley.Generic.Tx.Babbage (fromTxOut) import Cardano.DbSync.Era.Shelley.Generic.Tx.Types (DBPlutusScript) import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic -import Cardano.DbSync.Era.Shelley.Insert.Grouped -import Cardano.DbSync.Era.Shelley.Insert.Tx (insertTxOut) +import Cardano.DbSync.Era.Universal.Insert.Grouped +import Cardano.DbSync.Era.Universal.Insert.Tx (insertTxOut) import Cardano.DbSync.Era.Util import Cardano.DbSync.Error import Cardano.DbSync.Ledger.State diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index d4ec85050..bb65ed12e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -16,19 +16,15 @@ import qualified Cardano.Db as DB import Cardano.DbSync.Api import Cardano.DbSync.Api.Ledger import Cardano.DbSync.Api.Types (ConsistentLevel (..), InsertOptions (..), LedgerEnv (..), SyncEnv (..), SyncOptions (..)) -import Cardano.DbSync.Cache.Types (textShowStats) import Cardano.DbSync.Epoch (epochHandler) import Cardano.DbSync.Era.Byron.Insert (insertByronBlock) -import Cardano.DbSync.Era.Cardano.Insert (insertEpochSyncTime) -import Cardano.DbSync.Era.Shelley.Adjust (adjustEpochRewards) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Era.Shelley.Insert (insertShelleyBlock) -import Cardano.DbSync.Era.Shelley.Insert.Certificate (mkAdaPots) -import Cardano.DbSync.Era.Shelley.Insert.Epoch (insertInstantRewards, insertPoolDepositRefunds, insertRewards) -import Cardano.DbSync.Era.Shelley.Validate (validateEpochRewards) +import Cardano.DbSync.Era.Universal.Block (insertBlockUniversal) +import Cardano.DbSync.Era.Universal.Epoch (hasEpochStartEvent, hasNewEpochEvent) +import Cardano.DbSync.Era.Universal.Insert.Certificate (mkAdaPots) +import Cardano.DbSync.Era.Universal.Insert.LedgerEvent (insertBlockLedgerEvents) import Cardano.DbSync.Error import Cardano.DbSync.Fix.EpochStake -import Cardano.DbSync.Ledger.Event (LedgerEvent (..)) import Cardano.DbSync.Ledger.State (applyBlockAndSnapshot, defaultApplyResult) import Cardano.DbSync.Ledger.Types (ApplyResult (..)) import Cardano.DbSync.LocalStateQuery @@ -38,17 +34,15 @@ import Cardano.DbSync.Util import Cardano.DbSync.Util.Constraint (addConstraintsIfNotExist) import qualified Cardano.Ledger.Alonzo.Scripts as Ledger import Cardano.Ledger.Shelley.AdaPots as Shelley +import Cardano.Node.Configuration.Logging (Trace) import Cardano.Prelude import Cardano.Slotting.Slot (EpochNo (..), SlotNo) import Control.Monad.Logger (LoggingT) -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Except.Extra (newExceptT) import qualified Data.ByteString.Short as SBS -import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Strict.Maybe as Strict import Database.Persist.SqlBackend.Internal -import Database.Persist.SqlBackend.Internal.StatementCache import Ouroboros.Consensus.Cardano.Block (HardForkBlock (..)) import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import Ouroboros.Network.Block (blockHash, blockNo, getHeaderFields, headerFieldBlockNo, unBlockNo) @@ -60,15 +54,16 @@ insertListBlocks :: insertListBlocks synEnv blocks = do DB.runDbIohkLogging (envBackend synEnv) tracer . runExceptT - $ traverse_ (applyAndInsertBlockMaybe synEnv) blocks + $ traverse_ (applyAndInsertBlockMaybe synEnv tracer) blocks where tracer = getTrace synEnv applyAndInsertBlockMaybe :: SyncEnv -> + Trace IO Text -> CardanoBlock -> ExceptT SyncNodeError (ReaderT SqlBackend (LoggingT IO)) () -applyAndInsertBlockMaybe syncEnv cblk = do +applyAndInsertBlockMaybe syncEnv tracer cblk = do bl <- liftIO $ isConsistent syncEnv (!applyRes, !tookSnapshot) <- liftIO (mkApplyResult bl) if bl @@ -101,8 +96,6 @@ applyAndInsertBlockMaybe syncEnv cblk = do liftIO $ logInfo tracer $ "Reached " <> textShow epochNo _ -> pure () where - tracer = getTrace syncEnv - mkApplyResult :: Bool -> IO (ApplyResult, Bool) mkApplyResult isCons = do case envLedgerEnv syncEnv of @@ -136,12 +129,12 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do let !details = apSlotDetails applyResult let !withinTwoMin = isWithinTwoMin details let !withinHalfHour = isWithinHalfHour details - insertLedgerEvents syncEnv (sdEpochNo details) (apEvents applyResult) + insertBlockLedgerEvents syncEnv (sdEpochNo details) (apEvents applyResult) let isNewEpochEvent = hasNewEpochEvent (apEvents applyResult) let isStartEventOrRollback = hasEpochStartEvent (apEvents applyResult) || firstAfterRollback let isMember poolId = Set.member poolId (apPoolsRegistered applyResult) - let insertShelley blk = - insertShelleyBlock + let insertBlockUniversal' blk = + insertBlockUniversal syncEnv isStartEventOrRollback withinTwoMin @@ -159,27 +152,27 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do insertByronBlock syncEnv isStartEventOrRollback blk details BlockShelley blk -> newExceptT $ - insertShelley $ + insertBlockUniversal' $ Generic.fromShelleyBlock blk BlockAllegra blk -> newExceptT $ - insertShelley $ + insertBlockUniversal' $ Generic.fromAllegraBlock blk BlockMary blk -> newExceptT $ - insertShelley $ + insertBlockUniversal' $ Generic.fromMaryBlock blk BlockAlonzo blk -> newExceptT $ - insertShelley $ + insertBlockUniversal' $ Generic.fromAlonzoBlock (ioPlutusExtra iopts) (getPrices applyResult) blk BlockBabbage blk -> newExceptT $ - insertShelley $ + insertBlockUniversal' $ Generic.fromBabbageBlock (ioPlutusExtra iopts) (getPrices applyResult) blk BlockConway blk -> newExceptT $ - insertShelley $ + insertBlockUniversal' $ Generic.fromConwayBlock (ioPlutusExtra iopts) (getPrices applyResult) blk -- update the epoch updateEpoch details isNewEpochEvent @@ -232,90 +225,3 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do isWithinHalfHour sd = isSyncedWithinSeconds sd 1800 == SyncFollowing blkNo = headerFieldBlockNo $ getHeaderFields cblk - --- ------------------------------------------------------------------------------------------------- - -insertLedgerEvents :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - EpochNo -> - [LedgerEvent] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertLedgerEvents syncEnv currentEpochNo@(EpochNo curEpoch) = - mapM_ handler - where - tracer = getTrace syncEnv - cache = envCache syncEnv - ntw = getNetwork syncEnv - - subFromCurrentEpoch :: Word64 -> EpochNo - subFromCurrentEpoch m = - if unEpochNo currentEpochNo >= m - then EpochNo $ unEpochNo currentEpochNo - m - else EpochNo 0 - - toSyncState :: SyncState -> DB.SyncState - toSyncState SyncLagging = DB.SyncLagging - toSyncState SyncFollowing = DB.SyncFollowing - - handler :: - (MonadBaseControl IO m, MonadIO m) => - LedgerEvent -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () - handler ev = - case ev of - LedgerNewEpoch en ss -> do - lift $ - insertEpochSyncTime en (toSyncState ss) (envEpochSyncTime syncEnv) - sqlBackend <- lift ask - persistantCacheSize <- liftIO $ statementCacheSize $ connStmtMap sqlBackend - liftIO . logInfo tracer $ "Persistant SQL Statement Cache size is " <> textShow persistantCacheSize - stats <- liftIO $ textShowStats cache - liftIO . logInfo tracer $ stats - liftIO . logInfo tracer $ "Starting epoch " <> textShow (unEpochNo en) - LedgerStartAtEpoch en -> - -- This is different from the previous case in that the db-sync started - -- in this epoch, for example after a restart, instead of after an epoch boundary. - liftIO . logInfo tracer $ "Starting at epoch " <> textShow (unEpochNo en) - LedgerDeltaRewards _e rwd -> do - let rewards = Map.toList $ Generic.unRewards rwd - insertRewards syncEnv ntw (subFromCurrentEpoch 2) currentEpochNo cache (Map.toList $ Generic.unRewards rwd) - -- This event is only created when it's not empty, so we don't need to check for null here. - liftIO . logInfo tracer $ "Inserted " <> show (length rewards) <> " Delta rewards" - LedgerIncrementalRewards _ rwd -> do - let rewards = Map.toList $ Generic.unRewards rwd - insertRewards syncEnv ntw (subFromCurrentEpoch 1) (EpochNo $ curEpoch + 1) cache rewards - LedgerRestrainedRewards e rwd creds -> - lift $ adjustEpochRewards tracer ntw cache e rwd creds - LedgerTotalRewards _e rwd -> - lift $ validateEpochRewards tracer ntw (subFromCurrentEpoch 2) currentEpochNo rwd - LedgerAdaPots _ -> - pure () -- These are handled separately by insertBlock - LedgerMirDist rwd -> do - unless (Map.null rwd) $ do - let rewards = Map.toList rwd - insertInstantRewards ntw (subFromCurrentEpoch 1) currentEpochNo cache rewards - liftIO . logInfo tracer $ "Inserted " <> show (length rewards) <> " Mir rewards" - LedgerPoolReap en drs -> - unless (Map.null $ Generic.unRewards drs) $ do - insertPoolDepositRefunds syncEnv en drs - LedgerDeposits {} -> pure () - -hasEpochStartEvent :: [LedgerEvent] -> Bool -hasEpochStartEvent = any isNewEpoch - where - isNewEpoch :: LedgerEvent -> Bool - isNewEpoch le = - case le of - LedgerNewEpoch {} -> True - LedgerStartAtEpoch {} -> True - _otherwise -> False - -hasNewEpochEvent :: [LedgerEvent] -> Bool -hasNewEpochEvent = any isNewEpoch - where - isNewEpoch :: LedgerEvent -> Bool - isNewEpoch le = - case le of - LedgerNewEpoch {} -> True - _otherwise -> False diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/GovAction.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Conway/GovAction.hs similarity index 99% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/GovAction.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Conway/GovAction.hs index 4d24de974..5156251e4 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/GovAction.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Conway/GovAction.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Insert.GovAction ( +module Cardano.DbSync.Era.Conway.GovAction ( insertConstitution, insertCostModel, insertCredDrepHash, @@ -31,7 +31,7 @@ import Cardano.DbSync.Cache (queryOrInsertRewardAccount, queryPoolKeyOrInsert) import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..)) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.ParamProposal -import Cardano.DbSync.Era.Shelley.Insert.Other (toDouble) +import Cardano.DbSync.Era.Universal.Insert.Other (toDouble) import Cardano.DbSync.Era.Util (liftLookupFail) import Cardano.DbSync.Error import Cardano.DbSync.Util diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs index 2cb366c7c..af3e9b391 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -17,9 +17,9 @@ import Cardano.DbSync.Api import Cardano.DbSync.Api.Types (SyncEnv (envBackend)) import Cardano.DbSync.Cache.Types (Cache (..), uninitiatedCache) import qualified Cardano.DbSync.Era.Shelley.Generic.Util as Generic -import Cardano.DbSync.Era.Shelley.Insert.Certificate (insertDelegation, insertStakeRegistration) -import Cardano.DbSync.Era.Shelley.Insert.Other (insertStakeAddressRefIfMissing) -import Cardano.DbSync.Era.Shelley.Insert.Pool (insertPoolRegister) +import Cardano.DbSync.Era.Universal.Insert.Certificate (insertDelegation, insertStakeRegistration) +import Cardano.DbSync.Era.Universal.Insert.Other (insertStakeAddressRefIfMissing) +import Cardano.DbSync.Era.Universal.Insert.Pool (insertPoolRegister) import Cardano.DbSync.Era.Util (liftLookupFail) import Cardano.DbSync.Error import Cardano.DbSync.Util diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs deleted file mode 100644 index be526936d..000000000 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Cardano.DbSync.Era.Shelley.Insert ( - insertShelleyBlock, -) where - -import Cardano.BM.Trace (Trace, logDebug, logInfo) -import Cardano.Db (DbWord64 (..)) -import qualified Cardano.Db as DB -import Cardano.DbSync.Api -import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..)) -import Cardano.DbSync.Cache ( - insertBlockAndCache, - queryPoolKeyWithCache, - queryPrevBlockWithCache, - ) -import Cardano.DbSync.Cache.Epoch (writeEpochBlockDiffToCache) -import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..), EpochBlockDiff (..)) - -import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Era.Shelley.Insert.Epoch -import Cardano.DbSync.Era.Shelley.Insert.Grouped -import Cardano.DbSync.Era.Shelley.Insert.Tx (insertTx) -import Cardano.DbSync.Era.Util (liftLookupFail) -import Cardano.DbSync.Error -import Cardano.DbSync.Ledger.Types (ApplyResult (..)) -import Cardano.DbSync.OffChain -import Cardano.DbSync.Types -import Cardano.DbSync.Util - -import Cardano.DbSync.Era.Shelley.Insert.Certificate (insertPots) -import Cardano.DbSync.Era.Shelley.Insert.GovAction (insertCostModel, insertDrepDistr, updateEnacted) -import Cardano.DbSync.Era.Shelley.Insert.Other (toDouble) -import Cardano.DbSync.Era.Shelley.Insert.Pool (IsPoolMember) -import Cardano.Ledger.BaseTypes -import qualified Cardano.Ledger.BaseTypes as Ledger -import Cardano.Ledger.Conway.Core (DRepVotingThresholds (..), PoolVotingThresholds (..)) -import Cardano.Ledger.Conway.Governance -import Cardano.Ledger.Keys -import Cardano.Prelude - -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Trans.Except.Extra (newExceptT) -import Data.Either.Extra (eitherToMaybe) -import Database.Persist.Sql (SqlBackend) - -{- HLINT ignore "Reduce duplication" -} - --------------------------------------------------------------------------------------------- --- Insert Block --------------------------------------------------------------------------------------------- -insertShelleyBlock :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - Bool -> - Bool -> - Bool -> - Generic.Block -> - SlotDetails -> - IsPoolMember -> - ApplyResult -> - ReaderT SqlBackend m (Either SyncNodeError ()) -insertShelleyBlock syncEnv shouldLog withinTwoMins withinHalfHour blk details isMember applyResult = do - runExceptT $ do - pbid <- case Generic.blkPreviousHash blk of - Nothing -> liftLookupFail (renderErrorMessage (Generic.blkEra blk)) DB.queryGenesis -- this is for networks that fork from Byron on epoch 0. - Just pHash -> queryPrevBlockWithCache (renderErrorMessage (Generic.blkEra blk)) cache pHash - mPhid <- lift $ queryPoolKeyWithCache cache CacheNew $ coerceKeyRole $ Generic.blkSlotLeader blk - let epochNo = sdEpochNo details - - slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (ioShelley iopts) (Generic.unKeyHashRaw $ Generic.blkSlotLeader blk) (eitherToMaybe mPhid) - blkId <- - lift . insertBlockAndCache cache $ - DB.Block - { DB.blockHash = Generic.blkHash blk - , DB.blockEpochNo = Just $ unEpochNo epochNo - , DB.blockSlotNo = Just $ unSlotNo (Generic.blkSlotNo blk) - , DB.blockEpochSlotNo = Just $ unEpochSlot (sdEpochSlot details) - , DB.blockBlockNo = Just $ unBlockNo (Generic.blkBlockNo blk) - , DB.blockPreviousId = Just pbid - , DB.blockSlotLeaderId = slid - , DB.blockSize = Generic.blkSize blk - , DB.blockTime = sdSlotTime details - , DB.blockTxCount = fromIntegral $ length (Generic.blkTxs blk) - , DB.blockProtoMajor = getVersion $ Ledger.pvMajor (Generic.blkProto blk) - , DB.blockProtoMinor = fromIntegral $ Ledger.pvMinor (Generic.blkProto blk) - , -- Shelley specific - DB.blockVrfKey = Just $ Generic.blkVrfKey blk - , DB.blockOpCert = Just $ Generic.blkOpCert blk - , DB.blockOpCertCounter = Just $ Generic.blkOpCertCounter blk - } - - let zippedTx = zip [0 ..] (Generic.blkTxs blk) - let txInserter = insertTx syncEnv isMember blkId (sdEpochNo details) (Generic.blkSlotNo blk) applyResult - blockGroupedData <- foldM (\gp (idx, tx) -> txInserter idx tx gp) mempty zippedTx - minIds <- insertBlockGroupedData syncEnv blockGroupedData - - -- now that we've inserted the Block and all it's txs lets cache what we'll need - -- when we later update the epoch values. - -- if have --dissable-epoch && --dissable-cache then no need to cache data. - when (soptEpochAndCacheEnabled $ envOptions syncEnv) - . newExceptT - $ writeEpochBlockDiffToCache - cache - EpochBlockDiff - { ebdBlockId = blkId - , ebdTime = sdSlotTime details - , ebdFees = groupedTxFees blockGroupedData - , ebdEpochNo = unEpochNo (sdEpochNo details) - , ebdOutSum = fromIntegral $ groupedTxOutSum blockGroupedData - , ebdTxCount = fromIntegral $ length (Generic.blkTxs blk) - } - - when withinHalfHour $ - insertReverseIndex blkId minIds - - liftIO $ do - let epoch = unEpochNo epochNo - slotWithinEpoch = unEpochSlot (sdEpochSlot details) - - when (withinTwoMins && slotWithinEpoch /= 0 && unBlockNo (Generic.blkBlockNo blk) `mod` 20 == 0) $ do - logInfo tracer $ - mconcat - [ renderInsertName (Generic.blkEra blk) - , ": continuing epoch " - , textShow epoch - , " (slot " - , textShow slotWithinEpoch - , "/" - , textShow (unEpochSize $ sdEpochSize details) - , ")" - ] - logger tracer $ - mconcat - [ renderInsertName (Generic.blkEra blk) - , ": epoch " - , textShow (unEpochNo epochNo) - , ", slot " - , textShow (unSlotNo $ Generic.blkSlotNo blk) - , ", block " - , textShow (unBlockNo $ Generic.blkBlockNo blk) - , ", hash " - , renderByteArray (Generic.blkHash blk) - ] - - whenStrictJust (apNewEpoch applyResult) $ \newEpoch -> do - insertOnNewEpoch tracer iopts blkId (Generic.blkSlotNo blk) epochNo newEpoch - - insertStakeSlice syncEnv $ apStakeSlice applyResult - - when (ioGov iopts && (withinHalfHour || unBlockNo (Generic.blkBlockNo blk) `mod` 10000 == 0)) - . lift - $ insertOffChainVoteResults tracer (envOffChainVoteResultQueue syncEnv) - - when (ioOffChainPoolData iopts && (withinHalfHour || unBlockNo (Generic.blkBlockNo blk) `mod` 10000 == 0)) - . lift - $ insertOffChainPoolResults tracer (envOffChainPoolResultQueue syncEnv) - where - iopts = getInsertOptions syncEnv - - logger :: Trace IO a -> a -> IO () - logger - | shouldLog = logInfo - | withinTwoMins = logInfo - | unBlockNo (Generic.blkBlockNo blk) `mod` 5000 == 0 = logInfo - | otherwise = logDebug - - renderInsertName :: Generic.BlockEra -> Text - renderInsertName eraText = - mconcat ["Insert ", textShow eraText, " Block"] - - renderErrorMessage :: Generic.BlockEra -> Text - renderErrorMessage eraText = - case eraText of - Generic.Shelley -> "insertShelleyBlock" - other -> mconcat ["insertShelleyBlock(", textShow other, ")"] - - tracer :: Trace IO Text - tracer = getTrace syncEnv - - cache :: Cache - cache = envCache syncEnv - --------------------------------------------------------------------------------------------- --- Insert Epoch --------------------------------------------------------------------------------------------- -insertOnNewEpoch :: - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - InsertOptions -> - DB.BlockId -> - SlotNo -> - EpochNo -> - Generic.NewEpoch -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertOnNewEpoch tracer iopts blkId slotNo epochNo newEpoch = do - whenStrictJust (Generic.euProtoParams epochUpdate) $ \params -> - lift $ insertEpochParam tracer blkId epochNo params (Generic.euNonce epochUpdate) - whenStrictJust (Generic.neAdaPots newEpoch) $ \pots -> - insertPots blkId slotNo epochNo pots - whenStrictJust (Generic.neDRepState newEpoch) $ \dreps -> when (ioGov iopts) $ do - let (drepSnapshot, ratifyState) = finishDRepPulser dreps - lift $ insertDrepDistr epochNo drepSnapshot - updateEnacted False epochNo (rsEnactState ratifyState) - whenStrictJust (Generic.neEnacted newEpoch) $ \enactedSt -> - when (ioGov iopts) $ - updateEnacted True epochNo enactedSt - where - epochUpdate :: Generic.EpochUpdate - epochUpdate = Generic.neEpochUpdate newEpoch - -insertEpochParam :: - (MonadBaseControl IO m, MonadIO m) => - Trace IO Text -> - DB.BlockId -> - EpochNo -> - Generic.ProtoParams -> - Ledger.Nonce -> - ReaderT SqlBackend m () -insertEpochParam _tracer blkId (EpochNo epoch) params nonce = do - cmId <- maybe (pure Nothing) (fmap Just . insertCostModel blkId) (Generic.ppCostmdls params) - void - . DB.insertEpochParam - $ DB.EpochParam - { DB.epochParamEpochNo = epoch - , DB.epochParamMinFeeA = fromIntegral (Generic.ppMinfeeA params) - , DB.epochParamMinFeeB = fromIntegral (Generic.ppMinfeeB params) - , DB.epochParamMaxBlockSize = fromIntegral (Generic.ppMaxBBSize params) - , DB.epochParamMaxTxSize = fromIntegral (Generic.ppMaxTxSize params) - , DB.epochParamMaxBhSize = fromIntegral (Generic.ppMaxBHSize params) - , DB.epochParamKeyDeposit = Generic.coinToDbLovelace (Generic.ppKeyDeposit params) - , DB.epochParamPoolDeposit = Generic.coinToDbLovelace (Generic.ppPoolDeposit params) - , DB.epochParamMaxEpoch = fromIntegral $ unEpochInterval (Generic.ppMaxEpoch params) - , DB.epochParamOptimalPoolCount = fromIntegral (Generic.ppOptialPoolCount params) - , DB.epochParamInfluence = fromRational (Generic.ppInfluence params) - , DB.epochParamMonetaryExpandRate = toDouble (Generic.ppMonetaryExpandRate params) - , DB.epochParamTreasuryGrowthRate = toDouble (Generic.ppTreasuryGrowthRate params) - , DB.epochParamDecentralisation = toDouble (Generic.ppDecentralisation params) - , DB.epochParamExtraEntropy = Generic.nonceToBytes $ Generic.ppExtraEntropy params - , DB.epochParamProtocolMajor = getVersion $ Ledger.pvMajor (Generic.ppProtocolVersion params) - , DB.epochParamProtocolMinor = fromIntegral $ Ledger.pvMinor (Generic.ppProtocolVersion params) - , DB.epochParamMinUtxoValue = Generic.coinToDbLovelace (Generic.ppMinUTxOValue params) - , DB.epochParamMinPoolCost = Generic.coinToDbLovelace (Generic.ppMinPoolCost params) - , DB.epochParamNonce = Generic.nonceToBytes nonce - , DB.epochParamCoinsPerUtxoSize = Generic.coinToDbLovelace <$> Generic.ppCoinsPerUtxo params - , DB.epochParamCostModelId = cmId - , DB.epochParamPriceMem = realToFrac <$> Generic.ppPriceMem params - , DB.epochParamPriceStep = realToFrac <$> Generic.ppPriceStep params - , DB.epochParamMaxTxExMem = DbWord64 <$> Generic.ppMaxTxExMem params - , DB.epochParamMaxTxExSteps = DbWord64 <$> Generic.ppMaxTxExSteps params - , DB.epochParamMaxBlockExMem = DbWord64 <$> Generic.ppMaxBlockExMem params - , DB.epochParamMaxBlockExSteps = DbWord64 <$> Generic.ppMaxBlockExSteps params - , DB.epochParamMaxValSize = DbWord64 . fromIntegral <$> Generic.ppMaxValSize params - , DB.epochParamCollateralPercent = fromIntegral <$> Generic.ppCollateralPercentage params - , DB.epochParamMaxCollateralInputs = fromIntegral <$> Generic.ppMaxCollateralInputs params - , DB.epochParamPvtMotionNoConfidence = toDouble . pvtMotionNoConfidence <$> Generic.ppPoolVotingThresholds params - , DB.epochParamPvtCommitteeNormal = toDouble . pvtCommitteeNormal <$> Generic.ppPoolVotingThresholds params - , DB.epochParamPvtCommitteeNoConfidence = toDouble . pvtCommitteeNoConfidence <$> Generic.ppPoolVotingThresholds params - , DB.epochParamPvtHardForkInitiation = toDouble . pvtHardForkInitiation <$> Generic.ppPoolVotingThresholds params - , DB.epochParamDvtMotionNoConfidence = toDouble . dvtMotionNoConfidence <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtCommitteeNormal = toDouble . dvtCommitteeNormal <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtCommitteeNoConfidence = toDouble . dvtCommitteeNoConfidence <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtUpdateToConstitution = toDouble . dvtUpdateToConstitution <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtHardForkInitiation = toDouble . dvtHardForkInitiation <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtPPNetworkGroup = toDouble . dvtPPNetworkGroup <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtPPEconomicGroup = toDouble . dvtPPEconomicGroup <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtPPTechnicalGroup = toDouble . dvtPPTechnicalGroup <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtPPGovGroup = toDouble . dvtPPGovGroup <$> Generic.ppDRepVotingThresholds params - , DB.epochParamDvtTreasuryWithdrawal = toDouble . dvtTreasuryWithdrawal <$> Generic.ppDRepVotingThresholds params - , DB.epochParamCommitteeMinSize = DbWord64 . fromIntegral <$> Generic.ppCommitteeMinSize params - , DB.epochParamCommitteeMaxTermLength = DbWord64 . fromIntegral . unEpochInterval <$> Generic.ppCommitteeMaxTermLength params - , DB.epochParamGovActionLifetime = fromIntegral . unEpochInterval <$> Generic.ppGovActionLifetime params - , DB.epochParamGovActionDeposit = DbWord64 . fromIntegral <$> Generic.ppGovActionDeposit params - , DB.epochParamDrepDeposit = DbWord64 . fromIntegral <$> Generic.ppDRepDeposit params - , DB.epochParamDrepActivity = fromIntegral . unEpochInterval <$> Generic.ppDRepActivity params - , DB.epochParamBlockId = blkId - } diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs deleted file mode 100644 index fb09ff7f5..000000000 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Epoch.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Cardano.DbSync.Era.Shelley.Insert.Epoch ( - insertRewards, - insertInstantRewards, - insertPoolDepositRefunds, - insertStakeSlice, - sumRewardTotal, -) where - -import Cardano.BM.Trace (Trace, logInfo) -import qualified Cardano.Db as DB -import Cardano.DbSync.Api -import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..)) -import Cardano.DbSync.Cache (queryOrInsertStakeAddress, queryPoolKeyOrInsert) -import Cardano.DbSync.Cache.Types (Cache, CacheNew (..)) -import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Error -import Cardano.DbSync.Types -import Cardano.DbSync.Util.Constraint (constraintNameEpochStake, constraintNameReward) -import Cardano.Ledger.BaseTypes (Network) -import qualified Cardano.Ledger.Coin as Shelley -import Cardano.Prelude -import Cardano.Slotting.Slot (EpochNo (..)) -import Control.Concurrent.Class.MonadSTM.Strict (readTVarIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Database.Persist.Sql (SqlBackend) - -{- HLINT ignore "Use readTVarIO" -} - -insertStakeSlice :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - Generic.StakeSliceRes -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertStakeSlice _ Generic.NoSlices = pure () -insertStakeSlice syncEnv (Generic.Slice slice finalSlice) = do - 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)] - where - tracer :: Trace IO Text - tracer = getTrace syncEnv - - network :: Network - network = getNetwork syncEnv - -insertEpochStake :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - Network -> - EpochNo -> - [(StakeCred, (Shelley.Coin, PoolKeyHash))] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertEpochStake syncEnv nw epochNo stakeChunk = do - let cache = envCache syncEnv - DB.ManualDbConstraints {..} <- liftIO $ readTVarIO $ envDbConstraints syncEnv - dbStakes <- mapM (mkStake cache) stakeChunk - let chunckDbStakes = splittRecordsEvery 100000 dbStakes - -- minimising the bulk inserts into hundred thousand chunks to improve performance - forM_ chunckDbStakes $ \dbs -> lift $ DB.insertManyEpochStakes dbConstraintEpochStake constraintNameEpochStake dbs - where - mkStake :: - (MonadBaseControl IO m, MonadIO m) => - Cache -> - (StakeCred, (Shelley.Coin, PoolKeyHash)) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.EpochStake - mkStake cache (saddr, (coin, pool)) = do - saId <- lift $ queryOrInsertStakeAddress cache CacheNew nw saddr - poolId <- lift $ queryPoolKeyOrInsert "insertEpochStake" trce cache CacheNew (ioShelley iopts) pool - pure $ - DB.EpochStake - { DB.epochStakeAddrId = saId - , DB.epochStakePoolId = poolId - , DB.epochStakeAmount = Generic.coinToDbLovelace coin - , DB.epochStakeEpochNo = unEpochNo epochNo -- The epoch where this delegation becomes valid. - } - - trce = getTrace syncEnv - iopts = getInsertOptions syncEnv - -insertRewards :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - Network -> - EpochNo -> - EpochNo -> - Cache -> - [(StakeCred, Set Generic.Reward)] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertRewards syncEnv nw earnedEpoch spendableEpoch cache rewardsChunk = do - DB.ManualDbConstraints {..} <- liftIO $ readTVarIO $ envDbConstraints syncEnv - dbRewards <- concatMapM mkRewards rewardsChunk - let chunckDbRewards = splittRecordsEvery 100000 dbRewards - -- minimising the bulk inserts into hundred thousand chunks to improve performance - forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyRewards dbConstraintRewards constraintNameReward rws - where - mkRewards :: - (MonadBaseControl IO m, MonadIO m) => - (StakeCred, Set Generic.Reward) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.Reward] - mkRewards (saddr, rset) = do - saId <- lift $ queryOrInsertStakeAddress cache CacheNew nw saddr - mapM (prepareReward saId) (Set.toList rset) - - prepareReward :: - (MonadBaseControl IO m, MonadIO m) => - DB.StakeAddressId -> - Generic.Reward -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.Reward - prepareReward saId rwd = do - poolId <- queryPool (Generic.rewardPool rwd) - pure $ - DB.Reward - { DB.rewardAddrId = saId - , DB.rewardType = Generic.rewardSource rwd - , DB.rewardAmount = Generic.coinToDbLovelace (Generic.rewardAmount rwd) - , DB.rewardEarnedEpoch = unEpochNo earnedEpoch - , DB.rewardSpendableEpoch = unEpochNo spendableEpoch - , DB.rewardPoolId = poolId - } - - queryPool :: - (MonadBaseControl IO m, MonadIO m) => - PoolKeyHash -> - ExceptT SyncNodeError (ReaderT SqlBackend m) DB.PoolHashId - queryPool poolHash = - lift (queryPoolKeyOrInsert "insertRewards" trce cache CacheNew (ioShelley iopts) poolHash) - - trce = getTrace syncEnv - iopts = getInsertOptions syncEnv - -insertInstantRewards :: - (MonadBaseControl IO m, MonadIO m) => - Network -> - EpochNo -> - EpochNo -> - Cache -> - [(StakeCred, Set Generic.InstantReward)] -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertInstantRewards nw earnedEpoch spendableEpoch cache rewardsChunk = do - dbRewards <- concatMapM mkRewards rewardsChunk - let chunckDbRewards = splittRecordsEvery 100000 dbRewards - -- minimising the bulk inserts into hundred thousand chunks to improve performance - forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyInstantRewards rws - where - mkRewards :: - (MonadBaseControl IO m, MonadIO m) => - (StakeCred, Set Generic.InstantReward) -> - ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.InstantReward] - mkRewards (saddr, rset) = do - saId <- lift $ queryOrInsertStakeAddress cache CacheNew nw saddr - pure $ map (prepareReward saId) (Set.toList rset) - - prepareReward :: - DB.StakeAddressId -> - Generic.InstantReward -> - DB.InstantReward - prepareReward saId rwd = - DB.InstantReward - { DB.instantRewardAddrId = saId - , DB.instantRewardType = Generic.irSource rwd - , DB.instantRewardAmount = Generic.coinToDbLovelace (Generic.irAmount rwd) - , DB.instantRewardEarnedEpoch = unEpochNo earnedEpoch - , DB.instantRewardSpendableEpoch = unEpochNo spendableEpoch - } - -splittRecordsEvery :: Int -> [a] -> [[a]] -splittRecordsEvery val = go - where - go [] = [] - go ys = - let (as, bs) = splitAt val ys - in as : go bs - -insertPoolDepositRefunds :: - (MonadBaseControl IO m, MonadIO m) => - SyncEnv -> - EpochNo -> - Generic.Rewards -> - ExceptT SyncNodeError (ReaderT SqlBackend m) () -insertPoolDepositRefunds syncEnv epochNo refunds = do - insertRewards syncEnv nw epochNo epochNo (envCache syncEnv) (Map.toList rwds) - liftIO . logInfo tracer $ "Inserted " <> show (Generic.rewardsCount refunds) <> " deposit refund rewards" - where - tracer = getTrace syncEnv - rwds = Generic.unRewards refunds - nw = getNetwork syncEnv - -sumRewardTotal :: Map StakeCred (Set Generic.Reward) -> Shelley.Coin -sumRewardTotal = - Shelley.Coin . Map.foldl' sumCoin 0 - where - sumCoin :: Integer -> Set Generic.Reward -> Integer - sumCoin !acc sr = - acc + sum (map (Shelley.unCoin . Generic.rewardAmount) $ Set.toList sr) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs similarity index 98% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs index eb9f616ba..ee86ead34 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Adjust.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Adjust ( +module Cardano.DbSync.Era.Universal.Adjust ( adjustEpochRewards, ) where diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs new file mode 100644 index 000000000..5fbe707e6 --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.DbSync.Era.Universal.Block ( + insertBlockUniversal, +) where + +import Cardano.BM.Trace (Trace, logDebug, logInfo) +import qualified Cardano.Db as DB +import Cardano.DbSync.Api +import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..), SyncOptions (..)) +import Cardano.DbSync.Cache ( + insertBlockAndCache, + queryPoolKeyWithCache, + queryPrevBlockWithCache, + ) +import Cardano.DbSync.Cache.Epoch (writeEpochBlockDiffToCache) +import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..), EpochBlockDiff (..)) + +import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.DbSync.Era.Universal.Epoch +import Cardano.DbSync.Era.Universal.Insert.Grouped +import Cardano.DbSync.Era.Universal.Insert.Tx (insertTx) +import Cardano.DbSync.Era.Util (liftLookupFail) +import Cardano.DbSync.Error +import Cardano.DbSync.Ledger.Types (ApplyResult (..)) +import Cardano.DbSync.OffChain +import Cardano.DbSync.Types +import Cardano.DbSync.Util + +import Cardano.DbSync.Era.Universal.Insert.Pool (IsPoolMember) +import Cardano.Ledger.BaseTypes +import qualified Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.Keys +import Cardano.Prelude + +import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Except.Extra (newExceptT) +import Data.Either.Extra (eitherToMaybe) +import Database.Persist.Sql (SqlBackend) + +-------------------------------------------------------------------------------------------- +-- Insert a universal Block. +-- This is the entry point for inserting a block into the database, used for all eras appart from Byron. +-------------------------------------------------------------------------------------------- +insertBlockUniversal :: + (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> + -- | Should log + Bool -> + -- | Within two minutes + Bool -> + -- | Within half hour + Bool -> + Generic.Block -> + SlotDetails -> + IsPoolMember -> + ApplyResult -> + ReaderT SqlBackend m (Either SyncNodeError ()) +insertBlockUniversal syncEnv shouldLog withinTwoMins withinHalfHour blk details isMember applyResult = do + runExceptT $ do + pbid <- case Generic.blkPreviousHash blk of + Nothing -> liftLookupFail (renderErrorMessage (Generic.blkEra blk)) DB.queryGenesis -- this is for networks that fork from Byron on epoch 0. + Just pHash -> queryPrevBlockWithCache (renderErrorMessage (Generic.blkEra blk)) cache pHash + mPhid <- lift $ queryPoolKeyWithCache cache CacheNew $ coerceKeyRole $ Generic.blkSlotLeader blk + let epochNo = sdEpochNo details + + slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (ioShelley iopts) (Generic.unKeyHashRaw $ Generic.blkSlotLeader blk) (eitherToMaybe mPhid) + blkId <- + lift . insertBlockAndCache cache $ + DB.Block + { DB.blockHash = Generic.blkHash blk + , DB.blockEpochNo = Just $ unEpochNo epochNo + , DB.blockSlotNo = Just $ unSlotNo (Generic.blkSlotNo blk) + , DB.blockEpochSlotNo = Just $ unEpochSlot (sdEpochSlot details) + , DB.blockBlockNo = Just $ unBlockNo (Generic.blkBlockNo blk) + , DB.blockPreviousId = Just pbid + , DB.blockSlotLeaderId = slid + , DB.blockSize = Generic.blkSize blk + , DB.blockTime = sdSlotTime details + , DB.blockTxCount = fromIntegral $ length (Generic.blkTxs blk) + , DB.blockProtoMajor = getVersion $ Ledger.pvMajor (Generic.blkProto blk) + , DB.blockProtoMinor = fromIntegral $ Ledger.pvMinor (Generic.blkProto blk) + , -- Shelley specific + DB.blockVrfKey = Just $ Generic.blkVrfKey blk + , DB.blockOpCert = Just $ Generic.blkOpCert blk + , DB.blockOpCertCounter = Just $ Generic.blkOpCertCounter blk + } + + let zippedTx = zip [0 ..] (Generic.blkTxs blk) + let txInserter = insertTx syncEnv isMember blkId (sdEpochNo details) (Generic.blkSlotNo blk) applyResult + blockGroupedData <- foldM (\gp (idx, tx) -> txInserter idx tx gp) mempty zippedTx + minIds <- insertBlockGroupedData syncEnv blockGroupedData + + -- now that we've inserted the Block and all it's txs lets cache what we'll need + -- when we later update the epoch values. + -- if have --dissable-epoch && --dissable-cache then no need to cache data. + when (soptEpochAndCacheEnabled $ envOptions syncEnv) + . newExceptT + $ writeEpochBlockDiffToCache + cache + EpochBlockDiff + { ebdBlockId = blkId + , ebdTime = sdSlotTime details + , ebdFees = groupedTxFees blockGroupedData + , ebdEpochNo = unEpochNo (sdEpochNo details) + , ebdOutSum = fromIntegral $ groupedTxOutSum blockGroupedData + , ebdTxCount = fromIntegral $ length (Generic.blkTxs blk) + } + + when withinHalfHour $ + insertReverseIndex blkId minIds + + liftIO $ do + let epoch = unEpochNo epochNo + slotWithinEpoch = unEpochSlot (sdEpochSlot details) + + when (withinTwoMins && slotWithinEpoch /= 0 && unBlockNo (Generic.blkBlockNo blk) `mod` 20 == 0) $ do + logInfo tracer $ + mconcat + [ renderInsertName (Generic.blkEra blk) + , ": continuing epoch " + , textShow epoch + , " (slot " + , textShow slotWithinEpoch + , "/" + , textShow (unEpochSize $ sdEpochSize details) + , ")" + ] + logger tracer $ + mconcat + [ renderInsertName (Generic.blkEra blk) + , ": epoch " + , textShow (unEpochNo epochNo) + , ", slot " + , textShow (unSlotNo $ Generic.blkSlotNo blk) + , ", block " + , textShow (unBlockNo $ Generic.blkBlockNo blk) + , ", hash " + , renderByteArray (Generic.blkHash blk) + ] + + whenStrictJust (apNewEpoch applyResult) $ \newEpoch -> do + insertOnNewEpoch tracer iopts blkId (Generic.blkSlotNo blk) epochNo newEpoch + + insertStakeSlice syncEnv $ apStakeSlice applyResult + + when (ioGov iopts && (withinHalfHour || unBlockNo (Generic.blkBlockNo blk) `mod` 10000 == 0)) + . lift + $ insertOffChainVoteResults tracer (envOffChainVoteResultQueue syncEnv) + + when (ioOffChainPoolData iopts && (withinHalfHour || unBlockNo (Generic.blkBlockNo blk) `mod` 10000 == 0)) + . lift + $ insertOffChainPoolResults tracer (envOffChainPoolResultQueue syncEnv) + where + iopts = getInsertOptions syncEnv + + logger :: Trace IO a -> a -> IO () + logger + | shouldLog = logInfo + | withinTwoMins = logInfo + | unBlockNo (Generic.blkBlockNo blk) `mod` 5000 == 0 = logInfo + | otherwise = logDebug + + renderInsertName :: Generic.BlockEra -> Text + renderInsertName eraText = + mconcat ["Insert ", textShow eraText, " Block"] + + renderErrorMessage :: Generic.BlockEra -> Text + renderErrorMessage eraText = + case eraText of + Generic.Shelley -> "insertBlockForEra" + other -> mconcat ["insertBlockForEra(", textShow other, ")"] + + tracer :: Trace IO Text + tracer = getTrace syncEnv + + cache :: Cache + cache = envCache syncEnv diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs new file mode 100644 index 000000000..ada957458 --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.DbSync.Era.Universal.Epoch ( + insertOnNewEpoch, + insertRewards, + hasNewEpochEvent, + hasEpochStartEvent, + insertInstantRewards, + insertPoolDepositRefunds, + insertStakeSlice, + sumRewardTotal, +) where + +import Cardano.BM.Trace (Trace, logInfo) +import qualified Cardano.Db as DB +import Cardano.DbSync.Api +import Cardano.DbSync.Api.Types (InsertOptions (..), SyncEnv (..)) +import Cardano.DbSync.Cache (queryOrInsertStakeAddress, queryPoolKeyOrInsert) +import Cardano.DbSync.Cache.Types (Cache, CacheNew (..)) +import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.DbSync.Era.Universal.Insert.Certificate (insertPots) +import Cardano.DbSync.Era.Universal.Insert.GovAction (insertCostModel, insertDrepDistr, updateEnacted) +import Cardano.DbSync.Era.Universal.Insert.Other (toDouble) +import Cardano.DbSync.Error +import Cardano.DbSync.Ledger.Event (LedgerEvent (..)) +import Cardano.DbSync.Types +import Cardano.DbSync.Util (whenStrictJust) +import Cardano.DbSync.Util.Constraint (constraintNameEpochStake, constraintNameReward) +import Cardano.Ledger.BaseTypes (Network, unEpochInterval) +import qualified Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.Binary.Version (getVersion) +import qualified Cardano.Ledger.Coin as Shelley +import Cardano.Ledger.Conway.Core (PoolVotingThresholds (..)) +import Cardano.Ledger.Conway.Governance (finishDRepPulser) +import Cardano.Ledger.Conway.PParams (DRepVotingThresholds (..)) +import Cardano.Ledger.Conway.Rules (RatifyState (..)) +import Cardano.Prelude +import Cardano.Slotting.Slot (EpochNo (..), SlotNo) +import Control.Concurrent.Class.MonadSTM.Strict (readTVarIO) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Database.Persist.Sql (SqlBackend) + +{- HLINT ignore "Use readTVarIO" -} + +-------------------------------------------------------------------------------------------- +-- Insert Epoch +-------------------------------------------------------------------------------------------- +insertOnNewEpoch :: + (MonadBaseControl IO m, MonadIO m) => + Trace IO Text -> + InsertOptions -> + DB.BlockId -> + SlotNo -> + EpochNo -> + Generic.NewEpoch -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertOnNewEpoch tracer iopts blkId slotNo epochNo newEpoch = do + whenStrictJust (Generic.euProtoParams epochUpdate) $ \params -> + lift $ insertEpochParam tracer blkId epochNo params (Generic.euNonce epochUpdate) + whenStrictJust (Generic.neAdaPots newEpoch) $ \pots -> + insertPots blkId slotNo epochNo pots + whenStrictJust (Generic.neDRepState newEpoch) $ \dreps -> when (ioGov iopts) $ do + let (drepSnapshot, ratifyState) = finishDRepPulser dreps + lift $ insertDrepDistr epochNo drepSnapshot + updateEnacted False epochNo (rsEnactState ratifyState) + whenStrictJust (Generic.neEnacted newEpoch) $ \enactedSt -> + when (ioGov iopts) $ + updateEnacted True epochNo enactedSt + where + epochUpdate :: Generic.EpochUpdate + epochUpdate = Generic.neEpochUpdate newEpoch + +insertEpochParam :: + (MonadBaseControl IO m, MonadIO m) => + Trace IO Text -> + DB.BlockId -> + EpochNo -> + Generic.ProtoParams -> + Ledger.Nonce -> + ReaderT SqlBackend m () +insertEpochParam _tracer blkId (EpochNo epoch) params nonce = do + cmId <- maybe (pure Nothing) (fmap Just . insertCostModel blkId) (Generic.ppCostmdls params) + void + . DB.insertEpochParam + $ DB.EpochParam + { DB.epochParamEpochNo = epoch + , DB.epochParamMinFeeA = fromIntegral (Generic.ppMinfeeA params) + , DB.epochParamMinFeeB = fromIntegral (Generic.ppMinfeeB params) + , DB.epochParamMaxBlockSize = fromIntegral (Generic.ppMaxBBSize params) + , DB.epochParamMaxTxSize = fromIntegral (Generic.ppMaxTxSize params) + , DB.epochParamMaxBhSize = fromIntegral (Generic.ppMaxBHSize params) + , DB.epochParamKeyDeposit = Generic.coinToDbLovelace (Generic.ppKeyDeposit params) + , DB.epochParamPoolDeposit = Generic.coinToDbLovelace (Generic.ppPoolDeposit params) + , DB.epochParamMaxEpoch = fromIntegral $ unEpochInterval (Generic.ppMaxEpoch params) + , DB.epochParamOptimalPoolCount = fromIntegral (Generic.ppOptialPoolCount params) + , DB.epochParamInfluence = fromRational (Generic.ppInfluence params) + , DB.epochParamMonetaryExpandRate = toDouble (Generic.ppMonetaryExpandRate params) + , DB.epochParamTreasuryGrowthRate = toDouble (Generic.ppTreasuryGrowthRate params) + , DB.epochParamDecentralisation = toDouble (Generic.ppDecentralisation params) + , DB.epochParamExtraEntropy = Generic.nonceToBytes $ Generic.ppExtraEntropy params + , DB.epochParamProtocolMajor = getVersion $ Ledger.pvMajor (Generic.ppProtocolVersion params) + , DB.epochParamProtocolMinor = fromIntegral $ Ledger.pvMinor (Generic.ppProtocolVersion params) + , DB.epochParamMinUtxoValue = Generic.coinToDbLovelace (Generic.ppMinUTxOValue params) + , DB.epochParamMinPoolCost = Generic.coinToDbLovelace (Generic.ppMinPoolCost params) + , DB.epochParamNonce = Generic.nonceToBytes nonce + , DB.epochParamCoinsPerUtxoSize = Generic.coinToDbLovelace <$> Generic.ppCoinsPerUtxo params + , DB.epochParamCostModelId = cmId + , DB.epochParamPriceMem = realToFrac <$> Generic.ppPriceMem params + , DB.epochParamPriceStep = realToFrac <$> Generic.ppPriceStep params + , DB.epochParamMaxTxExMem = DB.DbWord64 <$> Generic.ppMaxTxExMem params + , DB.epochParamMaxTxExSteps = DB.DbWord64 <$> Generic.ppMaxTxExSteps params + , DB.epochParamMaxBlockExMem = DB.DbWord64 <$> Generic.ppMaxBlockExMem params + , DB.epochParamMaxBlockExSteps = DB.DbWord64 <$> Generic.ppMaxBlockExSteps params + , DB.epochParamMaxValSize = DB.DbWord64 . fromIntegral <$> Generic.ppMaxValSize params + , DB.epochParamCollateralPercent = fromIntegral <$> Generic.ppCollateralPercentage params + , DB.epochParamMaxCollateralInputs = fromIntegral <$> Generic.ppMaxCollateralInputs params + , DB.epochParamPvtMotionNoConfidence = toDouble . pvtMotionNoConfidence <$> Generic.ppPoolVotingThresholds params + , DB.epochParamPvtCommitteeNormal = toDouble . pvtCommitteeNormal <$> Generic.ppPoolVotingThresholds params + , DB.epochParamPvtCommitteeNoConfidence = toDouble . pvtCommitteeNoConfidence <$> Generic.ppPoolVotingThresholds params + , DB.epochParamPvtHardForkInitiation = toDouble . pvtHardForkInitiation <$> Generic.ppPoolVotingThresholds params + , DB.epochParamDvtMotionNoConfidence = toDouble . dvtMotionNoConfidence <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtCommitteeNormal = toDouble . dvtCommitteeNormal <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtCommitteeNoConfidence = toDouble . dvtCommitteeNoConfidence <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtUpdateToConstitution = toDouble . dvtUpdateToConstitution <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtHardForkInitiation = toDouble . dvtHardForkInitiation <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtPPNetworkGroup = toDouble . dvtPPNetworkGroup <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtPPEconomicGroup = toDouble . dvtPPEconomicGroup <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtPPTechnicalGroup = toDouble . dvtPPTechnicalGroup <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtPPGovGroup = toDouble . dvtPPGovGroup <$> Generic.ppDRepVotingThresholds params + , DB.epochParamDvtTreasuryWithdrawal = toDouble . dvtTreasuryWithdrawal <$> Generic.ppDRepVotingThresholds params + , DB.epochParamCommitteeMinSize = DB.DbWord64 . fromIntegral <$> Generic.ppCommitteeMinSize params + , DB.epochParamCommitteeMaxTermLength = DB.DbWord64 . fromIntegral . unEpochInterval <$> Generic.ppCommitteeMaxTermLength params + , DB.epochParamGovActionLifetime = fromIntegral . unEpochInterval <$> Generic.ppGovActionLifetime params + , DB.epochParamGovActionDeposit = DB.DbWord64 . fromIntegral <$> Generic.ppGovActionDeposit params + , DB.epochParamDrepDeposit = DB.DbWord64 . fromIntegral <$> Generic.ppDRepDeposit params + , DB.epochParamDrepActivity = fromIntegral . unEpochInterval <$> Generic.ppDRepActivity params + , DB.epochParamBlockId = blkId + } + +hasNewEpochEvent :: [LedgerEvent] -> Bool +hasNewEpochEvent = any isNewEpoch + where + isNewEpoch :: LedgerEvent -> Bool + isNewEpoch le = + case le of + LedgerNewEpoch {} -> True + _otherwise -> False + +hasEpochStartEvent :: [LedgerEvent] -> Bool +hasEpochStartEvent = any isNewEpoch + where + isNewEpoch :: LedgerEvent -> Bool + isNewEpoch le = + case le of + LedgerNewEpoch {} -> True + LedgerStartAtEpoch {} -> True + _otherwise -> False + +insertStakeSlice :: + (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> + Generic.StakeSliceRes -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertStakeSlice _ Generic.NoSlices = pure () +insertStakeSlice syncEnv (Generic.Slice slice finalSlice) = do + 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)] + where + tracer :: Trace IO Text + tracer = getTrace syncEnv + + network :: Network + network = getNetwork syncEnv + +insertEpochStake :: + (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> + Network -> + EpochNo -> + [(StakeCred, (Shelley.Coin, PoolKeyHash))] -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertEpochStake syncEnv nw epochNo stakeChunk = do + let cache = envCache syncEnv + DB.ManualDbConstraints {..} <- liftIO $ readTVarIO $ envDbConstraints syncEnv + dbStakes <- mapM (mkStake cache) stakeChunk + let chunckDbStakes = splittRecordsEvery 100000 dbStakes + -- minimising the bulk inserts into hundred thousand chunks to improve performance + forM_ chunckDbStakes $ \dbs -> lift $ DB.insertManyEpochStakes dbConstraintEpochStake constraintNameEpochStake dbs + where + mkStake :: + (MonadBaseControl IO m, MonadIO m) => + Cache -> + (StakeCred, (Shelley.Coin, PoolKeyHash)) -> + ExceptT SyncNodeError (ReaderT SqlBackend m) DB.EpochStake + mkStake cache (saddr, (coin, pool)) = do + saId <- lift $ queryOrInsertStakeAddress cache CacheNew nw saddr + poolId <- lift $ queryPoolKeyOrInsert "insertEpochStake" trce cache CacheNew (ioShelley iopts) pool + pure $ + DB.EpochStake + { DB.epochStakeAddrId = saId + , DB.epochStakePoolId = poolId + , DB.epochStakeAmount = Generic.coinToDbLovelace coin + , DB.epochStakeEpochNo = unEpochNo epochNo -- The epoch where this delegation becomes valid. + } + + trce = getTrace syncEnv + iopts = getInsertOptions syncEnv + +insertRewards :: + (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> + Network -> + EpochNo -> + EpochNo -> + Cache -> + [(StakeCred, Set Generic.Reward)] -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertRewards syncEnv nw earnedEpoch spendableEpoch cache rewardsChunk = do + DB.ManualDbConstraints {..} <- liftIO $ readTVarIO $ envDbConstraints syncEnv + dbRewards <- concatMapM mkRewards rewardsChunk + let chunckDbRewards = splittRecordsEvery 100000 dbRewards + -- minimising the bulk inserts into hundred thousand chunks to improve performance + forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyRewards dbConstraintRewards constraintNameReward rws + where + mkRewards :: + (MonadBaseControl IO m, MonadIO m) => + (StakeCred, Set Generic.Reward) -> + ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.Reward] + mkRewards (saddr, rset) = do + saId <- lift $ queryOrInsertStakeAddress cache CacheNew nw saddr + mapM (prepareReward saId) (Set.toList rset) + + prepareReward :: + (MonadBaseControl IO m, MonadIO m) => + DB.StakeAddressId -> + Generic.Reward -> + ExceptT SyncNodeError (ReaderT SqlBackend m) DB.Reward + prepareReward saId rwd = do + poolId <- queryPool (Generic.rewardPool rwd) + pure $ + DB.Reward + { DB.rewardAddrId = saId + , DB.rewardType = Generic.rewardSource rwd + , DB.rewardAmount = Generic.coinToDbLovelace (Generic.rewardAmount rwd) + , DB.rewardEarnedEpoch = unEpochNo earnedEpoch + , DB.rewardSpendableEpoch = unEpochNo spendableEpoch + , DB.rewardPoolId = poolId + } + + queryPool :: + (MonadBaseControl IO m, MonadIO m) => + PoolKeyHash -> + ExceptT SyncNodeError (ReaderT SqlBackend m) DB.PoolHashId + queryPool poolHash = + lift (queryPoolKeyOrInsert "insertRewards" trce cache CacheNew (ioShelley iopts) poolHash) + + trce = getTrace syncEnv + iopts = getInsertOptions syncEnv + +insertInstantRewards :: + (MonadBaseControl IO m, MonadIO m) => + Network -> + EpochNo -> + EpochNo -> + Cache -> + [(StakeCred, Set Generic.InstantReward)] -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertInstantRewards nw earnedEpoch spendableEpoch cache rewardsChunk = do + dbRewards <- concatMapM mkRewards rewardsChunk + let chunckDbRewards = splittRecordsEvery 100000 dbRewards + -- minimising the bulk inserts into hundred thousand chunks to improve performance + forM_ chunckDbRewards $ \rws -> lift $ DB.insertManyInstantRewards rws + where + mkRewards :: + (MonadBaseControl IO m, MonadIO m) => + (StakeCred, Set Generic.InstantReward) -> + ExceptT SyncNodeError (ReaderT SqlBackend m) [DB.InstantReward] + mkRewards (saddr, rset) = do + saId <- lift $ queryOrInsertStakeAddress cache CacheNew nw saddr + pure $ map (prepareReward saId) (Set.toList rset) + + prepareReward :: + DB.StakeAddressId -> + Generic.InstantReward -> + DB.InstantReward + prepareReward saId rwd = + DB.InstantReward + { DB.instantRewardAddrId = saId + , DB.instantRewardType = Generic.irSource rwd + , DB.instantRewardAmount = Generic.coinToDbLovelace (Generic.irAmount rwd) + , DB.instantRewardEarnedEpoch = unEpochNo earnedEpoch + , DB.instantRewardSpendableEpoch = unEpochNo spendableEpoch + } + +splittRecordsEvery :: Int -> [a] -> [[a]] +splittRecordsEvery val = go + where + go [] = [] + go ys = + let (as, bs) = splitAt val ys + in as : go bs + +insertPoolDepositRefunds :: + (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> + EpochNo -> + Generic.Rewards -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertPoolDepositRefunds syncEnv epochNo refunds = do + insertRewards syncEnv nw epochNo epochNo (envCache syncEnv) (Map.toList rwds) + liftIO . logInfo tracer $ "Inserted " <> show (Generic.rewardsCount refunds) <> " deposit refund rewards" + where + tracer = getTrace syncEnv + rwds = Generic.unRewards refunds + nw = getNetwork syncEnv + +sumRewardTotal :: Map StakeCred (Set Generic.Reward) -> Shelley.Coin +sumRewardTotal = + Shelley.Coin . Map.foldl' sumCoin 0 + where + sumCoin :: Integer -> Set Generic.Reward -> Integer + sumCoin !acc sr = + acc + sum (map (Shelley.unCoin . Generic.rewardAmount) $ Set.toList sr) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Certificate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs similarity index 98% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Certificate.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs index 4dfbfe403..66e6df09f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Certificate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Insert.Certificate ( +module Cardano.DbSync.Era.Universal.Insert.Certificate ( insertCertificate, insertDelegCert, insertConwayDelegCert, @@ -35,8 +35,8 @@ import Cardano.DbSync.Cache ( ) import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..)) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Era.Shelley.Insert.GovAction (insertCredDrepHash, insertDrep, insertVotingAnchor) -import Cardano.DbSync.Era.Shelley.Insert.Pool (IsPoolMember, insertPoolCert) +import Cardano.DbSync.Era.Universal.Insert.GovAction (insertCredDrepHash, insertDrep, insertVotingAnchor) +import Cardano.DbSync.Era.Universal.Insert.Pool (IsPoolMember, insertPoolCert) import Cardano.DbSync.Error import Cardano.DbSync.Types import Cardano.DbSync.Util diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs new file mode 100644 index 000000000..aeee9493c --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Cardano.DbSync.Era.Universal.Insert.GovAction ( + insertConstitution, + insertCostModel, + insertCredDrepHash, + insertDrep, + insertDrepDistr, + insertGovActionProposal, + insertParamProposal, + insertVotingProcedures, + insertVotingAnchor, + resolveGovActionProposal, + updateEnacted, +) +where + +import Cardano.BM.Trace (Trace) +import qualified Cardano.Crypto as Crypto +import Cardano.Db (DbWord64 (..)) +import qualified Cardano.Db as DB +import Cardano.DbSync.Cache (queryOrInsertRewardAccount, queryPoolKeyOrInsert) +import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..)) +import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.DbSync.Era.Shelley.Generic.ParamProposal +import Cardano.DbSync.Era.Universal.Insert.Other (toDouble) +import Cardano.DbSync.Era.Util (liftLookupFail) +import Cardano.DbSync.Error +import Cardano.DbSync.Util +import Cardano.DbSync.Util.Bech32 (serialiseDrepToBech32) +import Cardano.Ledger.BaseTypes +import qualified Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.CertState (DRep (..)) +import Cardano.Ledger.Coin (Coin) +import qualified Cardano.Ledger.Coin as Ledger +import Cardano.Ledger.Compactible (Compactible (..)) +import Cardano.Ledger.Conway.Core (DRepVotingThresholds (..), PoolVotingThresholds (..)) +import Cardano.Ledger.Conway.Governance +import qualified Cardano.Ledger.Credential as Ledger +import Cardano.Ledger.DRep (DRepState (..)) +import Cardano.Ledger.Keys (KeyRole (..)) +import qualified Cardano.Ledger.Plutus.CostModels as Ledger +import Cardano.Ledger.Plutus.Language (Language) +import Cardano.Ledger.Shelley.API (Coin (..)) +import Cardano.Prelude +import Control.Monad.Extra (whenJust) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map.Strict as Map +import qualified Data.Text.Encoding as Text +import Database.Persist.Sql (SqlBackend) +import Lens.Micro ((^.)) +import Ouroboros.Consensus.Cardano.Block (StandardConway, StandardCrypto) + +insertGovActionProposal :: + (MonadIO m, MonadBaseControl IO m) => + Cache -> + DB.BlockId -> + DB.TxId -> + Maybe EpochNo -> + (Word64, ProposalProcedure StandardConway) -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertGovActionProposal cache blkId txId govExpiresAt (index, pp) = do + addrId <- + lift $ queryOrInsertRewardAccount cache CacheNew $ pProcReturnAddr pp + votingAnchorId <- lift $ insertAnchor txId $ pProcAnchor pp + mParamProposalId <- lift $ + case pProcGovAction pp of + ParameterChange _ pparams _ -> + Just <$> insertParamProposal blkId txId (convertConwayParamProposal pparams) + _ -> pure Nothing + prevGovActionDBId <- case mprevGovAction of + Nothing -> pure Nothing + Just prevGovActionId -> Just <$> resolveGovActionProposal prevGovActionId + govActionProposalId <- + lift $ + DB.insertGovActionProposal $ + DB.GovActionProposal + { DB.govActionProposalTxId = txId + , DB.govActionProposalIndex = index + , DB.govActionProposalPrevGovActionProposal = prevGovActionDBId + , DB.govActionProposalDeposit = Generic.coinToDbLovelace $ pProcDeposit pp + , DB.govActionProposalReturnAddress = addrId + , DB.govActionProposalExpiration = unEpochNo <$> govExpiresAt + , DB.govActionProposalVotingAnchorId = Just votingAnchorId + , DB.govActionProposalType = Generic.toGovAction $ pProcGovAction pp + , DB.govActionProposalDescription = Text.decodeUtf8 $ LBS.toStrict $ Aeson.encode (pProcGovAction pp) + , DB.govActionProposalParamProposal = mParamProposalId + , DB.govActionProposalRatifiedEpoch = Nothing + , DB.govActionProposalEnactedEpoch = Nothing + , DB.govActionProposalDroppedEpoch = Nothing + , DB.govActionProposalExpiredEpoch = Nothing + } + case pProcGovAction pp of + TreasuryWithdrawals mp _ -> lift $ mapM_ (insertTreasuryWithdrawal govActionProposalId) (Map.toList mp) + UpdateCommittee _ removed added q -> lift $ insertNewCommittee govActionProposalId removed added q + NewConstitution _ constitution -> lift $ insertConstitution txId govActionProposalId constitution + _ -> pure () + where + mprevGovAction :: Maybe (GovActionId StandardCrypto) = case pProcGovAction pp of + ParameterChange prv _ _ -> unGovPurposeId <$> strictMaybeToMaybe prv + HardForkInitiation prv _ -> unGovPurposeId <$> strictMaybeToMaybe prv + NoConfidence prv -> unGovPurposeId <$> strictMaybeToMaybe prv + UpdateCommittee prv _ _ _ -> unGovPurposeId <$> strictMaybeToMaybe prv + NewConstitution prv _ -> unGovPurposeId <$> strictMaybeToMaybe prv + _ -> Nothing + + insertTreasuryWithdrawal gaId (rwdAcc, coin) = do + addrId <- + queryOrInsertRewardAccount cache CacheNew rwdAcc + DB.insertTreasuryWithdrawal $ + DB.TreasuryWithdrawal + { DB.treasuryWithdrawalGovActionProposalId = gaId + , DB.treasuryWithdrawalStakeAddressId = addrId + , DB.treasuryWithdrawalAmount = Generic.coinToDbLovelace coin + } + + insertNewCommittee gaId removed added q = do + void . DB.insertNewCommittee $ + DB.NewCommittee + { DB.newCommitteeGovActionProposalId = gaId + , DB.newCommitteeQuorumNumerator = fromIntegral $ numerator r + , DB.newCommitteeQuorumDenominator = fromIntegral $ denominator r + , DB.newCommitteeDeletedMembers = textShow removed + , DB.newCommitteeAddedMembers = textShow added + } + where + r = unboundRational q -- TODO work directly with Ratio Word64. This is not currently supported in ledger + +-------------------------------------------------------------------------------------- +-- PROPOSAL +-------------------------------------------------------------------------------------- +resolveGovActionProposal :: + MonadIO m => + GovActionId StandardCrypto -> + ExceptT SyncNodeError (ReaderT SqlBackend m) DB.GovActionProposalId +resolveGovActionProposal gaId = do + gaTxId <- + liftLookupFail "resolveGovActionProposal.queryTxId" $ + DB.queryTxId $ + Generic.unTxHash $ + gaidTxId gaId + let (GovActionIx index) = gaidGovActionIx gaId + liftLookupFail "resolveGovActionProposal.queryGovActionProposalId" $ + DB.queryGovActionProposalId gaTxId (fromIntegral index) -- TODO: Use Word32? + +insertParamProposal :: + (MonadBaseControl IO m, MonadIO m) => + DB.BlockId -> + DB.TxId -> + ParamProposal -> + ReaderT SqlBackend m DB.ParamProposalId +insertParamProposal blkId txId pp = do + cmId <- maybe (pure Nothing) (fmap Just . insertCostModel blkId) (pppCostmdls pp) + DB.insertParamProposal $ + DB.ParamProposal + { DB.paramProposalRegisteredTxId = txId + , DB.paramProposalEpochNo = unEpochNo <$> pppEpochNo pp + , DB.paramProposalKey = pppKey pp + , DB.paramProposalMinFeeA = fromIntegral <$> pppMinFeeA pp + , DB.paramProposalMinFeeB = fromIntegral <$> pppMinFeeB pp + , DB.paramProposalMaxBlockSize = fromIntegral <$> pppMaxBlockSize pp + , DB.paramProposalMaxTxSize = fromIntegral <$> pppMaxTxSize pp + , DB.paramProposalMaxBhSize = fromIntegral <$> pppMaxBhSize pp + , DB.paramProposalKeyDeposit = Generic.coinToDbLovelace <$> pppKeyDeposit pp + , DB.paramProposalPoolDeposit = Generic.coinToDbLovelace <$> pppPoolDeposit pp + , DB.paramProposalMaxEpoch = fromIntegral . unEpochInterval <$> pppMaxEpoch pp + , DB.paramProposalOptimalPoolCount = fromIntegral <$> pppOptimalPoolCount pp + , DB.paramProposalInfluence = fromRational <$> pppInfluence pp + , DB.paramProposalMonetaryExpandRate = toDouble <$> pppMonetaryExpandRate pp + , DB.paramProposalTreasuryGrowthRate = toDouble <$> pppTreasuryGrowthRate pp + , DB.paramProposalDecentralisation = toDouble <$> pppDecentralisation pp + , DB.paramProposalEntropy = Generic.nonceToBytes =<< pppEntropy pp + , DB.paramProposalProtocolMajor = getVersion . Ledger.pvMajor <$> pppProtocolVersion pp + , DB.paramProposalProtocolMinor = fromIntegral . Ledger.pvMinor <$> pppProtocolVersion pp + , DB.paramProposalMinUtxoValue = Generic.coinToDbLovelace <$> pppMinUtxoValue pp + , DB.paramProposalMinPoolCost = Generic.coinToDbLovelace <$> pppMinPoolCost pp + , -- New for Alonzo + DB.paramProposalCoinsPerUtxoSize = Generic.coinToDbLovelace <$> pppCoinsPerUtxo pp + , DB.paramProposalCostModelId = cmId + , DB.paramProposalPriceMem = realToFrac <$> pppPriceMem pp + , DB.paramProposalPriceStep = realToFrac <$> pppPriceStep pp + , DB.paramProposalMaxTxExMem = DbWord64 <$> pppMaxTxExMem pp + , DB.paramProposalMaxTxExSteps = DbWord64 <$> pppMaxTxExSteps pp + , DB.paramProposalMaxBlockExMem = DbWord64 <$> pppMaxBlockExMem pp + , DB.paramProposalMaxBlockExSteps = DbWord64 <$> pppMaxBlockExSteps pp + , DB.paramProposalMaxValSize = DbWord64 . fromIntegral <$> pppMaxValSize pp + , DB.paramProposalCollateralPercent = fromIntegral <$> pppCollateralPercentage pp + , DB.paramProposalMaxCollateralInputs = fromIntegral <$> pppMaxCollateralInputs pp + , -- New for Conway + DB.paramProposalPvtMotionNoConfidence = toDouble . pvtMotionNoConfidence <$> pppPoolVotingThresholds pp + , DB.paramProposalPvtCommitteeNormal = toDouble . pvtCommitteeNormal <$> pppPoolVotingThresholds pp + , DB.paramProposalPvtCommitteeNoConfidence = toDouble . pvtCommitteeNoConfidence <$> pppPoolVotingThresholds pp + , DB.paramProposalPvtHardForkInitiation = toDouble . pvtHardForkInitiation <$> pppPoolVotingThresholds pp + , DB.paramProposalDvtMotionNoConfidence = toDouble . dvtMotionNoConfidence <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtCommitteeNormal = toDouble . dvtCommitteeNormal <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtCommitteeNoConfidence = toDouble . dvtCommitteeNoConfidence <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtUpdateToConstitution = toDouble . dvtUpdateToConstitution <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtHardForkInitiation = toDouble . dvtHardForkInitiation <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtPPNetworkGroup = toDouble . dvtPPNetworkGroup <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtPPEconomicGroup = toDouble . dvtPPEconomicGroup <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtPPTechnicalGroup = toDouble . dvtPPTechnicalGroup <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtPPGovGroup = toDouble . dvtPPGovGroup <$> pppDRepVotingThresholds pp + , DB.paramProposalDvtTreasuryWithdrawal = toDouble . dvtTreasuryWithdrawal <$> pppDRepVotingThresholds pp + , DB.paramProposalCommitteeMinSize = DbWord64 . fromIntegral <$> pppCommitteeMinSize pp + , DB.paramProposalCommitteeMaxTermLength = DbWord64 . fromIntegral . unEpochInterval <$> pppCommitteeMaxTermLength pp + , DB.paramProposalGovActionLifetime = fromIntegral . unEpochInterval <$> pppGovActionLifetime pp + , DB.paramProposalGovActionDeposit = DbWord64 . fromIntegral <$> pppGovActionDeposit pp + , DB.paramProposalDrepDeposit = DbWord64 . fromIntegral <$> pppDRepDeposit pp + , DB.paramProposalDrepActivity = fromIntegral . unEpochInterval <$> pppDRepActivity pp + } + +insertConstitution :: (MonadIO m, MonadBaseControl IO m) => DB.TxId -> DB.GovActionProposalId -> Constitution StandardConway -> ReaderT SqlBackend m () +insertConstitution txId gapId constitution = do + votingAnchorId <- insertVotingAnchor txId $ constitutionAnchor constitution + void . DB.insertConstitution $ + DB.Constitution + { DB.constitutionGovActionProposalId = gapId + , DB.constitutionVotingAnchorId = votingAnchorId + , DB.constitutionScriptHash = Generic.unScriptHash <$> strictMaybeToMaybe (constitutionScript constitution) + } + +-------------------------------------------------------------------------------------- +-- VOTING PROCEDURES +-------------------------------------------------------------------------------------- +insertVotingProcedures :: + (MonadIO m, MonadBaseControl IO m) => + Trace IO Text -> + Cache -> + DB.TxId -> + (Voter StandardCrypto, [(GovActionId StandardCrypto, VotingProcedure StandardConway)]) -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertVotingProcedures trce cache txId (voter, actions) = + mapM_ (insertVotingProcedure trce cache txId voter) (zip [0 ..] actions) + +insertVotingProcedure :: + (MonadIO m, MonadBaseControl IO m) => + Trace IO Text -> + Cache -> + DB.TxId -> + Voter StandardCrypto -> + (Word16, (GovActionId StandardCrypto, VotingProcedure StandardConway)) -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertVotingProcedure trce cache txId voter (index, (gaId, vp)) = do + govActionId <- resolveGovActionProposal gaId + votingAnchorId <- whenMaybe (strictMaybeToMaybe $ vProcAnchor vp) $ lift . insertVotingAnchor txId + (mCommitteeVoter, mDRepVoter, mStakePoolVoter) <- case voter of + CommitteeVoter cred -> + pure (Just $ Generic.unCredentialHash cred, Nothing, Nothing) + DRepVoter cred -> do + drep <- lift $ insertCredDrepHash cred + pure (Nothing, Just drep, Nothing) + StakePoolVoter poolkh -> do + poolHashId <- lift $ queryPoolKeyOrInsert "insertVotingProcedure" trce cache CacheNew False poolkh + pure (Nothing, Nothing, Just poolHashId) + void + . lift + . DB.insertVotingProcedure + $ DB.VotingProcedure + { DB.votingProcedureTxId = txId + , DB.votingProcedureIndex = index + , DB.votingProcedureGovActionProposalId = govActionId + , DB.votingProcedureCommitteeVoter = mCommitteeVoter + , DB.votingProcedureDrepVoter = mDRepVoter + , DB.votingProcedurePoolVoter = mStakePoolVoter + , DB.votingProcedureVoterRole = Generic.toVoterRole voter + , DB.votingProcedureVote = Generic.toVote $ vProcVote vp + , DB.votingProcedureVotingAnchorId = votingAnchorId + } + +insertVotingAnchor :: (MonadIO m, MonadBaseControl IO m) => DB.TxId -> Anchor StandardCrypto -> ReaderT SqlBackend m DB.VotingAnchorId +insertVotingAnchor txId anchor = + DB.insertAnchor $ + DB.VotingAnchor + { DB.votingAnchorTxId = txId + , DB.votingAnchorUrl = DB.VoteUrl $ Ledger.urlToText $ anchorUrl anchor -- TODO: Conway check unicode and size of URL + , DB.votingAnchorDataHash = Generic.safeHashToByteString $ anchorDataHash anchor + } + +insertAnchor :: (MonadIO m, MonadBaseControl IO m) => DB.TxId -> Anchor StandardCrypto -> ReaderT SqlBackend m DB.VotingAnchorId +insertAnchor txId anchor = + DB.insertAnchor $ + DB.VotingAnchor + { DB.votingAnchorTxId = txId + , DB.votingAnchorUrl = DB.VoteUrl $ Ledger.urlToText $ anchorUrl anchor -- TODO: Conway check unicode and size of URL + , DB.votingAnchorDataHash = Generic.safeHashToByteString $ anchorDataHash anchor + } + +-------------------------------------------------------------------------------------- +-- DREP +-------------------------------------------------------------------------------------- +insertDrep :: (MonadBaseControl IO m, MonadIO m) => DRep StandardCrypto -> ReaderT SqlBackend m DB.DrepHashId +insertDrep = \case + DRepCredential cred -> insertCredDrepHash cred + DRepAlwaysAbstain -> DB.insertAlwaysAbstainDrep + DRepAlwaysNoConfidence -> DB.insertAlwaysNoConfidence + +insertCredDrepHash :: (MonadBaseControl IO m, MonadIO m) => Ledger.Credential 'DRepRole StandardCrypto -> ReaderT SqlBackend m DB.DrepHashId +insertCredDrepHash cred = do + DB.insertDrepHash + DB.DrepHash + { DB.drepHashRaw = Just bs + , DB.drepHashView = serialiseDrepToBech32 bs + , DB.drepHashHasScript = Generic.hasCredScript cred + } + where + bs = Generic.unCredentialHash cred + +insertDrepDistr :: forall m. (MonadBaseControl IO m, MonadIO m) => EpochNo -> PulsingSnapshot StandardConway -> ReaderT SqlBackend m () +insertDrepDistr e pSnapshot = do + drepsDB <- mapM mkEntry (Map.toList $ psDRepDistr pSnapshot) + DB.insertManyDrepDistr drepsDB + where + mkEntry :: (DRep StandardCrypto, Ledger.CompactForm Coin) -> ReaderT SqlBackend m DB.DrepDistr + mkEntry (drep, coin) = do + drepId <- insertDrep drep + pure $ + DB.DrepDistr + { DB.drepDistrHashId = drepId + , DB.drepDistrAmount = fromIntegral $ unCoin $ fromCompact coin + , DB.drepDistrEpochNo = unEpochNo e + , DB.drepDistrActiveUntil = unEpochNo <$> isActiveEpochNo drep + } + + isActiveEpochNo :: DRep StandardCrypto -> Maybe EpochNo + isActiveEpochNo = \case + DRepAlwaysAbstain -> Nothing + DRepAlwaysNoConfidence -> Nothing + DRepCredential cred -> drepExpiry <$> Map.lookup cred (psDRepState pSnapshot) + +insertCostModel :: + (MonadBaseControl IO m, MonadIO m) => + DB.BlockId -> + Map Language Ledger.CostModel -> + ReaderT SqlBackend m DB.CostModelId +insertCostModel _blkId cms = + DB.insertCostModel $ + DB.CostModel + { DB.costModelHash = Crypto.abstractHashToBytes $ Crypto.serializeCborHash $ Ledger.mkCostModels cms + , DB.costModelCosts = Text.decodeUtf8 $ LBS.toStrict $ Aeson.encode cms + } + +updateEnacted :: forall m. (MonadBaseControl IO m, MonadIO m) => Bool -> EpochNo -> EnactState StandardConway -> ExceptT SyncNodeError (ReaderT SqlBackend m) () +updateEnacted isEnacted epochNo enactedState = do + whenJust (strictMaybeToMaybe (enactedState ^. ensPrevPParamUpdateL)) $ \prevId -> do + gaId <- resolveGovActionProposal $ getPrevId prevId + if isEnacted + then lift $ DB.updateGovActionEnacted gaId (unEpochNo epochNo) + else lift $ DB.updateGovActionRatified gaId (unEpochNo epochNo) + where + getPrevId = unGovPurposeId diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Grouped.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs similarity index 99% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Grouped.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs index bdc04d203..9a3f80498 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Grouped.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Insert.Grouped ( +module Cardano.DbSync.Era.Universal.Insert.Grouped ( BlockGroupedData (..), MissingMaTxOut (..), ExtendedTxIn (..), diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs new file mode 100644 index 000000000..51cf1cecb --- /dev/null +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module Cardano.DbSync.Era.Universal.Insert.LedgerEvent ( + insertBlockLedgerEvents, +) where + +import Cardano.BM.Trace (logInfo) +import qualified Cardano.Db as DB +import Cardano.DbSync.Api +import Cardano.DbSync.Api.Types (SyncEnv (..)) +import Cardano.DbSync.Cache.Types (textShowStats) +import Cardano.DbSync.Era.Cardano.Insert (insertEpochSyncTime) +import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.DbSync.Era.Universal.Adjust (adjustEpochRewards) +import Cardano.DbSync.Era.Universal.Epoch (insertInstantRewards, insertPoolDepositRefunds, insertRewards) +import Cardano.DbSync.Era.Universal.Validate (validateEpochRewards) +import Cardano.DbSync.Error +import Cardano.DbSync.Ledger.Event (LedgerEvent (..)) +import Cardano.DbSync.Types +import Cardano.DbSync.Util +import Cardano.Prelude +import Cardano.Slotting.Slot (EpochNo (..)) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.Map.Strict as Map +import Database.Persist.SqlBackend.Internal +import Database.Persist.SqlBackend.Internal.StatementCache + +-------------------------------------------------------------------------------------------- +-- Insert LedgerEvents +-------------------------------------------------------------------------------------------- +insertBlockLedgerEvents :: + (MonadBaseControl IO m, MonadIO m) => + SyncEnv -> + EpochNo -> + [LedgerEvent] -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () +insertBlockLedgerEvents syncEnv currentEpochNo@(EpochNo curEpoch) = + mapM_ handler + where + tracer = getTrace syncEnv + cache = envCache syncEnv + ntw = getNetwork syncEnv + + subFromCurrentEpoch :: Word64 -> EpochNo + subFromCurrentEpoch m = + if unEpochNo currentEpochNo >= m + then EpochNo $ unEpochNo currentEpochNo - m + else EpochNo 0 + + toSyncState :: SyncState -> DB.SyncState + toSyncState SyncLagging = DB.SyncLagging + toSyncState SyncFollowing = DB.SyncFollowing + + handler :: + (MonadBaseControl IO m, MonadIO m) => + LedgerEvent -> + ExceptT SyncNodeError (ReaderT SqlBackend m) () + handler ev = + case ev of + LedgerNewEpoch en ss -> do + lift $ + insertEpochSyncTime en (toSyncState ss) (envEpochSyncTime syncEnv) + sqlBackend <- lift ask + persistantCacheSize <- liftIO $ statementCacheSize $ connStmtMap sqlBackend + liftIO . logInfo tracer $ "Persistant SQL Statement Cache size is " <> textShow persistantCacheSize + stats <- liftIO $ textShowStats cache + liftIO . logInfo tracer $ stats + liftIO . logInfo tracer $ "Starting epoch " <> textShow (unEpochNo en) + LedgerStartAtEpoch en -> + -- This is different from the previous case in that the db-sync started + -- in this epoch, for example after a restart, instead of after an epoch boundary. + liftIO . logInfo tracer $ "Starting at epoch " <> textShow (unEpochNo en) + LedgerDeltaRewards _e rwd -> do + let rewards = Map.toList $ Generic.unRewards rwd + insertRewards syncEnv ntw (subFromCurrentEpoch 2) currentEpochNo cache (Map.toList $ Generic.unRewards rwd) + -- This event is only created when it's not empty, so we don't need to check for null here. + liftIO . logInfo tracer $ "Inserted " <> show (length rewards) <> " Delta rewards" + LedgerIncrementalRewards _ rwd -> do + let rewards = Map.toList $ Generic.unRewards rwd + insertRewards syncEnv ntw (subFromCurrentEpoch 1) (EpochNo $ curEpoch + 1) cache rewards + LedgerRestrainedRewards e rwd creds -> + lift $ adjustEpochRewards tracer ntw cache e rwd creds + LedgerTotalRewards _e rwd -> + lift $ validateEpochRewards tracer ntw (subFromCurrentEpoch 2) currentEpochNo rwd + LedgerAdaPots _ -> + pure () -- These are handled separately by insertBlock + LedgerMirDist rwd -> do + unless (Map.null rwd) $ do + let rewards = Map.toList rwd + insertInstantRewards ntw (subFromCurrentEpoch 1) currentEpochNo cache rewards + liftIO . logInfo tracer $ "Inserted " <> show (length rewards) <> " Mir rewards" + LedgerPoolReap en drs -> + unless (Map.null $ Generic.unRewards drs) $ do + insertPoolDepositRefunds syncEnv en drs + LedgerDeposits {} -> pure () diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Other.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs similarity index 98% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Other.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs index e0fd0058a..aca8adb6c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Other.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Insert.Other ( +module Cardano.DbSync.Era.Universal.Insert.Other ( toDouble, insertRedeemer, insertDatum, @@ -23,8 +23,8 @@ import qualified Cardano.Db as DB import Cardano.DbSync.Cache (insertDatumAndCache, queryDatum, queryMAWithCache, queryOrInsertRewardAccount, queryOrInsertStakeAddress) import Cardano.DbSync.Cache.Types (Cache (..), CacheNew (..)) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic -import Cardano.DbSync.Era.Shelley.Insert.Grouped import Cardano.DbSync.Era.Shelley.Query (queryStakeRefPtr) +import Cardano.DbSync.Era.Universal.Insert.Grouped import Cardano.DbSync.Era.Util (safeDecodeToJson) import Cardano.DbSync.Error import Cardano.DbSync.Util diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Pool.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs similarity index 99% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Pool.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs index 475762ac3..be0af10d8 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Pool.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs @@ -6,7 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Insert.Pool ( +module Cardano.DbSync.Era.Universal.Insert.Pool ( IsPoolMember, insertPoolRegister, insertPoolRetire, @@ -41,7 +41,6 @@ import qualified Cardano.Ledger.Keys as Ledger import qualified Cardano.Ledger.PoolParams as PoolP import qualified Cardano.Ledger.Shelley.TxBody as Shelley import Cardano.Prelude - import Control.Monad.Trans.Control (MonadBaseControl) import Database.Persist.Sql (SqlBackend) import Ouroboros.Consensus.Cardano.Block (StandardCrypto) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Tx.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs similarity index 97% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Tx.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs index bd933addf..3237bd5a4 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Insert/Tx.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Insert.Tx ( +module Cardano.DbSync.Era.Universal.Insert.Tx ( insertTx, insertTxOut, ) where @@ -22,14 +22,14 @@ import Cardano.DbSync.Cache.Types (Cache (..)) import qualified Cardano.DbSync.Era.Shelley.Generic as Generic import Cardano.DbSync.Era.Shelley.Generic.Metadata (TxMetadataValue (..), metadataValueToJsonNoSchema) -import Cardano.DbSync.Era.Shelley.Insert.Certificate (insertCertificate) -import Cardano.DbSync.Era.Shelley.Insert.GovAction ( +import Cardano.DbSync.Era.Universal.Insert.Certificate (insertCertificate) +import Cardano.DbSync.Era.Universal.Insert.GovAction ( insertGovActionProposal, insertParamProposal, insertVotingProcedures, ) -import Cardano.DbSync.Era.Shelley.Insert.Grouped -import Cardano.DbSync.Era.Shelley.Insert.Other ( +import Cardano.DbSync.Era.Universal.Insert.Grouped +import Cardano.DbSync.Era.Universal.Insert.Other ( insertDatum, insertExtraKeyWitness, insertMultiAsset, @@ -38,7 +38,7 @@ import Cardano.DbSync.Era.Shelley.Insert.Other ( insertStakeAddressRefIfMissing, insertWithdrawals, ) -import Cardano.DbSync.Era.Shelley.Insert.Pool (IsPoolMember) +import Cardano.DbSync.Era.Universal.Insert.Pool (IsPoolMember) import Cardano.DbSync.Era.Util (liftLookupFail, safeDecodeToJson) import Cardano.DbSync.Error import Cardano.DbSync.Ledger.Types (ApplyResult (..), getGovExpiresAt, lookupDepositsMap) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs similarity index 99% rename from cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs rename to cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs index 194cf0073..d269012ee 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Validate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE NoImplicitPrelude #-} -module Cardano.DbSync.Era.Shelley.Validate ( +module Cardano.DbSync.Era.Universal.Validate ( validateEpochRewards, ) where diff --git a/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs b/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs index 0ac5b27a0..a7377c27f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Fix/EpochStake.hs @@ -8,7 +8,7 @@ import qualified Cardano.Db as DB import Cardano.DbSync.Api import Cardano.DbSync.Api.Types import Cardano.DbSync.Era.Shelley.Generic.StakeDist hiding (getStakeSlice) -import Cardano.DbSync.Era.Shelley.Insert.Epoch +import Cardano.DbSync.Era.Universal.Epoch import Cardano.DbSync.Error import Cardano.DbSync.Ledger.State import Cardano.DbSync.Ledger.Types