diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index 8df2f9a65..55f59cd00 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -35,6 +35,7 @@ module Cardano.DbSync.Ledger.State ( getStakeSlice, getSliceMeta, findProposedCommittee, + trimLedgerState, ) where import Cardano.BM.Trace (Trace, logInfo, logWarning) @@ -50,9 +51,15 @@ import Cardano.DbSync.Types import Cardano.DbSync.Util import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import Cardano.Ledger.Alonzo.Scripts +import Cardano.Ledger.Alonzo.TxOut (AlonzoTxOut (..)) +import Cardano.Ledger.Babbage.TxOut (BabbageTxOut (..)) import qualified Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Mary.Value (MaryValue (..)) import Cardano.Ledger.Shelley.AdaPots (AdaPots) import qualified Cardano.Ledger.Shelley.LedgerState as Shelley +import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..)) +import Cardano.Ledger.UTxO (UTxO (..)) import Cardano.Prelude hiding (atomically) import Cardano.Slotting.Block (BlockNo (..)) import Cardano.Slotting.EpochInfo (EpochInfo, epochInfoEpoch) @@ -73,6 +80,7 @@ import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue, write import qualified Control.Exception as Exception import qualified Data.ByteString.Base16 as Base16 +import Data.SOP.Strict (NP (..), fn) import Cardano.DbSync.Api.Types (InsertOptions (..), LedgerEnv (..), SyncOptions (..)) import Cardano.DbSync.Error (SyncNodeError (..), fromEitherSTM) @@ -104,6 +112,7 @@ import Ouroboros.Consensus.Block ( import Ouroboros.Consensus.Block.Abstract (ConvertRawHash (..)) import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..)) import Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardConway, StandardCrypto) +import qualified Ouroboros.Consensus.Cardano.Block as Consensus import Ouroboros.Consensus.Cardano.CanHardFork () import Ouroboros.Consensus.Config (TopLevelConfig (..), configCodec, configLedger) import Ouroboros.Consensus.HardFork.Abstract @@ -217,6 +226,7 @@ readStateUnsafe env = do applyBlockAndSnapshot :: HasLedgerEnv -> CardanoBlock -> Bool -> IO (ApplyResult, Bool) applyBlockAndSnapshot ledgerEnv blk isCons = do (oldState, appResult) <- applyBlock ledgerEnv blk + tookSnapshot <- storeSnapshotAndCleanupMaybe ledgerEnv oldState appResult (blockNo blk) isCons (isSyncedWithinSeconds (apSlotDetails appResult) 600) pure (appResult, tookSnapshot) @@ -233,11 +243,13 @@ applyBlock env blk = do let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (lrEvents result) let (ledgerEvents, deposits) = splitDeposits ledgerEventsFull let !newLedgerState = finaliseDrepDistr (lrResult result) + !details <- getSlotDetails env (ledgerState newLedgerState) time (cardanoBlockSlotNo blk) !newEpoch <- fromEitherSTM $ mkOnNewEpoch (clsState oldState) newLedgerState (findAdaPots ledgerEvents) let !newEpochBlockNo = applyToEpochBlockNo (isJust $ blockIsEBB blk) (isJust newEpoch) (clsEpochBlockNo oldState) let !newState = CardanoLedgerState newLedgerState newEpochBlockNo - let !ledgerDB' = pushLedgerDB ledgerDB newState + let !newState' = maybe newState (trimOnNewEpoch newState) newEpoch + let !ledgerDB' = pushLedgerDB ledgerDB newState' writeTVar (leStateVar env) (Strict.Just ledgerDB') let !appResult = if leUseLedger env @@ -299,6 +311,9 @@ applyBlock env blk = do finaliseDrepDistr ledger = ledger & newEpochStateT %~ forceDRepPulsingState @StandardConway + trimOnNewEpoch :: CardanoLedgerState -> Generic.NewEpoch -> CardanoLedgerState + trimOnNewEpoch ls !_ = trimLedgerState ls + getGovState :: ExtLedgerState CardanoBlock -> Maybe (ConwayGovState StandardConway) getGovState ls = case ledgerState ls of LedgerStateConway cls -> @@ -889,3 +904,56 @@ findProposedCommittee gaId cgs = do UpdateCommittee _ toRemove toAdd q -> Right $ Ledger.SJust $ updatedCommittee toRemove toAdd q scommittee _ -> Left "Unexpected gov action." -- Should never happen since the accumulator only includes UpdateCommittee fromNothing err = maybe (Left err) Right + +trimLedgerState :: CardanoLedgerState -> CardanoLedgerState +trimLedgerState (CardanoLedgerState extLedger epochBlockNo) = + CardanoLedgerState extLedger' epochBlockNo + where + extLedger' = trimExtLedgerState extLedger + +trimExtLedgerState :: ExtLedgerState CardanoBlock -> ExtLedgerState CardanoBlock +trimExtLedgerState = + hApplyExtLedgerState $ + fn id + :* fn id + :* fn (overUTxO trimMaryTxOut) + :* fn (overUTxO trimAlonzoTxOut) + :* fn (overUTxO trimBabbageTxOut) + :* fn (overUTxO trimBabbageTxOut) + :* Nil + +overUTxO :: + (TxOut era -> TxOut era) -> + LedgerState (ShelleyBlock proto era) -> + LedgerState (ShelleyBlock proto era) +overUTxO f ledger = ledger {Consensus.shelleyLedgerState = newEpochState'} + where + newEpochState = Consensus.shelleyLedgerState ledger + newEpochState' = newEpochState & utxosL %~ mapUTxO + utxosL = Shelley.nesEpochStateL . Shelley.esLStateL . Shelley.lsUTxOStateL . Shelley.utxosUtxoL + mapUTxO (UTxO utxos) = UTxO (Map.map f utxos) + +trimMaryTxOut :: + ShelleyTxOut Consensus.StandardMary -> + ShelleyTxOut Consensus.StandardMary +trimMaryTxOut (ShelleyTxOut addr val) = ShelleyTxOut addr val' + where + val' = trimMultiAsset val + +trimAlonzoTxOut :: + AlonzoTxOut Consensus.StandardAlonzo -> + AlonzoTxOut Consensus.StandardAlonzo +trimAlonzoTxOut (AlonzoTxOut addr val hashes) = AlonzoTxOut addr val' hashes + where + val' = trimMultiAsset val + +trimBabbageTxOut :: + (Crypto c, Era era, Value era ~ MaryValue c) => + BabbageTxOut era -> + BabbageTxOut era +trimBabbageTxOut (BabbageTxOut addr val datums refs) = BabbageTxOut addr val' datums refs + where + val' = trimMultiAsset val + +trimMultiAsset :: MaryValue c -> MaryValue c +trimMultiAsset (MaryValue coin _) = MaryValue coin mempty