From caf032cd2b7cd087fc050364c84918a323eb50ec Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 11 Aug 2025 16:22:37 -0400 Subject: [PATCH 1/6] feature: Implement UTxO-HD --- cabal.project | 2 +- cardano-chain-gen/src/Cardano/Mock/Chain.hs | 4 +- cardano-chain-gen/src/Cardano/Mock/ChainDB.hs | 44 ++++-- .../src/Cardano/Mock/ChainSync/Server.hs | 26 ++-- .../src/Cardano/Mock/ChainSync/State.hs | 7 +- .../src/Cardano/Mock/Forging/Interpreter.hs | 44 +++--- .../src/Cardano/Mock/Forging/Tx/Alonzo.hs | 20 +-- .../src/Cardano/Mock/Forging/Tx/Babbage.hs | 24 +-- .../src/Cardano/Mock/Forging/Tx/Conway.hs | 28 ++-- .../Mock/Forging/Tx/Conway/Scenarios.hs | 9 +- .../src/Cardano/Mock/Forging/Tx/Generic.hs | 18 +-- .../src/Cardano/Mock/Forging/Tx/Shelley.hs | 6 +- .../test/Test/Cardano/Db/Mock/UnifiedApi.hs | 30 ++-- .../test/Test/Cardano/Db/Mock/Validate.hs | 6 +- .../src/Cardano/DbSync/Api/Ledger.hs | 2 +- .../DbSync/Era/Shelley/Generic/EpochUpdate.hs | 4 +- .../DbSync/Era/Shelley/Generic/ProtoParams.hs | 6 +- .../DbSync/Era/Shelley/Generic/StakeDist.hs | 12 +- .../src/Cardano/DbSync/Ledger/State.hs | 94 ++++++++---- .../src/Cardano/DbSync/Ledger/Types.hs | 137 ++++++++++++++---- .../src/Cardano/DbTool/Validate/Balance.hs | 7 +- 21 files changed, 356 insertions(+), 174 deletions(-) diff --git a/cabal.project b/cabal.project index 3b237bd19..3794a93c4 100644 --- a/cabal.project +++ b/cabal.project @@ -78,7 +78,7 @@ constraints: -- then clashes with the `show` in `Prelude`. , text < 2.1.2 - , cardano-node ^>= 10.3 + , cardano-node ^>= 10.4 if impl (ghc >= 9.12) allow-newer: diff --git a/cardano-chain-gen/src/Cardano/Mock/Chain.hs b/cardano-chain-gen/src/Cardano/Mock/Chain.hs index bb2dd746c..0f2bebe12 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Chain.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Chain.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PartialTypeSignatures #-} module Cardano.Mock.Chain ( Chain' (..), @@ -20,6 +21,7 @@ import Ouroboros.Consensus.Block import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) -- | This looks a lot like the 'Chain' defined in Ouroboros.Network.MockChain.Chain -- but this version includes also the ledger states. @@ -30,7 +32,7 @@ data Chain' block st type State block = Consensus.ExtLedgerState block -type Chain block = Chain' block (State block) +type Chain block = Chain' block (State block ValuesMK) infixl 5 :> diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs index c281adb3b..a420d0cb8 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} module Cardano.Mock.ChainDB ( ChainDB (..), + currentState, initChainDB, headTip, - currentState, replaceGenesisDB, extendChainDB, findFirstPoint, @@ -17,13 +19,17 @@ module Cardano.Mock.ChainDB ( currentBlockNo, ) where +import Ouroboros.Consensus.Cardano.Ledger () +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () +import Ouroboros.Consensus.Cardano.CanHardFork () import Cardano.Mock.Chain import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import qualified Ouroboros.Consensus.Ledger.Extended as Consensus -import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) import Ouroboros.Network.Block (Tip (..)) +import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -- | Thin layer around 'Chain' that knows how to apply blocks and maintain -- new and old states. The state here, which is the 'Chain', is not a MVar, @@ -41,7 +47,10 @@ instance Eq (Chain block) => Eq (ChainDB block) where instance Show (Chain block) => Show (ChainDB block) where show = show . cchain -initChainDB :: TopLevelConfig block -> State block -> ChainDB block +initChainDB :: + TopLevelConfig block -> + State block ValuesMK -> + ChainDB block initChainDB config st = ChainDB config (Genesis st) headTip :: HasHeader block => ChainDB block -> Tip block @@ -50,20 +59,37 @@ headTip chainDB = Genesis _ -> TipGenesis (_ :> (b, _)) -> Tip (blockSlot b) (blockHash b) (blockNo b) -currentState :: ChainDB block -> State block +currentState :: ChainDB block -> State block ValuesMK currentState chainDB = case cchain chainDB of Genesis st -> st _ :> (_, st) -> st -replaceGenesisDB :: ChainDB block -> State block -> ChainDB block +replaceGenesisDB :: + ChainDB block -> + State block ValuesMK -> + ChainDB block replaceGenesisDB chainDB st = chainDB {cchain = Genesis st} -extendChainDB :: LedgerSupportsProtocol block => ChainDB block -> block -> ChainDB block +extendChainDB :: + LedgerSupportsProtocol block => + ChainDB block -> + block -> + ChainDB block extendChainDB chainDB blk = do let !chain = cchain chainDB - !st = tickThenReapply ComputeLedgerEvents (Consensus.ExtLedgerCfg $ chainConfig chainDB) blk (getTipState chain) - in chainDB {cchain = chain :> (blk, st)} + -- Get the current ledger state + !tipState = getTipState chain + -- Apply the block and compute the diffs + !diffState = tickThenReapply + ComputeLedgerEvents + (Consensus.ExtLedgerCfg $ chainConfig chainDB) + blk + tipState + -- Apply the diffs + !newTipState = applyDiffs tipState diffState + + in chainDB {cchain = chain :> (blk, newTipState)} findFirstPoint :: HasHeader block => [Point block] -> ChainDB block -> Maybe (Point block) findFirstPoint points chainDB = findFirstPointChain points (cchain chainDB) diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs index d742e5865..ec208a35c 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs @@ -55,7 +55,7 @@ import Network.TypedProtocol.Stateful.Codec () import qualified Network.TypedProtocol.Stateful.Peer as St import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint) import Ouroboros.Consensus.Config (TopLevelConfig, configCodec) -import Ouroboros.Consensus.Ledger.Query (BlockQuery, ShowQuery) +import Ouroboros.Consensus.Ledger.Query (BlockQuery, ShowQuery, QueryFootprint (..), BlockSupportsLedgerQuery) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, TxId) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Network.NodeToClient (Apps (..), Codecs' (..), DefaultCodecs) @@ -107,6 +107,7 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQu import Ouroboros.Network.Snocket (LocalAddress, LocalSnocket, LocalSocket (..)) import qualified Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Util.ShowProxy (Proxy (..), ShowProxy (..)) +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) {- HLINT ignore "Use readTVarIO" -} @@ -116,7 +117,7 @@ data ServerHandle m blk = ServerHandle , forkAgain :: m (Async ()) } -replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk -> STM m () +replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk ValuesMK -> STM m () replaceGenesis handle st = modifyTVar (chainProducerState handle) $ \cps -> cps {chainDB = replaceGenesisDB (chainDB cps) st} @@ -125,12 +126,20 @@ readChain :: MonadSTM m => ServerHandle m blk -> STM m (Chain blk) readChain handle = do cchain . chainDB <$> readTVar (chainProducerState handle) -addBlock :: (LedgerSupportsProtocol blk, MonadSTM m) => ServerHandle m blk -> blk -> STM m () +addBlock :: + (LedgerSupportsProtocol blk, MonadSTM m) => + ServerHandle m blk -> + blk -> + STM m () addBlock handle blk = modifyTVar (chainProducerState handle) $ addBlockState blk -rollback :: (LedgerSupportsProtocol blk, MonadSTM m) => ServerHandle m blk -> Point blk -> STM m () +rollback :: + (LedgerSupportsProtocol blk, MonadSTM m) => + ServerHandle m blk -> + Point blk -> + STM m () rollback handle point = modifyTVar (chainProducerState handle) $ \st -> case rollbackState point st of @@ -153,7 +162,8 @@ stopServer sh = do type MockServerConstraint blk = ( SerialiseNodeToClientConstraints blk - , ShowQuery (BlockQuery blk) + , BlockSupportsLedgerQuery blk + , ShowQuery (BlockQuery blk 'QFNoTables) , StandardHash blk , ShowProxy (ApplyTxErr blk) , Serialise (HeaderHash blk) @@ -167,11 +177,10 @@ type MockServerConstraint blk = ) forkServerThread :: - forall blk. MockServerConstraint blk => IOManager -> TopLevelConfig blk -> - State blk -> + State blk ValuesMK -> NetworkMagic -> FilePath -> IO (ServerHandle IO blk) @@ -183,11 +192,10 @@ forkServerThread iom config initSt netMagic path = do pure $ ServerHandle chainSt threadVar runThread withServerHandle :: - forall blk a. MockServerConstraint blk => IOManager -> TopLevelConfig blk -> - State blk -> + State blk ValuesMK -> NetworkMagic -> FilePath -> (ServerHandle IO blk -> IO a) -> diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs b/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs index 3b4e4b57a..73e094e38 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -24,6 +25,7 @@ import Ouroboros.Consensus.Block (HasHeader, HeaderHash, Point, blockPoint, cast import Ouroboros.Consensus.Config (TopLevelConfig) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Network.Block (ChainUpdate (..)) +import Ouroboros.Consensus.Ledger.Tables (ValuesMK) data ChainProducerState block = ChainProducerState { chainDB :: ChainDB block @@ -52,7 +54,10 @@ data FollowerNext | FollowerForwardFrom deriving (Eq, Show) -initChainProducerState :: TopLevelConfig block -> Chain.State block -> ChainProducerState block +initChainProducerState :: + TopLevelConfig block -> + Chain.State block ValuesMK -> + ChainProducerState block initChainProducerState config st = ChainProducerState (initChainDB config st) Map.empty 0 -- | Add a block to the chain. It does not require any follower's state changes. diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs index 568ea181e..27baa9473 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs @@ -32,6 +32,7 @@ module Cardano.Mock.Forging.Interpreter ( mkTxId, ) where +import Ouroboros.Consensus.Shelley.Ledger.Ledger import Cardano.Ledger.Core (txIdTx) import qualified Cardano.Ledger.Shelley.API.Mempool as Ledger import Cardano.Ledger.Shelley.LedgerState (NewEpochState (..)) @@ -81,6 +82,7 @@ import Ouroboros.Consensus.Cardano.Block ( ShelleyEra, ) import Ouroboros.Consensus.Cardano.CanHardFork () +import Ouroboros.Consensus.Cardano.Ledger () import Ouroboros.Consensus.Config ( TopLevelConfig, configConsensus, @@ -94,7 +96,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Ledger () import qualified Ouroboros.Consensus.HardFork.Combinator.Mempool as Consensus import Ouroboros.Consensus.HeaderValidation (headerStateChainDep) import Ouroboros.Consensus.Ledger.Abstract (TickedLedgerState, applyChainTick) -import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..)) +import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), ValuesMK) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, headerState, ledgerState) import Ouroboros.Consensus.Ledger.SupportsMempool ( ApplyTxErr, @@ -104,6 +106,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool ( applyTx, ) import Ouroboros.Consensus.Ledger.SupportsProtocol (ledgerViewForecastAt) +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.ProtocolInfo ( ProtocolInfo, pInfoConfig, @@ -118,7 +121,7 @@ import Ouroboros.Consensus.Protocol.Abstract ( import Ouroboros.Consensus.Protocol.Praos () import Ouroboros.Consensus.Protocol.TPraos () import Ouroboros.Consensus.Shelley.HFEras () -import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, Ticked, shelleyLedgerState) +import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger.Mempool as Consensus import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import qualified Ouroboros.Consensus.TypeFamilyWrappers as Consensus @@ -232,13 +235,13 @@ initInterpreter :: initInterpreter pinfo forging traceForge mFingerprintFile = do let topLeverCfg = pInfoConfig pinfo let initSt = pInfoInitLedger pinfo - let ledgerView = mkForecast topLeverCfg initSt + let ledgerView' = mkForecast topLeverCfg initSt (mode, fingerprint) <- mkFingerprint mFingerprintFile stvar <- newTVarIO $ InterpreterState { istChain = initChainDB topLeverCfg initSt - , istForecast = ledgerView + , istForecast = ledgerView' , istSlot = SlotNo 0 , -- The first real Byron block (ie block that can contain txs) is number 1. istNextBlockNo = BlockNo 1 @@ -360,20 +363,22 @@ forgeNextLeaders interpreter txes possibleLeaders = do else throwIO $ FailedToValidateSlot currentSlot (lengthSlots <$> istFingerprint interState) (interpFingerFile interpreter) Just (proof, blockForging) -> do -- Tick the ledger state for the 'SlotNo' we're producing a block for - let tickedLedgerSt :: Ticked (LedgerState CardanoBlock) - !tickedLedgerSt = + let ledgerState' = ledgerState $ currentState (istChain interState) + + tickedLedgerSt = applyChainTick ComputeLedgerEvents (configLedger cfg) currentSlot - (ledgerState . currentState $ istChain interState) + (forgetLedgerTables ledgerState') + !blk <- Block.forgeBlock blockForging cfg (istNextBlockNo interState) currentSlot - tickedLedgerSt + (forgetLedgerTables tickedLedgerSt) (mkValidated <$> txes) proof @@ -384,7 +389,7 @@ forgeNextLeaders interpreter txes possibleLeaders = do _applyTxs :: [Consensus.GenTx CardanoBlock] -> SlotNo -> - TickedLedgerState CardanoBlock -> + TickedLedgerState CardanoBlock ValuesMK -> Either (ApplyTxErr CardanoBlock) [Validated (GenTx CardanoBlock)] _applyTxs genTxs slotNo st = runExcept @@ -405,7 +410,7 @@ tryAllForging interpreter interState currentSlot xs = do let cfg = interpTopLeverConfig interpreter -- We require the ticked ledger view in order to construct the ticked 'ChainDepState'. - ledgerView <- case runExcept (forecastFor (istForecast interState) currentSlot) of + ledgerView' <- case runExcept (forecastFor (istForecast interState) currentSlot) of Right lv -> pure (lv :: (LedgerView (BlockProtocol CardanoBlock))) -- Left can only happen if we cross an epoch boundary Left err -> throwIO $ ForecastError currentSlot err @@ -417,7 +422,7 @@ tryAllForging interpreter interState currentSlot xs = do !tickedChainDepState = tickChainDepState (configConsensus cfg) - ledgerView + ledgerView' currentSlot (headerStateChainDep (headerState $ currentState $ istChain interState)) @@ -471,7 +476,7 @@ rollbackInterpreter interpreter pnt = do getCurrentInterpreterState :: Interpreter -> IO InterpreterState getCurrentInterpreterState = readTVarIO . interpState -getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock) +getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock ValuesMK) getCurrentLedgerState = fmap (currentState . istChain) . getCurrentInterpreterState getNextBlockNo :: Interpreter -> IO BlockNo @@ -495,7 +500,7 @@ getCurrentSlot interp = istSlot <$> readTVarIO (interpState interp) withBabbageLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock PraosStandard BabbageEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> Either ForgingError a) -> IO a withBabbageLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -507,7 +512,7 @@ withBabbageLedgerState inter mk = do withConwayLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock PraosStandard ConwayEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK -> Either ForgingError a) -> IO a withConwayLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -519,7 +524,7 @@ withConwayLedgerState inter mk = do withAlonzoLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK -> Either ForgingError a) -> IO a withAlonzoLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -531,7 +536,7 @@ withAlonzoLedgerState inter mk = do withShelleyLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> Either ForgingError a) -> IO a withShelleyLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -623,9 +628,12 @@ mkValidated txe = mkForecast :: TopLevelConfig CardanoBlock -> - ExtLedgerState CardanoBlock -> + ExtLedgerState CardanoBlock ValuesMK -> Forecast (LedgerView (BlockProtocol CardanoBlock)) -mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st) +mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st') + where + st' :: ExtLedgerState CardanoBlock ValuesMK + st' = st throwLeftIO :: Exception e => Either e a -> IO a throwLeftIO = either throwIO pure diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs index 36c4b7074..ebdbfca7c 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Alonzo.hs @@ -123,7 +123,7 @@ mkPaymentTx :: AlonzoUTxOIndex -> Integer -> Integer -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkPaymentTx inputIndex outputIndex amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -138,7 +138,7 @@ mkPaymentTx inputIndex outputIndex amount fees sta = do mkPaymentTx' :: AlonzoUTxOIndex -> [(AlonzoUTxOIndex, MaryValue)] -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkPaymentTx' inputIndex outputIndex sta = do inputPair <- fst <$> resolveUTxOIndex inputIndex sta @@ -159,7 +159,7 @@ mkLockByScriptTx :: [Bool] -> Integer -> Integer -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkLockByScriptTx inputIndex spendable amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -183,7 +183,7 @@ mkUnlockScriptTx :: Bool -> Integer -> Integer -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex @@ -249,7 +249,7 @@ mkMAssetsScriptTx :: MultiAsset -> Bool -> Integer -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkMAssetsScriptTx inputIndex colInputIndex outputIndex minted succeeds fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex @@ -277,7 +277,7 @@ mkDCertTx certs wdrl = Right $ mkSimpleTx True $ consCertTxBody certs wdrl mkSimpleDCertTx :: [(StakeIndex, StakeCredential -> ShelleyTxCert AlonzoEra)] -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkSimpleDCertTx consDert st = do dcerts <- forM consDert $ \(stakeIndex, mkDCert) -> do @@ -291,7 +291,7 @@ mkDCertPoolTx :: , [StakeCredential] -> KeyHash 'StakePool -> ShelleyTxCert AlonzoEra ) ] -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkDCertPoolTx consDert st = do dcerts <- forM consDert $ \(stakeIxs, poolIx, mkDCert) -> do @@ -303,7 +303,7 @@ mkDCertPoolTx consDert st = do mkScriptDCertTx :: [(StakeIndex, Bool, StakeCredential -> ShelleyTxCert AlonzoEra)] -> Bool -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkScriptDCertTx consDert valid st = do dcerts <- forM consDert $ \(stakeIndex, _, mkDCert) -> do @@ -326,7 +326,7 @@ mkScriptDCertTx consDert valid st = do mkDepositTxPools :: AlonzoUTxOIndex -> Integer -> - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkDepositTxPools inputIndex deposit sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -337,7 +337,7 @@ mkDepositTxPools inputIndex deposit sta = do Right $ mkSimpleTx True $ consTxBody input mempty (StrictSeq.fromList [change]) (Coin 0) mempty (allPoolStakeCert sta) (Withdrawals mempty) mkDCertTxPools :: - AlonzoLedgerState -> + AlonzoLedgerState mk -> Either ForgingError (AlonzoTx AlonzoEra) mkDCertTxPools sta = Right $ mkSimpleTx True $ consCertTxBody (allPoolStakeCert sta) (Withdrawals mempty) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs index 5f84c72b3..4b3b87c61 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs @@ -164,7 +164,7 @@ mkPaymentTx :: BabbageUTxOIndex -> Integer -> Integer -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkPaymentTx inputIndex outputIndex amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -179,7 +179,7 @@ mkPaymentTx inputIndex outputIndex amount fees sta = do mkPaymentTx' :: BabbageUTxOIndex -> [(BabbageUTxOIndex, MaryValue)] -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkPaymentTx' inputIndex outputIndex sta = do inputPair <- fst <$> resolveUTxOIndex inputIndex sta @@ -221,7 +221,7 @@ mkLockByScriptTx :: [TxOutScriptType] -> Integer -> Integer -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkLockByScriptTx inputIndex txOutTypes amount fees sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -254,7 +254,7 @@ mkUnlockScriptTx :: Bool -> Integer -> Integer -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkUnlockScriptTx inputIndex colInputIndex outputIndex succeeds amount fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex @@ -279,7 +279,7 @@ mkUnlockScriptTxBabbage :: Bool -> Integer -> Integer -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkUnlockScriptTxBabbage inputIndex colInputIndex outputIndex refInput compl succeeds amount fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex @@ -339,7 +339,7 @@ mkMAssetsScriptTx :: MultiAsset -> Bool -> Integer -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkMAssetsScriptTx inputIndex colInputIndex outputIndex refInput minted succeeds fees sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inputIndex @@ -369,7 +369,7 @@ mkDCertTx certs wdrl ref = Right $ mkSimpleTx True $ consCertTxBody ref certs wd mkSimpleDCertTx :: [(StakeIndex, StakeCredential -> ShelleyTxCert BabbageEra)] -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkSimpleDCertTx consDert st = do dcerts <- forM consDert $ \(stakeIndex, mkDCert) -> do @@ -390,7 +390,7 @@ mkDCertPoolTx :: , [StakeCredential] -> KeyHash 'StakePool -> ShelleyTxCert BabbageEra ) ] -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkDCertPoolTx consDert st = do dcerts <- forM consDert $ \(stakeIxs, poolIx, mkDCert) -> do @@ -402,7 +402,7 @@ mkDCertPoolTx consDert st = do mkScriptDCertTx :: [(StakeIndex, Bool, StakeCredential -> ShelleyTxCert BabbageEra)] -> Bool -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkScriptDCertTx consDert valid st = do dcerts <- forM consDert $ \(stakeIndex, _, mkDCert) -> do @@ -425,7 +425,7 @@ mkScriptDCertTx consDert valid st = do mkDepositTxPools :: BabbageUTxOIndex -> Integer -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkDepositTxPools inputIndex deposit sta = do (inputPair, _) <- resolveUTxOIndex inputIndex sta @@ -436,7 +436,7 @@ mkDepositTxPools inputIndex deposit sta = do Right $ mkSimpleTx True $ consTxBody input mempty mempty (StrictSeq.fromList [change]) SNothing (Coin 0) mempty (allPoolStakeCert sta) (Withdrawals mempty) mkDCertTxPools :: - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkDCertTxPools sta = Right $ mkSimpleTx True $ consCertTxBody Nothing (allPoolStakeCert sta) (Withdrawals mempty) @@ -529,7 +529,7 @@ mkParamUpdateTx = Right (mkSimpleTx True txBody) mkFullTx :: Int -> Integer -> - BabbageLedgerState -> + BabbageLedgerState mk -> Either ForgingError (AlonzoTx BabbageEra) mkFullTx n m sta = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` sta) inps diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs index 9c231a546..24ca8245f 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs @@ -199,7 +199,7 @@ mkPaymentTx :: Integer -> Integer -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkPaymentTx inputIndex outputIndex amount = mkPaymentTx' inputIndex outputIndices @@ -211,7 +211,7 @@ mkPaymentTx' :: [(ConwayUTxOIndex, MaryValue)] -> Integer -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkPaymentTx' inputIndex outputIndices fees donation state' = do (inputPair, _) <- resolveUTxOIndex inputIndex state' @@ -253,7 +253,7 @@ mkLockByScriptTx :: [Babbage.TxOutScriptType] -> Integer -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkLockByScriptTx inputIndex txOutTypes amount fees state' = do (inputPair, _) <- resolveUTxOIndex inputIndex state' @@ -287,7 +287,7 @@ mkUnlockScriptTx :: Bool -> Integer -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkUnlockScriptTx inputIndex colInputIndex outputIndex = mkUnlockScriptTx' inputIndex colInputIndex outputIndex mempty Nothing @@ -301,7 +301,7 @@ mkUnlockScriptTxBabbage :: Bool -> Integer -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkUnlockScriptTxBabbage inputIndex colInputIndex outputIndex refInput compl succeeds amount fees state' = do let colTxOutType = @@ -336,7 +336,7 @@ mkDCertPoolTx :: ConwayTxCert ConwayEra ) ] -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkDCertPoolTx consDCert state' = do dcerts <- forM consDCert $ \(stakeIxs, poolIx, mkDCert) -> do @@ -346,7 +346,7 @@ mkDCertPoolTx consDCert state' = do mkDCertTx dcerts (Withdrawals mempty) Nothing -mkDCertTxPools :: ConwayLedgerState -> Either ForgingError (AlonzoTx ConwayEra) +mkDCertTxPools :: ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkDCertTxPools state' = Right $ mkSimpleTx True $ @@ -376,7 +376,7 @@ mkAuxDataTx isValid' txBody auxData = mkSimpleDCertTx :: [(StakeIndex, StakeCredential -> ConwayTxCert ConwayEra)] -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkSimpleDCertTx consDCert st = do dcerts <- forM consDCert $ \(stakeIndex, mkDCert) -> do @@ -387,7 +387,7 @@ mkSimpleDCertTx consDCert st = do mkScriptDCertTx :: [(StakeIndex, Bool, StakeCredential -> ConwayTxCert ConwayEra)] -> Bool -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkScriptDCertTx consCert isValid' state' = do dcerts <- forM consCert $ \(stakeIndex, _, mkDCert) -> do @@ -416,7 +416,7 @@ mkMultiAssetsScriptTx :: MultiAsset -> Bool -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkMultiAssetsScriptTx inputIx colInputIx outputIx refInput minted succeeds fees state' = do inputs <- mapM (`resolveUTxOIndex` state') inputIx @@ -454,7 +454,7 @@ mkMultiAssetsScriptTx inputIx colInputIx outputIx refInput minted succeeds fees mkDepositTxPools :: ConwayUTxOIndex -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkDepositTxPools inputIndex deposit state' = do (inputPair, _) <- resolveUTxOIndex inputIndex state' @@ -649,7 +649,7 @@ mkDummyTxBody = mkFullTx :: Int -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkFullTx n m state' = do inputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` state') inputs @@ -883,7 +883,7 @@ mkUnlockScriptTx' :: Bool -> Integer -> Integer -> - ConwayLedgerState -> + ConwayLedgerState mk -> Either ForgingError (AlonzoTx ConwayEra) mkUnlockScriptTx' inputIndex colInputIndex outputIndex refInput colOut succeeds amount fees state' = do inputPairs <- map fst <$> mapM (`resolveUTxOIndex` state') inputIndex @@ -913,7 +913,7 @@ mkUnlockScriptTx' inputIndex colInputIndex outputIndex refInput colOut succeeds mempty (Coin 0) -allPoolStakeCert' :: ConwayLedgerState -> [ConwayTxCert ConwayEra] +allPoolStakeCert' :: ConwayLedgerState mk -> [ConwayTxCert ConwayEra] allPoolStakeCert' st = map (mkRegTxCert SNothing) (getCreds st) where getCreds = nub . concatMap getPoolStakeCreds . Map.elems . stakePoolParams diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs index 1898f925b..907fa9691 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs @@ -34,9 +34,10 @@ import Ouroboros.Consensus.Cardano.Block (LedgerState (..)) import Ouroboros.Consensus.Shelley.Eras (ConwayEra ()) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock ()) import qualified Prelude +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) -newtype ShelleyLedgerState era = ShelleyLedgerState - {unState :: LedgerState (ShelleyBlock PraosStandard era)} +newtype ShelleyLedgerState era mk = ShelleyLedgerState + {unState :: LedgerState (ShelleyBlock PraosStandard era) mk} delegateAndSendBlocks :: Int -> Interpreter -> IO [CardanoBlock] delegateAndSendBlocks n interpreter = do @@ -86,7 +87,7 @@ mkPaymentBlocks utxoIx addresses interpreter = forgeBlocksChunked :: Interpreter -> [a] -> - ([a] -> ShelleyLedgerState ConwayEra -> Either ForgingError (Tx ConwayEra)) -> + ([a] -> ShelleyLedgerState ConwayEra ValuesMK -> Either ForgingError (Tx ConwayEra)) -> IO [CardanoBlock] forgeBlocksChunked interpreter vs f = forM (chunksOf 500 vs) $ \blockCreds -> do blockTxs <- withConwayLedgerState interpreter $ \state' -> @@ -107,7 +108,7 @@ registerDRepsAndDelegateVotes interpreter = do registerDRepAndDelegateVotes' :: Credential 'DRepRole -> StakeIndex -> - Conway.ConwayLedgerState -> + Conway.ConwayLedgerState mk -> Either ForgingError [AlonzoTx ConwayEra] registerDRepAndDelegateVotes' drepId stakeIx ledger = do stakeCreds <- resolveStakeCreds stakeIx ledger diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs index 1c0c9586c..5dc6c4d78 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Generic.hs @@ -68,10 +68,10 @@ import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus resolveAddress :: - forall era p. + forall era p mk. (Core.EraTxOut era, EraCertState era) => UTxOIndex era -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> Either ForgingError Addr resolveAddress index st = case index of UTxOAddressNew n -> Right $ Addr Testnet (unregisteredAddresses !! n) StakeRefNull @@ -84,10 +84,10 @@ resolveAddress index st = case index of _ -> (^. Core.addrTxOutL) . snd . fst <$> resolveUTxOIndex index st resolveUTxOIndex :: - forall era p. + forall era p mk. (Core.EraTxOut era, EraCertState era) => UTxOIndex era -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> Either ForgingError ((TxIn, Core.TxOut era), UTxOIndex era) resolveUTxOIndex index st = toLeft $ case index of UTxOIndex n -> utxoPairs !? n @@ -122,10 +122,10 @@ resolveUTxOIndex index st = toLeft $ case index of toLeft (Just (txIn, txOut)) = Right ((txIn, txOut), UTxOInput txIn) resolveStakeCreds :: - forall era p. + forall era p mk. EraCertState era => StakeIndex -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> Either ForgingError StakeCredential resolveStakeCreds indx st = case indx of StakeIndex n -> toEither $ fst <$> (rewardAccs !? n) @@ -177,7 +177,7 @@ resolveStakeCreds indx st = case indx of resolvePool :: EraCertState era => PoolIndex -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> KeyHash 'StakePool resolvePool pix st = case pix of PoolIndexId key -> key @@ -194,7 +194,7 @@ resolvePool pix st = case pix of Consensus.shelleyLedgerState st in certState ^. certPStateL -allPoolStakeCert :: EraCertState era => LedgerState (ShelleyBlock p era) -> [ShelleyTxCert era] +allPoolStakeCert :: EraCertState era => LedgerState (ShelleyBlock p era) mk -> [ShelleyTxCert era] allPoolStakeCert st = ShelleyTxCertDelegCert . ShelleyRegCert <$> nub creds where @@ -337,7 +337,7 @@ consPoolParams poolId rwCred owners = resolveStakePoolVoters :: EraCertState era => - LedgerState (ShelleyBlock proto era) -> + LedgerState (ShelleyBlock proto era) mk -> [Voter] resolveStakePoolVoters ledger = [ StakePoolVoter (resolvePool (PoolIndex 0) ledger) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs index b914ae221..ff3cbe7be 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Shelley.hs @@ -45,7 +45,7 @@ mkPaymentTx :: ShelleyUTxOIndex -> Integer -> Integer -> - ShelleyLedgerState -> + ShelleyLedgerState mk -> Either ForgingError ShelleyTx mkPaymentTx inputIndex outputIndex amount fees st = do (inputPair, _) <- resolveUTxOIndex inputIndex st @@ -59,7 +59,7 @@ mkPaymentTx inputIndex outputIndex amount fees st = do Right $ mkSimpleTx $ consPaymentTxBody input (StrictSeq.fromList [output, change]) (Coin fees) -mkDCertTxPools :: ShelleyLedgerState -> Either ForgingError ShelleyTx +mkDCertTxPools :: ShelleyLedgerState mk -> Either ForgingError ShelleyTx mkDCertTxPools sta = Right $ mkSimpleTx $ consCertTxBody (allPoolStakeCert sta) (Withdrawals mempty) mkSimpleTx :: ShelleyTxBody ShelleyEra -> ShelleyTx @@ -74,7 +74,7 @@ mkDCertTx certs wdrl = Right $ mkSimpleTx $ consCertTxBody certs wdrl mkSimpleDCertTx :: [(StakeIndex, StakeCredential -> ShelleyTxCert ShelleyEra)] -> - ShelleyLedgerState -> + ShelleyLedgerState mk -> Either ForgingError ShelleyTx mkSimpleDCertTx consDert st = do dcerts <- forM consDert $ \(stakeIndex, mkDCert) -> do diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs index 8273f1c2a..8ea6c5c93 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs @@ -40,7 +40,7 @@ import Ouroboros.Consensus.Cardano.Block ( ConwayEra, ShelleyEra, ) -import Ouroboros.Consensus.Ledger.Basics (LedgerState) +import Ouroboros.Consensus.Ledger.Basics (LedgerState, ValuesMK) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) forgeNextAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> MockBlock -> IO CardanoBlock @@ -68,7 +68,7 @@ forgeAndSubmitBlocks interpreter mockServer blocksToCreate = withAlonzoFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock TPraosStandard AlonzoEra) -> + ( LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK -> Either ForgingError [Core.Tx AlonzoEra] ) -> IO CardanoBlock @@ -79,7 +79,7 @@ withAlonzoFindLeaderAndSubmit interpreter mockServer mkTxs = do withBabbageFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> - (LedgerState (ShelleyBlock PraosStandard BabbageEra) -> Either ForgingError [Core.Tx BabbageEra]) -> + (LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> Either ForgingError [Core.Tx BabbageEra]) -> IO CardanoBlock withBabbageFindLeaderAndSubmit interpreter mockServer mkTxs = do alTxs <- withBabbageLedgerState interpreter mkTxs @@ -88,7 +88,7 @@ withBabbageFindLeaderAndSubmit interpreter mockServer mkTxs = do withConwayFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> - (LedgerState (ShelleyBlock PraosStandard ConwayEra) -> Either ForgingError [Core.Tx ConwayEra]) -> + (LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK -> Either ForgingError [Core.Tx ConwayEra]) -> IO CardanoBlock withConwayFindLeaderAndSubmit interpreter mockServer mkTxs = do txs' <- withConwayLedgerState interpreter mkTxs @@ -97,7 +97,7 @@ withConwayFindLeaderAndSubmit interpreter mockServer mkTxs = do withAlonzoFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock TPraosStandard AlonzoEra) -> + ( LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK -> Either ForgingError (Core.Tx AlonzoEra) ) -> IO CardanoBlock @@ -109,7 +109,9 @@ withAlonzoFindLeaderAndSubmitTx interpreter mockServer mkTxs = do withBabbageFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - (LedgerState (ShelleyBlock PraosStandard BabbageEra) -> Either ForgingError (Core.Tx BabbageEra)) -> + ( LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> + Either ForgingError (Core.Tx BabbageEra) + ) -> IO CardanoBlock withBabbageFindLeaderAndSubmitTx interpreter mockServer mkTxs = do withBabbageFindLeaderAndSubmit interpreter mockServer $ \st -> do @@ -119,7 +121,9 @@ withBabbageFindLeaderAndSubmitTx interpreter mockServer mkTxs = do withConwayFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - (LedgerState (ShelleyBlock PraosStandard ConwayEra) -> Either ForgingError (Core.Tx ConwayEra)) -> + ( LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK -> + Either ForgingError (Core.Tx ConwayEra) + ) -> IO CardanoBlock withConwayFindLeaderAndSubmitTx interpreter mockServer mkTx = withConwayFindLeaderAndSubmit interpreter mockServer $ \st -> do @@ -129,7 +133,7 @@ withConwayFindLeaderAndSubmitTx interpreter mockServer mkTx = withShelleyFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) -> + ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> Either ForgingError [Core.Tx ShelleyEra] ) -> IO CardanoBlock @@ -140,7 +144,7 @@ withShelleyFindLeaderAndSubmit interpreter mockServer mkTxs = do withShelleyFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) -> + ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> Either ForgingError (Core.Tx ShelleyEra) ) -> IO CardanoBlock @@ -149,16 +153,16 @@ withShelleyFindLeaderAndSubmitTx interpreter mockServer mkTxs = tx <- mkTxs st pure [tx] -getShelleyLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard ShelleyEra)) +getShelleyLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK) getShelleyLedgerState interpreter = withShelleyLedgerState interpreter Right -getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard AlonzoEra)) +getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK) getAlonzoLedgerState interpreter = withAlonzoLedgerState interpreter Right -getBabbageLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard BabbageEra)) +getBabbageLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK) getBabbageLedgerState interpreter = withBabbageLedgerState interpreter Right -getConwayLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard ConwayEra)) +getConwayLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK) getConwayLedgerState interpreter = withConwayLedgerState interpreter Right skipUntilNextEpoch :: Interpreter -> ServerHandle IO CardanoBlock -> [TxEra] -> IO CardanoBlock diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs index 8c96d6297..29b597866 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Validate.hs @@ -211,7 +211,7 @@ assertAddrValues :: DBSyncEnv -> UTxOIndex era -> DbLovelace -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> IO () assertAddrValues env ix expected sta = do addr <- assertRight $ resolveAddress ix sta @@ -248,7 +248,7 @@ assertCertCounts env expected = assertRewardCounts :: EraCertState era => DBSyncEnv -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> Bool -> Maybe Word64 -> [(StakeIndex, (Word64, Word64, Word64, Word64, Word64))] -> @@ -502,7 +502,7 @@ assertPoolLayerCounters :: DBSyncEnv -> (Word64, Word64) -> [(PoolIndex, (Either DBFail Bool, Bool, Bool))] -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> IO () assertPoolLayerCounters env (expectedRetired, expectedDelisted) expResults st = do poolLayer <- getPoolLayer env diff --git a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs index 3862d3bcc..1b3006ffe 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api/Ledger.hs @@ -81,7 +81,7 @@ migrateBootstrapUTxO syncEnv = do storeUTxOFromLedger :: (MonadBaseControl IO m, MonadIO m) => SyncEnv -> - ExtLedgerState CardanoBlock -> + ExtLedgerState CardanoBlock mk -> ExceptT SyncNodeError (ReaderT SqlBackend m) () storeUTxOFromLedger env st = case ledgerState st of LedgerStateBabbage bts -> storeUTxO env (getUTxO bts) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs index fea5ab42c..1a42a560c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs @@ -40,7 +40,7 @@ data EpochUpdate = EpochUpdate , euNonce :: !Ledger.Nonce } -epochUpdate :: ExtLedgerState CardanoBlock -> EpochUpdate +epochUpdate :: ExtLedgerState CardanoBlock mk -> EpochUpdate epochUpdate lstate = EpochUpdate { euProtoParams = maybeToStrict $ epochProtoParams lstate @@ -49,7 +49,7 @@ epochUpdate lstate = -- ------------------------------------------------------------------------------------------------- -extractEpochNonce :: ExtLedgerState CardanoBlock -> Ledger.Nonce +extractEpochNonce :: ExtLedgerState CardanoBlock mk -> Ledger.Nonce extractEpochNonce extLedgerState = case Consensus.headerStateChainDep (headerState extLedgerState) of ChainDepStateByron _ -> Ledger.NeutralNonce diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs index f4eddbd1b..d015b9177 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/ProtoParams.hs @@ -74,7 +74,7 @@ data Deposits = Deposits , poolDeposit :: Coin } -epochProtoParams :: ExtLedgerState CardanoBlock -> Maybe ProtoParams +epochProtoParams :: ExtLedgerState CardanoBlock mk -> Maybe ProtoParams epochProtoParams lstate = case ledgerState lstate of LedgerStateByron _ -> Nothing @@ -87,11 +87,11 @@ epochProtoParams lstate = getProtoParams :: EraGov era => - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> PParams era getProtoParams st = Shelley.nesEs (Consensus.shelleyLedgerState st) ^. Shelley.curPParamsEpochStateL -getDeposits :: ExtLedgerState CardanoBlock -> Maybe Deposits +getDeposits :: ExtLedgerState CardanoBlock mk -> Maybe Deposits getDeposits lstate = case ledgerState lstate of LedgerStateByron _ -> Nothing diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index 98540838e..19a4a12a8 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs @@ -72,7 +72,7 @@ getStakeSlice :: ConsensusProtocol (BlockProtocol blk) => ProtocolInfo blk -> Word64 -> - ExtLedgerState CardanoBlock -> + ExtLedgerState CardanoBlock mk -> Bool -> StakeSliceRes getStakeSlice pInfo !epochBlockNo els isMigration = @@ -86,11 +86,11 @@ getStakeSlice pInfo !epochBlockNo els isMigration = LedgerStateConway cls -> genericStakeSlice pInfo epochBlockNo cls isMigration genericStakeSlice :: - forall era blk p. + forall era blk mk p. ConsensusProtocol (BlockProtocol blk) => ProtocolInfo blk -> Word64 -> - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> Bool -> StakeSliceRes genericStakeSlice pInfo epochBlockNo lstate isMigration @@ -175,7 +175,7 @@ genericStakeSlice pInfo epochBlockNo lstate isMigration VMap.mapWithKey (\a p -> (,p) <$> lookupStake a) delegationsSliced getPoolDistr :: - ExtLedgerState CardanoBlock -> + ExtLedgerState CardanoBlock mk -> Maybe (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural) getPoolDistr els = case ledgerState els of @@ -188,8 +188,8 @@ getPoolDistr els = LedgerStateConway cls -> Just $ genericPoolDistr cls genericPoolDistr :: - forall era p. - LedgerState (ShelleyBlock p era) -> + forall era mk p. + LedgerState (ShelleyBlock p era) mk -> (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural) genericPoolDistr lstate = (stakePerPool, blocksPerPool) diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index a71ccd0ff..94205e929 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -118,7 +118,7 @@ import Ouroboros.Consensus.Ledger.Abstract ( ledgerTipSlot, tickThenReapplyLedgerResult, ) -import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..)) +import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), ValuesMK, DiffMK) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerCfg (..), ExtLedgerState (..)) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus @@ -133,6 +133,7 @@ import System.Directory (doesFileExist, listDirectory, removeFile) import System.FilePath (dropExtension, takeExtension, ()) import System.Mem (performMajorGC) import Prelude (String, id) +import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) -- Note: The decision on whether a ledger-state is written to disk is based on the block number -- rather than the slot number because while the block number is fully populated (for every block @@ -144,7 +145,7 @@ import Prelude (String, id) {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Use readTVarIO" -} -pushLedgerDB :: LedgerDB -> CardanoLedgerState -> LedgerDB +pushLedgerDB :: LedgerDB -> CardanoLedgerState -> LedgerDB pushLedgerDB db st = pruneLedgerDb 10 @@ -160,7 +161,7 @@ pruneLedgerDb k db = {-# INLINE pruneLedgerDb #-} -- | The ledger state at the tip of the chain -ledgerDbCurrent :: LedgerDB -> CardanoLedgerState +ledgerDbCurrent :: LedgerDB -> CardanoLedgerState ledgerDbCurrent = either id id . AS.head . ledgerDbCheckpoints mkHasLedgerEnv :: @@ -195,14 +196,14 @@ mkHasLedgerEnv trce protoInfo dir nw systemStart syncOptions = do initCardanoLedgerState :: Consensus.ProtocolInfo CardanoBlock -> CardanoLedgerState initCardanoLedgerState pInfo = CardanoLedgerState - { clsState = Consensus.pInfoInitLedger pInfo + { clsState = coerceLedgerTables (Consensus.pInfoInitLedger pInfo) , clsEpochBlockNo = GenesisEpochBlockNo } getTopLevelconfigHasLedger :: HasLedgerEnv -> TopLevelConfig CardanoBlock getTopLevelconfigHasLedger = Consensus.pInfoConfig . leProtocolInfo -readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock) +readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock CardanoLedgerMk) readCurrentStateUnsafe hle = atomically (clsState . ledgerDbCurrent <$> readStateUnsafe hle) -- TODO make this type safe. We make the assumption here that the first message of @@ -229,14 +230,37 @@ applyBlock env blk = do atomically $ do !ledgerDB <- readStateUnsafe env let oldState = ledgerDbCurrent ledgerDB - !result <- fromEitherSTM $ tickThenReapplyCheckHash (ExtLedgerCfg (getTopLevelconfigHasLedger env)) blk (clsState oldState) + + -- TODO[sgillespie] + let + oldState' :: ExtLedgerState CardanoBlock ValuesMK + oldState' = coerceLedgerTables (clsState oldState) + + !result <- + fromEitherSTM $ + tickThenReapplyCheckHash + (ExtLedgerCfg (getTopLevelconfigHasLedger env)) + blk + oldState' + 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 + newLedgerState' :: ExtLedgerState CardanoBlock CardanoLedgerMk + newLedgerState' = coerceLedgerTables $ applyDiffs oldState' newLedgerState + + !newEpoch <- + fromEitherSTM $ + mkOnNewEpoch + (clsState oldState) + newLedgerState' + (findAdaPots ledgerEvents) + let !newEpochBlockNo = applyToEpochBlockNo (isJust $ blockIsEBB blk) (isJust newEpoch) (clsEpochBlockNo oldState) - let !newState = CardanoLedgerState newLedgerState newEpochBlockNo + let !newState = CardanoLedgerState newLedgerState' newEpochBlockNo let !ledgerDB' = pushLedgerDB ledgerDB newState writeTVar (leStateVar env) (Strict.Just ledgerDB') let !appResult = @@ -258,7 +282,11 @@ applyBlock env blk = do else defaultApplyResult details pure (oldState, appResult) where - mkOnNewEpoch :: ExtLedgerState CardanoBlock -> ExtLedgerState CardanoBlock -> Maybe AdaPots -> Either SyncNodeError (Maybe Generic.NewEpoch) + mkOnNewEpoch :: + ExtLedgerState CardanoBlock mk -> + ExtLedgerState CardanoBlock mk -> + Maybe AdaPots -> + Either SyncNodeError (Maybe Generic.NewEpoch) mkOnNewEpoch oldState newState mPots = do -- pass on error when trying to get ledgerEpochNo case (prevEpochE, currEpochE) of @@ -292,14 +320,14 @@ applyBlock env blk = do applyToEpochBlockNo _ _ GenesisEpochBlockNo = EpochBlockNo 0 applyToEpochBlockNo _ _ EBBEpochBlockNo = EpochBlockNo 0 - getDrepState :: ExtLedgerState CardanoBlock -> Maybe (DRepPulsingState ConwayEra) + getDrepState :: ExtLedgerState CardanoBlock mk -> Maybe (DRepPulsingState ConwayEra) getDrepState ls = ls ^? newEpochStateT . Shelley.newEpochStateDRepPulsingStateL - finaliseDrepDistr :: ExtLedgerState CardanoBlock -> ExtLedgerState CardanoBlock + finaliseDrepDistr :: ExtLedgerState CardanoBlock mk -> ExtLedgerState CardanoBlock mk finaliseDrepDistr ledger = ledger & newEpochStateT %~ forceDRepPulsingState @ConwayEra -getGovState :: ExtLedgerState CardanoBlock -> Maybe (ConwayGovState ConwayEra) +getGovState :: ExtLedgerState CardanoBlock mk -> Maybe (ConwayGovState ConwayEra) getGovState ls = case ledgerState ls of LedgerStateConway cls -> Just $ Consensus.shelleyLedgerState cls ^. Shelley.newEpochStateGovStateL @@ -392,6 +420,7 @@ ledgerStateWriteLoop tracer swQueue codecConfig = (encodeDisk codecConfig) (encodeDisk codecConfig) (encodeDisk codecConfig) + . stowCardanoLedger ) ledger endTime <- getCurrentTime @@ -404,7 +433,7 @@ ledgerStateWriteLoop tracer swQueue codecConfig = , "." ] -mkLedgerStateFilename :: LedgerStateDir -> ExtLedgerState CardanoBlock -> Maybe EpochNo -> WithOrigin FilePath +mkLedgerStateFilename :: LedgerStateDir -> ExtLedgerState CardanoBlock mk -> Maybe EpochNo -> WithOrigin FilePath mkLedgerStateFilename dir ledger mEpochNo = lsfFilePath . dbPointToFileName dir mEpochNo <$> getPoint (ledgerTipPoint @CardanoBlock (ledgerState ledger)) @@ -526,7 +555,11 @@ loadLedgerAtPoint hasLedgerEnv point = do where rollbackLedger :: Strict.Maybe LedgerDB -> - Maybe (AnchoredSeq (WithOrigin SlotNo) CardanoLedgerState CardanoLedgerState) + Maybe + (AnchoredSeq + (WithOrigin SlotNo) + CardanoLedgerState + CardanoLedgerState) rollbackLedger mLedgerDB = case mLedgerDB of Strict.Nothing -> Nothing Strict.Just ledgerDB -> @@ -636,7 +669,13 @@ comparePointToFile lsf (blSlotNo, blHash) = else GT x -> x -loadLedgerStateFromFile :: Trace IO Text -> TopLevelConfig CardanoBlock -> Bool -> CardanoPoint -> LedgerStateFile -> IO (Either Text CardanoLedgerState) +loadLedgerStateFromFile :: + Trace IO Text -> + TopLevelConfig CardanoBlock -> + Bool -> + CardanoPoint -> + LedgerStateFile -> + IO (Either Text CardanoLedgerState) loadLedgerStateFromFile tracer config delete point lsf = do mst <- safeReadFile (lsfFilePath lsf) case mst of @@ -677,13 +716,14 @@ loadLedgerStateFromFile tracer config delete point lsf = do decodeState . LBS.fromStrict - decodeState :: (forall s. Decoder s CardanoLedgerState) - decodeState = + decodeState :: forall s . Decoder s CardanoLedgerState + decodeState = decodeCardanoLedgerState $ - Consensus.decodeExtLedgerState - (decodeDisk codecConfig) - (decodeDisk codecConfig) - (decodeDisk codecConfig) + unstowCardanoLedger <$> + Consensus.decodeExtLedgerState + (decodeDisk codecConfig) + (decodeDisk codecConfig) + (decodeDisk codecConfig) getSlotNoSnapshot :: SnapshotPoint -> WithOrigin SlotNo getSlotNoSnapshot (OnDisk lsf) = at $ lsfSlotNo lsf @@ -745,9 +785,9 @@ getRegisteredPools st = LedgerStateConway stc -> getRegisteredPoolShelley stc getRegisteredPoolShelley :: - forall p era. + forall p era mk. Shelley.EraCertState era => - LedgerState (ShelleyBlock p era) -> + LedgerState (ShelleyBlock p era) mk -> Set.Set PoolKeyHash getRegisteredPoolShelley lState = Map.keysSet $ @@ -758,7 +798,7 @@ getRegisteredPoolShelley lState = Consensus.shelleyLedgerState lState in Shelley.psStakePoolParams $ certState ^. Shelley.certPStateL -ledgerEpochNo :: HasLedgerEnv -> ExtLedgerState CardanoBlock -> Either SyncNodeError (Maybe EpochNo) +ledgerEpochNo :: HasLedgerEnv -> ExtLedgerState CardanoBlock mk -> Either SyncNodeError (Maybe EpochNo) ledgerEpochNo env cls = case ledgerTipSlot (ledgerState cls) of Origin -> Right Nothing @@ -775,8 +815,8 @@ ledgerEpochNo env cls = tickThenReapplyCheckHash :: ExtLedgerCfg CardanoBlock -> CardanoBlock -> - ExtLedgerState CardanoBlock -> - Either SyncNodeError (LedgerResult (ExtLedgerState CardanoBlock) (ExtLedgerState CardanoBlock)) + ExtLedgerState CardanoBlock ValuesMK -> + Either SyncNodeError (LedgerResult (ExtLedgerState CardanoBlock) (ExtLedgerState CardanoBlock DiffMK)) tickThenReapplyCheckHash cfg block lsb = if blockPrevHash block == ledgerTipHash (ledgerState lsb) then Right $ tickThenReapplyLedgerResult ComputeLedgerEvents cfg block lsb @@ -798,7 +838,7 @@ tickThenReapplyCheckHash cfg block lsb = getHeaderHash :: HeaderHash CardanoBlock -> ByteString getHeaderHash bh = SBS.fromShort (Consensus.getOneEraHash bh) -getSlotDetails :: HasLedgerEnv -> LedgerState CardanoBlock -> UTCTime -> SlotNo -> STM SlotDetails +getSlotDetails :: HasLedgerEnv -> LedgerState CardanoBlock mk -> UTCTime -> SlotNo -> STM SlotDetails getSlotDetails env st time slot = do minter <- readTVar $ leInterpreter env details <- case minter of diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs index b0a98d5b0..0244e9edd 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -39,7 +42,9 @@ import Control.Concurrent.Class.MonadSTM.Strict ( StrictTVar, ) import Control.Concurrent.STM.TBQueue (TBQueue) +import Data.Coerce (Coercible, coerce) import qualified Data.Map.Strict as Map +import Data.SOP.Functors (Flip (..)) import Data.SOP.Strict import qualified Data.Set as Set import qualified Data.Strict.Maybe as Strict @@ -49,6 +54,16 @@ import Ouroboros.Consensus.Cardano.Block hiding (CardanoBlock, CardanoLedgerStat import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState (..)) import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) +import Ouroboros.Consensus.Ledger.Tables ( + CanMapKeysMK, + CanMapMK, + EmptyMK, + EqMK, + HasLedgerTables, + ValuesMK, + ZeroableMK, + ) +import qualified Ouroboros.Consensus.Ledger.Tables as Tables import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Shelley.Ledger (LedgerState (..), ShelleyBlock) import Ouroboros.Network.AnchoredSeq (Anchorable (..), AnchoredSeq (..)) @@ -75,10 +90,35 @@ data HasLedgerEnv = HasLedgerEnv } data CardanoLedgerState = CardanoLedgerState - { clsState :: !(ExtLedgerState CardanoBlock) + { clsState :: !(ExtLedgerState CardanoBlock CardanoLedgerMk) , clsEpochBlockNo :: !EpochBlockNo } +newtype CardanoLedgerMk k v = CardanoLedgerMk {unMk :: ValuesMK k v} + deriving stock (Eq, Show, Generic) + deriving newtype (CanMapKeysMK, CanMapMK, EqMK, ZeroableMK) + +stowCardanoLedger :: ExtLedgerState CardanoBlock CardanoLedgerMk -> ExtLedgerState CardanoBlock EmptyMK +stowCardanoLedger = Tables.stowLedgerTables . coerceLedgerTables + +unstowCardanoLedger :: ExtLedgerState CardanoBlock EmptyMK -> ExtLedgerState CardanoBlock CardanoLedgerMk +unstowCardanoLedger = coerceLedgerTables . Tables.unstowLedgerTables + +coerceLedgerTables :: + ( Coercible mk mk' + , CanMapMK mk + , CanMapMK mk' + , CanMapKeysMK mk + , CanMapKeysMK mk' + , ZeroableMK mk' + , ZeroableMK mk + , HasLedgerTables ledger + ) => + ledger mk -> + ledger mk' +coerceLedgerTables ledgerState' = + Tables.withLedgerTables ledgerState' . coerce . Tables.projectLedgerTables $ ledgerState' + -- The height of the block in the current Epoch. We maintain this -- data next to the ledger state and store it in the same blob file. data EpochBlockNo @@ -101,7 +141,10 @@ instance FromCBOR EpochBlockNo where 2 -> EpochBlockNo <$> fromCBOR n -> fail $ "unexpected EpochBlockNo value " <> show n -encodeCardanoLedgerState :: (ExtLedgerState CardanoBlock -> Encoding) -> CardanoLedgerState -> Encoding +encodeCardanoLedgerState :: + (ExtLedgerState CardanoBlock CardanoLedgerMk -> Encoding) -> + CardanoLedgerState -> + Encoding encodeCardanoLedgerState encodeExt cls = mconcat [ encodeExt (clsState cls) @@ -109,7 +152,7 @@ encodeCardanoLedgerState encodeExt cls = ] decodeCardanoLedgerState :: - (forall s. Decoder s (ExtLedgerState CardanoBlock)) -> + (forall s. Decoder s (ExtLedgerState CardanoBlock CardanoLedgerMk)) -> (forall s. Decoder s CardanoLedgerState) decodeCardanoLedgerState decodeExt = do ldgrState <- decodeExt @@ -187,7 +230,11 @@ updatedCommittee membersToRemove membersToAdd newQuorum committee = newQuorum newtype LedgerDB = LedgerDB - { ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) CardanoLedgerState CardanoLedgerState + { ledgerDbCheckpoints :: + AnchoredSeq + (WithOrigin SlotNo) + CardanoLedgerState + CardanoLedgerState } instance Anchorable (WithOrigin SlotNo) CardanoLedgerState CardanoLedgerState where @@ -201,12 +248,12 @@ data SnapshotPoint = OnDisk LedgerStateFile | InMemory CardanoPoint -- designed to be updated this way. We are only replaying the chain, so this should be -- safe. class HasNewEpochState era where - getNewEpochState :: ExtLedgerState CardanoBlock -> Maybe (NewEpochState era) + getNewEpochState :: ExtLedgerState CardanoBlock mk -> Maybe (NewEpochState era) applyNewEpochState :: NewEpochState era -> - ExtLedgerState CardanoBlock -> - ExtLedgerState CardanoBlock + ExtLedgerState CardanoBlock mk -> + ExtLedgerState CardanoBlock mk instance HasNewEpochState ShelleyEra where getNewEpochState st = case ledgerState st of @@ -214,8 +261,14 @@ instance HasNewEpochState ShelleyEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState AllegraEra where getNewEpochState st = case ledgerState st of @@ -223,8 +276,14 @@ instance HasNewEpochState AllegraEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState MaryEra where getNewEpochState st = case ledgerState st of @@ -232,8 +291,14 @@ instance HasNewEpochState MaryEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState AlonzoEra where getNewEpochState st = case ledgerState st of @@ -241,8 +306,14 @@ instance HasNewEpochState AlonzoEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* Nil instance HasNewEpochState BabbageEra where getNewEpochState st = case ledgerState st of @@ -250,8 +321,14 @@ instance HasNewEpochState BabbageEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* Nil instance HasNewEpochState ConwayEra where getNewEpochState st = case ledgerState st of @@ -259,13 +336,19 @@ instance HasNewEpochState ConwayEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* Nil hApplyExtLedgerState :: - NP (LedgerState -.-> LedgerState) (CardanoShelleyEras StandardCrypto) -> - ExtLedgerState CardanoBlock -> - ExtLedgerState CardanoBlock + NP (Flip LedgerState mk -.-> Flip LedgerState mk) (CardanoShelleyEras StandardCrypto) -> + ExtLedgerState CardanoBlock mk -> + ExtLedgerState CardanoBlock mk hApplyExtLedgerState f ledger = case ledgerState ledger of HardForkLedgerState hfState -> @@ -276,15 +359,17 @@ hApplyExtLedgerState f ledger = applyNewEpochState' :: NewEpochState era -> - LedgerState (ShelleyBlock proto era) -> - LedgerState (ShelleyBlock proto era) + Flip LedgerState mk (ShelleyBlock proto era) -> + Flip LedgerState mk (ShelleyBlock proto era) applyNewEpochState' newEpochState' ledger = - ledger {shelleyLedgerState = newEpochState'} + Flip $ updateNewEpochState (unFlip ledger) + where + updateNewEpochState l = l {shelleyLedgerState = newEpochState'} -- | A @Traversal@ that targets the @NewEpochState@ from the extended ledger state newEpochStateT :: HasNewEpochState era => - Traversal' (ExtLedgerState CardanoBlock) (NewEpochState era) + Traversal' (ExtLedgerState CardanoBlock mk) (NewEpochState era) newEpochStateT f ledger = case getNewEpochState ledger of Just newEpochState' -> flip applyNewEpochState ledger <$> f newEpochState' diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs index 1b8f7a2a4..db303c2ec 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs @@ -67,7 +67,10 @@ vBErr :: String vBErr = "Validation Balance Error - " -- Given an address, return it's current UTxO balance. -ledgerAddrBalance :: Text -> LedgerState (CardanoBlock StandardCrypto) -> Either ValidateBalanceError Word64 +ledgerAddrBalance :: + Text -> + LedgerState (CardanoBlock StandardCrypto) mk -> + Either ValidateBalanceError Word64 ledgerAddrBalance addr lsc = case lsc of LedgerStateByron st -> getByronBalance addr $ Byron.cvsUtxo $ byronLedgerState st @@ -78,7 +81,7 @@ ledgerAddrBalance addr lsc = LedgerStateBabbage _st -> Left $ VBErrBabbage "undefined Babbage ledgerAddrBalance" LedgerStateConway _st -> Left $ VBErrConway "undefined Conway ledgerAddrBalance" where - getUTxO :: LedgerState (ShelleyBlock p era) -> Shelley.UTxO era + getUTxO :: LedgerState (ShelleyBlock p era) mk -> Shelley.UTxO era getUTxO = Shelley.utxosUtxo . Shelley.lsUTxOState . Shelley.esLState . Shelley.nesEs . shelleyLedgerState getByronBalance :: Text -> Byron.UTxO -> Either ValidateBalanceError Word64 From 41ad2142628f44457f760b163372d67f05098410 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Wed, 20 Aug 2025 14:00:40 -0400 Subject: [PATCH 2/6] test: Simplify UTxO-HD implementation for performance testing --- cardano-db-sync/cardano-db-sync.cabal | 1 + .../DbSync/Era/Shelley/Generic/StakeDist.hs | 4 +- .../src/Cardano/DbSync/Ledger/State.hs | 89 +++++-------- .../src/Cardano/DbSync/Ledger/Types.hs | 117 +++--------------- 4 files changed, 53 insertions(+), 158 deletions(-) diff --git a/cardano-db-sync/cardano-db-sync.cabal b/cardano-db-sync/cardano-db-sync.cabal index bc0f10808..d1542f59b 100644 --- a/cardano-db-sync/cardano-db-sync.cabal +++ b/cardano-db-sync/cardano-db-sync.cabal @@ -216,6 +216,7 @@ library , stm , strict , sop-core + , sop-extras , strict-sop-core , strict-stm , swagger2 diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index 19a4a12a8..3040396be 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs @@ -86,7 +86,7 @@ getStakeSlice pInfo !epochBlockNo els isMigration = LedgerStateConway cls -> genericStakeSlice pInfo epochBlockNo cls isMigration genericStakeSlice :: - forall era blk mk p. + forall era blk p mk. ConsensusProtocol (BlockProtocol blk) => ProtocolInfo blk -> Word64 -> @@ -188,7 +188,7 @@ getPoolDistr els = LedgerStateConway cls -> Just $ genericPoolDistr cls genericPoolDistr :: - forall era mk p. + forall era p mk. LedgerState (ShelleyBlock p era) mk -> (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural) genericPoolDistr lstate = diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index 94205e929..a1bffe036 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -118,7 +118,7 @@ import Ouroboros.Consensus.Ledger.Abstract ( ledgerTipSlot, tickThenReapplyLedgerResult, ) -import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), ValuesMK, DiffMK) +import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), CanStowLedgerTables (..), DiffMK) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerCfg (..), ExtLedgerState (..)) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus @@ -133,7 +133,8 @@ import System.Directory (doesFileExist, listDirectory, removeFile) import System.FilePath (dropExtension, takeExtension, ()) import System.Mem (performMajorGC) import Prelude (String, id) -import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) +import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs, forgetLedgerTables) -- Note: The decision on whether a ledger-state is written to disk is based on the block number -- rather than the slot number because while the block number is fully populated (for every block @@ -145,7 +146,7 @@ import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Use readTVarIO" -} -pushLedgerDB :: LedgerDB -> CardanoLedgerState -> LedgerDB +pushLedgerDB :: LedgerDB -> CardanoLedgerState -> LedgerDB pushLedgerDB db st = pruneLedgerDb 10 @@ -161,7 +162,7 @@ pruneLedgerDb k db = {-# INLINE pruneLedgerDb #-} -- | The ledger state at the tip of the chain -ledgerDbCurrent :: LedgerDB -> CardanoLedgerState +ledgerDbCurrent :: LedgerDB -> CardanoLedgerState ledgerDbCurrent = either id id . AS.head . ledgerDbCheckpoints mkHasLedgerEnv :: @@ -196,14 +197,14 @@ mkHasLedgerEnv trce protoInfo dir nw systemStart syncOptions = do initCardanoLedgerState :: Consensus.ProtocolInfo CardanoBlock -> CardanoLedgerState initCardanoLedgerState pInfo = CardanoLedgerState - { clsState = coerceLedgerTables (Consensus.pInfoInitLedger pInfo) + { clsState = Consensus.pInfoInitLedger pInfo , clsEpochBlockNo = GenesisEpochBlockNo } getTopLevelconfigHasLedger :: HasLedgerEnv -> TopLevelConfig CardanoBlock getTopLevelconfigHasLedger = Consensus.pInfoConfig . leProtocolInfo -readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock CardanoLedgerMk) +readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock ValuesMK) readCurrentStateUnsafe hle = atomically (clsState . ledgerDbCurrent <$> readStateUnsafe hle) -- TODO make this type safe. We make the assumption here that the first message of @@ -230,35 +231,18 @@ applyBlock env blk = do atomically $ do !ledgerDB <- readStateUnsafe env let oldState = ledgerDbCurrent ledgerDB - - -- TODO[sgillespie] - let - oldState' :: ExtLedgerState CardanoBlock ValuesMK - oldState' = coerceLedgerTables (clsState oldState) - - !result <- - fromEitherSTM $ - tickThenReapplyCheckHash - (ExtLedgerCfg (getTopLevelconfigHasLedger env)) - blk - oldState' - + -- Calculate ledger diffs + !result <- fromEitherSTM $ tickThenReapplyCheckHash (ExtLedgerCfg (getTopLevelconfigHasLedger env)) blk (clsState oldState) + -- Extract the ledger events let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (lrEvents result) + -- Find the deposits let (ledgerEvents, deposits) = splitDeposits ledgerEventsFull + -- Calculate DRep distribution let !newLedgerState = finaliseDrepDistr (lrResult result) + -- Apply the ledger diffs + let !newLedgerState' = applyDiffs (clsState oldState) newLedgerState !details <- getSlotDetails env (ledgerState newLedgerState) time (cardanoBlockSlotNo blk) - - let - newLedgerState' :: ExtLedgerState CardanoBlock CardanoLedgerMk - newLedgerState' = coerceLedgerTables $ applyDiffs oldState' newLedgerState - - !newEpoch <- - fromEitherSTM $ - mkOnNewEpoch - (clsState oldState) - newLedgerState' - (findAdaPots ledgerEvents) - + !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 @@ -282,11 +266,7 @@ applyBlock env blk = do else defaultApplyResult details pure (oldState, appResult) where - mkOnNewEpoch :: - ExtLedgerState CardanoBlock mk -> - ExtLedgerState CardanoBlock mk -> - Maybe AdaPots -> - Either SyncNodeError (Maybe Generic.NewEpoch) + mkOnNewEpoch :: ExtLedgerState CardanoBlock mk -> ExtLedgerState CardanoBlock mk -> Maybe AdaPots -> Either SyncNodeError (Maybe Generic.NewEpoch) mkOnNewEpoch oldState newState mPots = do -- pass on error when trying to get ledgerEpochNo case (prevEpochE, currEpochE) of @@ -420,7 +400,7 @@ ledgerStateWriteLoop tracer swQueue codecConfig = (encodeDisk codecConfig) (encodeDisk codecConfig) (encodeDisk codecConfig) - . stowCardanoLedger + . forgetLedgerTables ) ledger endTime <- getCurrentTime @@ -555,11 +535,7 @@ loadLedgerAtPoint hasLedgerEnv point = do where rollbackLedger :: Strict.Maybe LedgerDB -> - Maybe - (AnchoredSeq - (WithOrigin SlotNo) - CardanoLedgerState - CardanoLedgerState) + Maybe (AnchoredSeq (WithOrigin SlotNo) CardanoLedgerState CardanoLedgerState) rollbackLedger mLedgerDB = case mLedgerDB of Strict.Nothing -> Nothing Strict.Just ledgerDB -> @@ -669,13 +645,7 @@ comparePointToFile lsf (blSlotNo, blHash) = else GT x -> x -loadLedgerStateFromFile :: - Trace IO Text -> - TopLevelConfig CardanoBlock -> - Bool -> - CardanoPoint -> - LedgerStateFile -> - IO (Either Text CardanoLedgerState) +loadLedgerStateFromFile :: Trace IO Text -> TopLevelConfig CardanoBlock -> Bool -> CardanoPoint -> LedgerStateFile -> IO (Either Text CardanoLedgerState) loadLedgerStateFromFile tracer config delete point lsf = do mst <- safeReadFile (lsfFilePath lsf) case mst of @@ -716,14 +686,14 @@ loadLedgerStateFromFile tracer config delete point lsf = do decodeState . LBS.fromStrict - decodeState :: forall s . Decoder s CardanoLedgerState - decodeState = + decodeState :: (forall s. Decoder s CardanoLedgerState) + decodeState = decodeCardanoLedgerState $ - unstowCardanoLedger <$> - Consensus.decodeExtLedgerState - (decodeDisk codecConfig) - (decodeDisk codecConfig) - (decodeDisk codecConfig) + unstowLedgerTables <$> + Consensus.decodeExtLedgerState + (decodeDisk codecConfig) + (decodeDisk codecConfig) + (decodeDisk codecConfig) getSlotNoSnapshot :: SnapshotPoint -> WithOrigin SlotNo getSlotNoSnapshot (OnDisk lsf) = at $ lsfSlotNo lsf @@ -816,7 +786,12 @@ tickThenReapplyCheckHash :: ExtLedgerCfg CardanoBlock -> CardanoBlock -> ExtLedgerState CardanoBlock ValuesMK -> - Either SyncNodeError (LedgerResult (ExtLedgerState CardanoBlock) (ExtLedgerState CardanoBlock DiffMK)) + Either + SyncNodeError + ( LedgerResult + (ExtLedgerState CardanoBlock) + (ExtLedgerState CardanoBlock DiffMK) + ) tickThenReapplyCheckHash cfg block lsb = if blockPrevHash block == ledgerTipHash (ledgerState lsb) then Right $ tickThenReapplyLedgerResult ComputeLedgerEvents cfg block lsb diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs index 0244e9edd..fa09aeb5d 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs @@ -1,8 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -42,9 +39,7 @@ import Control.Concurrent.Class.MonadSTM.Strict ( StrictTVar, ) import Control.Concurrent.STM.TBQueue (TBQueue) -import Data.Coerce (Coercible, coerce) import qualified Data.Map.Strict as Map -import Data.SOP.Functors (Flip (..)) import Data.SOP.Strict import qualified Data.Set as Set import qualified Data.Strict.Maybe as Strict @@ -54,20 +49,12 @@ import Ouroboros.Consensus.Cardano.Block hiding (CardanoBlock, CardanoLedgerStat import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState (..)) import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) -import Ouroboros.Consensus.Ledger.Tables ( - CanMapKeysMK, - CanMapMK, - EmptyMK, - EqMK, - HasLedgerTables, - ValuesMK, - ZeroableMK, - ) -import qualified Ouroboros.Consensus.Ledger.Tables as Tables import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Shelley.Ledger (LedgerState (..), ShelleyBlock) import Ouroboros.Network.AnchoredSeq (Anchorable (..), AnchoredSeq (..)) import Prelude (fail, id) +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) +import Data.SOP.Functors (Flip (..)) -------------------------------------------------------------------------- -- Ledger Types @@ -90,35 +77,10 @@ data HasLedgerEnv = HasLedgerEnv } data CardanoLedgerState = CardanoLedgerState - { clsState :: !(ExtLedgerState CardanoBlock CardanoLedgerMk) + { clsState :: !(ExtLedgerState CardanoBlock ValuesMK) , clsEpochBlockNo :: !EpochBlockNo } -newtype CardanoLedgerMk k v = CardanoLedgerMk {unMk :: ValuesMK k v} - deriving stock (Eq, Show, Generic) - deriving newtype (CanMapKeysMK, CanMapMK, EqMK, ZeroableMK) - -stowCardanoLedger :: ExtLedgerState CardanoBlock CardanoLedgerMk -> ExtLedgerState CardanoBlock EmptyMK -stowCardanoLedger = Tables.stowLedgerTables . coerceLedgerTables - -unstowCardanoLedger :: ExtLedgerState CardanoBlock EmptyMK -> ExtLedgerState CardanoBlock CardanoLedgerMk -unstowCardanoLedger = coerceLedgerTables . Tables.unstowLedgerTables - -coerceLedgerTables :: - ( Coercible mk mk' - , CanMapMK mk - , CanMapMK mk' - , CanMapKeysMK mk - , CanMapKeysMK mk' - , ZeroableMK mk' - , ZeroableMK mk - , HasLedgerTables ledger - ) => - ledger mk -> - ledger mk' -coerceLedgerTables ledgerState' = - Tables.withLedgerTables ledgerState' . coerce . Tables.projectLedgerTables $ ledgerState' - -- The height of the block in the current Epoch. We maintain this -- data next to the ledger state and store it in the same blob file. data EpochBlockNo @@ -141,10 +103,7 @@ instance FromCBOR EpochBlockNo where 2 -> EpochBlockNo <$> fromCBOR n -> fail $ "unexpected EpochBlockNo value " <> show n -encodeCardanoLedgerState :: - (ExtLedgerState CardanoBlock CardanoLedgerMk -> Encoding) -> - CardanoLedgerState -> - Encoding +encodeCardanoLedgerState :: (ExtLedgerState CardanoBlock ValuesMK -> Encoding) -> CardanoLedgerState -> Encoding encodeCardanoLedgerState encodeExt cls = mconcat [ encodeExt (clsState cls) @@ -152,7 +111,7 @@ encodeCardanoLedgerState encodeExt cls = ] decodeCardanoLedgerState :: - (forall s. Decoder s (ExtLedgerState CardanoBlock CardanoLedgerMk)) -> + (forall s. Decoder s (ExtLedgerState CardanoBlock ValuesMK)) -> (forall s. Decoder s CardanoLedgerState) decodeCardanoLedgerState decodeExt = do ldgrState <- decodeExt @@ -230,11 +189,7 @@ updatedCommittee membersToRemove membersToAdd newQuorum committee = newQuorum newtype LedgerDB = LedgerDB - { ledgerDbCheckpoints :: - AnchoredSeq - (WithOrigin SlotNo) - CardanoLedgerState - CardanoLedgerState + { ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) CardanoLedgerState CardanoLedgerState } instance Anchorable (WithOrigin SlotNo) CardanoLedgerState CardanoLedgerState where @@ -261,14 +216,8 @@ instance HasNewEpochState ShelleyEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState - $ fn (applyNewEpochState' st) - :* fn id - :* fn id - :* fn id - :* fn id - :* fn id - :* Nil + hApplyExtLedgerState $ + fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* fn id :* Nil instance HasNewEpochState AllegraEra where getNewEpochState st = case ledgerState st of @@ -276,14 +225,8 @@ instance HasNewEpochState AllegraEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState - $ fn id - :* fn (applyNewEpochState' st) - :* fn id - :* fn id - :* fn id - :* fn id - :* Nil + hApplyExtLedgerState $ + fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* Nil instance HasNewEpochState MaryEra where getNewEpochState st = case ledgerState st of @@ -291,14 +234,8 @@ instance HasNewEpochState MaryEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState - $ fn id - :* fn id - :* fn (applyNewEpochState' st) - :* fn id - :* fn id - :* fn id - :* Nil + hApplyExtLedgerState $ + fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* Nil instance HasNewEpochState AlonzoEra where getNewEpochState st = case ledgerState st of @@ -306,14 +243,8 @@ instance HasNewEpochState AlonzoEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState - $ fn id - :* fn id - :* fn id - :* fn (applyNewEpochState' st) - :* fn id - :* fn id - :* Nil + hApplyExtLedgerState $ + fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* Nil instance HasNewEpochState BabbageEra where getNewEpochState st = case ledgerState st of @@ -321,14 +252,8 @@ instance HasNewEpochState BabbageEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState - $ fn id - :* fn id - :* fn id - :* fn id - :* fn (applyNewEpochState' st) - :* fn id - :* Nil + hApplyExtLedgerState $ + fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* Nil instance HasNewEpochState ConwayEra where getNewEpochState st = case ledgerState st of @@ -336,14 +261,8 @@ instance HasNewEpochState ConwayEra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState - $ fn id - :* fn id - :* fn id - :* fn id - :* fn id - :* fn (applyNewEpochState' st) - :* Nil + hApplyExtLedgerState $ + fn id :* fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* Nil hApplyExtLedgerState :: NP (Flip LedgerState mk -.-> Flip LedgerState mk) (CardanoShelleyEras StandardCrypto) -> From ee3c40473c0707c4f47c34011e372d7d1461bc13 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Wed, 20 Aug 2025 15:00:20 -0400 Subject: [PATCH 3/6] test: Disable writing ledger state files --- .../src/Cardano/DbSync/Ledger/State.hs | 76 +++++-------------- 1 file changed, 19 insertions(+), 57 deletions(-) diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index a1bffe036..909aab1d7 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -12,9 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif + + + module Cardano.DbSync.Ledger.State ( applyBlock, @@ -68,7 +68,7 @@ import Control.Concurrent.Class.MonadSTM.Strict ( readTVar, writeTVar, ) -import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue, writeTBQueue) +import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue) import qualified Control.Exception as Exception import qualified Data.ByteString.Base16 as Base16 @@ -114,11 +114,14 @@ import Ouroboros.Consensus.Ledger.Abstract ( LedgerResult (..), getTip, ledgerTipHash, - ledgerTipPoint, ledgerTipSlot, tickThenReapplyLedgerResult, ) -import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), CanStowLedgerTables (..), DiffMK) +import Ouroboros.Consensus.Ledger.Basics + ( ComputeLedgerEvents(..), + CanStowLedgerTables(..), + DiffMK, + ValuesMK ) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerCfg (..), ExtLedgerState (..)) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus @@ -129,11 +132,10 @@ import Ouroboros.Network.AnchoredSeq (AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Block (HeaderHash, Point (..), blockNo) import qualified Ouroboros.Network.Point as Point -import System.Directory (doesFileExist, listDirectory, removeFile) +import System.Directory (listDirectory, removeFile) import System.FilePath (dropExtension, takeExtension, ()) import System.Mem (performMajorGC) -import Prelude (String, id) -import Ouroboros.Consensus.Ledger.Basics (ValuesMK) +import Prelude (id) import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs, forgetLedgerTables) -- Note: The decision on whether a ledger-state is written to disk is based on the block number @@ -229,6 +231,7 @@ applyBlock :: HasLedgerEnv -> CardanoBlock -> IO (CardanoLedgerState, ApplyResul applyBlock env blk = do time <- getCurrentTime atomically $ do + -- Read the current ledger state !ledgerDB <- readStateUnsafe env let oldState = ledgerDbCurrent ledgerDB -- Calculate ledger diffs @@ -241,10 +244,12 @@ applyBlock env blk = do let !newLedgerState = finaliseDrepDistr (lrResult result) -- Apply the ledger diffs let !newLedgerState' = applyDiffs (clsState oldState) newLedgerState + -- Construct the new ledger state !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 + -- Add the new ledger state to the in-memory db let !ledgerDB' = pushLedgerDB ledgerDB newState writeTVar (leStateVar env) (Strict.Just ledgerDB') let !appResult = @@ -360,17 +365,7 @@ storeSnapshotAndCleanupMaybe env oldState appResult blkNo isCons syncState = (SyncLagging, _) -> False saveCurrentLedgerState :: HasLedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () -saveCurrentLedgerState env lState mEpochNo = do - case mkLedgerStateFilename (leDir env) (clsState lState) mEpochNo of - Origin -> pure () -- we don't store genesis - At file -> do - exists <- doesFileExist file - if exists - then - logInfo (leTrace env) $ - mconcat - ["File ", Text.pack file, " exists"] - else atomically $ writeTBQueue (leStateWriteQueue env) (file, lState) +saveCurrentLedgerState _ _ _ = pure () runLedgerStateWriteThread :: Trace IO Text -> LedgerEnv -> IO () runLedgerStateWriteThread tracer lenv = @@ -413,11 +408,6 @@ ledgerStateWriteLoop tracer swQueue codecConfig = , "." ] -mkLedgerStateFilename :: LedgerStateDir -> ExtLedgerState CardanoBlock mk -> Maybe EpochNo -> WithOrigin FilePath -mkLedgerStateFilename dir ledger mEpochNo = - lsfFilePath . dbPointToFileName dir mEpochNo - <$> getPoint (ledgerTipPoint @CardanoBlock (ledgerState ledger)) - saveCleanupState :: HasLedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () saveCleanupState env ledger mEpochNo = do let st = clsState ledger @@ -431,34 +421,6 @@ hashToAnnotation = Base16.encode . BS.take 5 mkRawHash :: HeaderHash CardanoBlock -> ByteString mkRawHash = toRawHash (Proxy @CardanoBlock) -mkShortHash :: HeaderHash CardanoBlock -> ByteString -mkShortHash = hashToAnnotation . mkRawHash - -dbPointToFileName :: LedgerStateDir -> Maybe EpochNo -> Point.Block SlotNo (HeaderHash CardanoBlock) -> LedgerStateFile -dbPointToFileName (LedgerStateDir stateDir) mEpochNo (Point.Block slot hash) = - LedgerStateFile - { lsfSlotNo = slot - , lsfHash = shortHash - , lsNewEpoch = maybeToStrict mEpochNo - , lsfFilePath = - mconcat - [ stateDir show (unSlotNo slot) - , "-" - , BS.unpack shortHash - , epochSuffix - , ".lstate" - ] - } - where - shortHash :: ByteString - shortHash = mkShortHash hash - - epochSuffix :: String - epochSuffix = - case mEpochNo of - Nothing -> "" - Just epoch -> "-" ++ show (unEpochNo epoch) - parseLedgerStateFileName :: LedgerStateDir -> FilePath -> Maybe LedgerStateFile parseLedgerStateFileName (LedgerStateDir stateDir) fp = case break (== '-') (dropExtension fp) of @@ -689,7 +651,7 @@ loadLedgerStateFromFile tracer config delete point lsf = do decodeState :: (forall s. Decoder s CardanoLedgerState) decodeState = decodeCardanoLedgerState $ - unstowLedgerTables <$> + unstowLedgerTables <$> Consensus.decodeExtLedgerState (decodeDisk codecConfig) (decodeDisk codecConfig) @@ -786,9 +748,9 @@ tickThenReapplyCheckHash :: ExtLedgerCfg CardanoBlock -> CardanoBlock -> ExtLedgerState CardanoBlock ValuesMK -> - Either - SyncNodeError - ( LedgerResult + Either + SyncNodeError + ( LedgerResult (ExtLedgerState CardanoBlock) (ExtLedgerState CardanoBlock DiffMK) ) From 12126d39f6a552fdcf351ff6e78fe7f8a9297228 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 26 Aug 2025 14:35:29 -0400 Subject: [PATCH 4/6] Separate Ledger state from ledger tables This allows us to carry around ledger tables with a minimal UTxO set, which reduces the amount of processing we have to do when applying blocks to the ledger state --- .../src/Cardano/DbSync/Ledger/State.hs | 122 ++++++++++++------ .../src/Cardano/DbSync/Ledger/Types.hs | 66 ++++++++-- 2 files changed, 136 insertions(+), 52 deletions(-) diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index 909aab1d7..60ba68b34 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -7,15 +7,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} - - - - module Cardano.DbSync.Ledger.State ( applyBlock, defaultApplyResult, @@ -39,9 +36,11 @@ module Cardano.DbSync.Ledger.State ( import Cardano.BM.Trace (Trace, logInfo, logWarning) import Cardano.Binary (Decoder, DecoderError) import qualified Cardano.Binary as Serialize +import Cardano.DbSync.Api.Types (InsertOptions (..), LedgerEnv (..), SyncOptions (..)) import Cardano.DbSync.Config.Types import qualified Cardano.DbSync.Era.Cardano.Util as Cardano import qualified Cardano.DbSync.Era.Shelley.Generic as Generic +import Cardano.DbSync.Error (SyncNodeError (..), fromEitherSTM) import Cardano.DbSync.Ledger.Event import Cardano.DbSync.Ledger.Types import Cardano.DbSync.StateQuery @@ -49,7 +48,11 @@ import Cardano.DbSync.Types import Cardano.DbSync.Util import qualified Cardano.Ledger.Alonzo.PParams as Alonzo import Cardano.Ledger.Alonzo.Scripts +import Cardano.Ledger.BaseTypes (StrictMaybe) import qualified Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.Conway.Core as Shelley +import Cardano.Ledger.Conway.Governance +import qualified Cardano.Ledger.Conway.Governance as Shelley import Cardano.Ledger.Shelley.AdaPots (AdaPots) import qualified Cardano.Ledger.Shelley.LedgerState as Shelley import Cardano.Prelude hiding (atomically) @@ -70,15 +73,7 @@ import Control.Concurrent.Class.MonadSTM.Strict ( ) import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue) import qualified Control.Exception as Exception - import qualified Data.ByteString.Base16 as Base16 - -import Cardano.DbSync.Api.Types (InsertOptions (..), LedgerEnv (..), SyncOptions (..)) -import Cardano.DbSync.Error (SyncNodeError (..), fromEitherSTM) -import Cardano.Ledger.BaseTypes (StrictMaybe) -import Cardano.Ledger.Conway.Core as Shelley -import Cardano.Ledger.Conway.Governance -import qualified Cardano.Ledger.Conway.Governance as Shelley import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.ByteString.Short as SBS @@ -111,19 +106,23 @@ import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState (..)) import Ouroboros.Consensus.HardFork.Combinator.State (epochInfoLedger) import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Ledger.Abstract ( + ApplyBlock (..), LedgerResult (..), getTip, ledgerTipHash, ledgerTipSlot, tickThenReapplyLedgerResult, ) -import Ouroboros.Consensus.Ledger.Basics - ( ComputeLedgerEvents(..), - CanStowLedgerTables(..), - DiffMK, - ValuesMK ) +import Ouroboros.Consensus.Ledger.Basics ( + ComputeLedgerEvents (..), + EmptyMK, + HasLedgerTables (..), + KeysMK, + LedgerTables (..), + ) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerCfg (..), ExtLedgerState (..)) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus +import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffsMK, forgetLedgerTables, restrictValuesMK) import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Shelley.Ledger.Block import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus @@ -136,7 +135,6 @@ import System.Directory (listDirectory, removeFile) import System.FilePath (dropExtension, takeExtension, ()) import System.Mem (performMajorGC) import Prelude (id) -import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs, forgetLedgerTables) -- Note: The decision on whether a ledger-state is written to disk is based on the block number -- rather than the slot number because while the block number is fully populated (for every block @@ -199,15 +197,20 @@ mkHasLedgerEnv trce protoInfo dir nw systemStart syncOptions = do initCardanoLedgerState :: Consensus.ProtocolInfo CardanoBlock -> CardanoLedgerState initCardanoLedgerState pInfo = CardanoLedgerState - { clsState = Consensus.pInfoInitLedger pInfo + { clsState = forgetLedgerTables initState + , clsTables = projectLedgerTables initState , clsEpochBlockNo = GenesisEpochBlockNo } + where + initState = Consensus.pInfoInitLedger pInfo getTopLevelconfigHasLedger :: HasLedgerEnv -> TopLevelConfig CardanoBlock getTopLevelconfigHasLedger = Consensus.pInfoConfig . leProtocolInfo -readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock ValuesMK) -readCurrentStateUnsafe hle = atomically (clsState . ledgerDbCurrent <$> readStateUnsafe hle) +readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock EmptyMK) +readCurrentStateUnsafe hle = + atomically + (clsState . ledgerDbCurrent <$> readStateUnsafe hle) -- TODO make this type safe. We make the assumption here that the first message of -- the chainsync protocol is 'RollbackTo'. @@ -235,20 +238,24 @@ applyBlock env blk = do !ledgerDB <- readStateUnsafe env let oldState = ledgerDbCurrent ledgerDB -- Calculate ledger diffs - !result <- fromEitherSTM $ tickThenReapplyCheckHash (ExtLedgerCfg (getTopLevelconfigHasLedger env)) blk (clsState oldState) + !result <- + fromEitherSTM $ + tickThenReapplyCheckHash + (ExtLedgerCfg (getTopLevelconfigHasLedger env)) + blk + oldState -- Extract the ledger events let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (lrEvents result) -- Find the deposits let (ledgerEvents, deposits) = splitDeposits ledgerEventsFull -- Calculate DRep distribution - let !newLedgerState = finaliseDrepDistr (lrResult result) + let !newLedgerState = finaliseDrepDistr $ clsState (lrResult result) -- Apply the ledger diffs - let !newLedgerState' = applyDiffs (clsState oldState) newLedgerState -- Construct the new ledger state !details <- getSlotDetails env (ledgerState newLedgerState) time (cardanoBlockSlotNo blk) - !newEpoch <- fromEitherSTM $ mkOnNewEpoch (clsState oldState) newLedgerState' (findAdaPots ledgerEvents) + !newEpoch <- fromEitherSTM $ mkOnNewEpoch (clsState oldState) newLedgerState (findAdaPots ledgerEvents) let !newEpochBlockNo = applyToEpochBlockNo (isJust $ blockIsEBB blk) (isJust newEpoch) (clsEpochBlockNo oldState) - let !newState = CardanoLedgerState newLedgerState' newEpochBlockNo + let !newState = CardanoLedgerState newLedgerState (clsTables $ lrResult result) newEpochBlockNo -- Add the new ledger state to the in-memory db let !ledgerDB' = pushLedgerDB ledgerDB newState writeTVar (leStateVar env) (Strict.Just ledgerDB') @@ -651,11 +658,10 @@ loadLedgerStateFromFile tracer config delete point lsf = do decodeState :: (forall s. Decoder s CardanoLedgerState) decodeState = decodeCardanoLedgerState $ - unstowLedgerTables <$> - Consensus.decodeExtLedgerState - (decodeDisk codecConfig) - (decodeDisk codecConfig) - (decodeDisk codecConfig) + Consensus.decodeExtLedgerState + (decodeDisk codecConfig) + (decodeDisk codecConfig) + (decodeDisk codecConfig) getSlotNoSnapshot :: SnapshotPoint -> WithOrigin SlotNo getSlotNoSnapshot (OnDisk lsf) = at $ lsfSlotNo lsf @@ -747,28 +753,64 @@ ledgerEpochNo env cls = tickThenReapplyCheckHash :: ExtLedgerCfg CardanoBlock -> CardanoBlock -> - ExtLedgerState CardanoBlock ValuesMK -> + CardanoLedgerState -> Either SyncNodeError ( LedgerResult (ExtLedgerState CardanoBlock) - (ExtLedgerState CardanoBlock DiffMK) + CardanoLedgerState ) -tickThenReapplyCheckHash cfg block lsb = - if blockPrevHash block == ledgerTipHash (ledgerState lsb) - then Right $ tickThenReapplyLedgerResult ComputeLedgerEvents cfg block lsb +tickThenReapplyCheckHash cfg block state'@CardanoLedgerState {..} = + if blockPrevHash block == ledgerTipHash (ledgerState clsState) + then + let + -- Get utxo keys set to update + keys :: LedgerTables (ExtLedgerState CardanoBlock) KeysMK + keys = getBlockKeySets block + -- Get the current ledger tables + ledgerTables = getLedgerTables clsTables + -- Limit ledger tables to utxo keys above + restrictedTables = restrictValuesMK ledgerTables (getLedgerTables keys) + -- Attach the tables back to the ledger state + ledgerState' = withLedgerTables clsState (LedgerTables restrictedTables) + -- Apply the block + newLedgerState = + tickThenReapplyLedgerResult ComputeLedgerEvents cfg block ledgerState' + in + Right $ + fmap + ( \stt -> + state' + { clsState = forgetLedgerTables stt + , clsTables = + LedgerTables + . applyDiffsMK ledgerTables + . getLedgerTables + . projectLedgerTables + $ stt + } + ) + newLedgerState else Left $ SNErrLedgerState $ mconcat [ "Ledger state hash mismatch. Ledger head is slot " - , show (unSlotNo $ fromWithOrigin (SlotNo 0) (ledgerTipSlot $ ledgerState lsb)) + , show + ( unSlotNo $ + fromWithOrigin + (SlotNo 0) + (ledgerTipSlot $ ledgerState clsState) + ) , " hash " - , Text.unpack $ renderByteArray (Cardano.unChainHash (ledgerTipHash $ ledgerState lsb)) + , Text.unpack $ + renderByteArray (Cardano.unChainHash (ledgerTipHash $ ledgerState clsState)) , " but block previous hash is " - , Text.unpack $ renderByteArray (Cardano.unChainHash $ blockPrevHash block) + , Text.unpack $ + renderByteArray (Cardano.unChainHash $ blockPrevHash block) , " and block current hash is " - , Text.unpack $ renderByteArray (SBS.fromShort . Consensus.getOneEraHash $ blockHash block) + , Text.unpack $ + renderByteArray (SBS.fromShort . Consensus.getOneEraHash $ blockHash block) , "." ] diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs index fa09aeb5d..48b312539 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs @@ -40,6 +40,7 @@ import Control.Concurrent.Class.MonadSTM.Strict ( ) import Control.Concurrent.STM.TBQueue (TBQueue) import qualified Data.Map.Strict as Map +import Data.SOP.Functors (Flip (..)) import Data.SOP.Strict import qualified Data.Set as Set import qualified Data.Strict.Maybe as Strict @@ -48,13 +49,13 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..)) import Ouroboros.Consensus.Cardano.Block hiding (CardanoBlock, CardanoLedgerState) import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState (..)) import Ouroboros.Consensus.Ledger.Abstract (getTipSlot) +import Ouroboros.Consensus.Ledger.Basics (EmptyMK, LedgerTables, ValuesMK) +import qualified Ouroboros.Consensus.Ledger.Basics as Consensus import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Shelley.Ledger (LedgerState (..), ShelleyBlock) import Ouroboros.Network.AnchoredSeq (Anchorable (..), AnchoredSeq (..)) import Prelude (fail, id) -import Ouroboros.Consensus.Ledger.Basics (ValuesMK) -import Data.SOP.Functors (Flip (..)) -------------------------------------------------------------------------- -- Ledger Types @@ -77,7 +78,8 @@ data HasLedgerEnv = HasLedgerEnv } data CardanoLedgerState = CardanoLedgerState - { clsState :: !(ExtLedgerState CardanoBlock ValuesMK) + { clsState :: !(ExtLedgerState CardanoBlock EmptyMK) + , clsTables :: !(LedgerTables (ExtLedgerState CardanoBlock) ValuesMK) , clsEpochBlockNo :: !EpochBlockNo } @@ -103,7 +105,10 @@ instance FromCBOR EpochBlockNo where 2 -> EpochBlockNo <$> fromCBOR n -> fail $ "unexpected EpochBlockNo value " <> show n -encodeCardanoLedgerState :: (ExtLedgerState CardanoBlock ValuesMK -> Encoding) -> CardanoLedgerState -> Encoding +encodeCardanoLedgerState :: + (ExtLedgerState CardanoBlock EmptyMK -> Encoding) -> + CardanoLedgerState -> + Encoding encodeCardanoLedgerState encodeExt cls = mconcat [ encodeExt (clsState cls) @@ -111,11 +116,12 @@ encodeCardanoLedgerState encodeExt cls = ] decodeCardanoLedgerState :: - (forall s. Decoder s (ExtLedgerState CardanoBlock ValuesMK)) -> + (forall s. Decoder s (ExtLedgerState CardanoBlock EmptyMK)) -> (forall s. Decoder s CardanoLedgerState) decodeCardanoLedgerState decodeExt = do ldgrState <- decodeExt - CardanoLedgerState ldgrState <$> fromCBOR + let ldgrTables = Consensus.projectLedgerTables (Consensus.unstowLedgerTables ldgrState) + CardanoLedgerState ldgrState ldgrTables <$> fromCBOR data LedgerStateFile = LedgerStateFile { lsfSlotNo :: !SlotNo @@ -217,7 +223,13 @@ instance HasNewEpochState ShelleyEra where applyNewEpochState st = hApplyExtLedgerState $ - fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* fn id :* Nil + fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState AllegraEra where getNewEpochState st = case ledgerState st of @@ -226,7 +238,13 @@ instance HasNewEpochState AllegraEra where applyNewEpochState st = hApplyExtLedgerState $ - fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* Nil + fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState MaryEra where getNewEpochState st = case ledgerState st of @@ -235,7 +253,13 @@ instance HasNewEpochState MaryEra where applyNewEpochState st = hApplyExtLedgerState $ - fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* Nil + fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState AlonzoEra where getNewEpochState st = case ledgerState st of @@ -244,7 +268,13 @@ instance HasNewEpochState AlonzoEra where applyNewEpochState st = hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* Nil + fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* Nil instance HasNewEpochState BabbageEra where getNewEpochState st = case ledgerState st of @@ -253,7 +283,13 @@ instance HasNewEpochState BabbageEra where applyNewEpochState st = hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* Nil + fn id + :* fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* Nil instance HasNewEpochState ConwayEra where getNewEpochState st = case ledgerState st of @@ -262,7 +298,13 @@ instance HasNewEpochState ConwayEra where applyNewEpochState st = hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* Nil + fn id + :* fn id + :* fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* Nil hApplyExtLedgerState :: NP (Flip LedgerState mk -.-> Flip LedgerState mk) (CardanoShelleyEras StandardCrypto) -> From 57ac0965a2253c515f7be3bda05a6e470a001502 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 26 Aug 2025 14:37:02 -0400 Subject: [PATCH 5/6] Fourmolize! --- cardano-chain-gen/src/Cardano/Mock/Chain.hs | 4 ++-- cardano-chain-gen/src/Cardano/Mock/ChainDB.hs | 24 +++++++++---------- .../src/Cardano/Mock/ChainSync/Server.hs | 16 ++++++------- .../src/Cardano/Mock/ChainSync/State.hs | 4 ++-- .../src/Cardano/Mock/Forging/Interpreter.hs | 4 ++-- .../Mock/Forging/Tx/Conway/Scenarios.hs | 2 +- .../test/Test/Cardano/Db/Mock/UnifiedApi.hs | 2 +- .../src/Cardano/DbTool/Validate/Balance.hs | 6 ++--- 8 files changed, 31 insertions(+), 31 deletions(-) diff --git a/cardano-chain-gen/src/Cardano/Mock/Chain.hs b/cardano-chain-gen/src/Cardano/Mock/Chain.hs index 0f2bebe12..8985fada7 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Chain.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Chain.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE PartialTypeSignatures #-} module Cardano.Mock.Chain ( Chain' (..), @@ -18,10 +18,10 @@ module Cardano.Mock.Chain ( ) where import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block -import Ouroboros.Consensus.Ledger.Basics (ValuesMK) -- | This looks a lot like the 'Chain' defined in Ouroboros.Network.MockChain.Chain -- but this version includes also the ledger states. diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs index a420d0cb8..33aeae059 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} module Cardano.Mock.ChainDB ( ChainDB (..), @@ -19,17 +19,17 @@ module Cardano.Mock.ChainDB ( currentBlockNo, ) where -import Ouroboros.Consensus.Cardano.Ledger () -import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () -import Ouroboros.Consensus.Cardano.CanHardFork () import Cardano.Mock.Chain import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Cardano.CanHardFork () +import Ouroboros.Consensus.Cardano.Ledger () import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import qualified Ouroboros.Consensus.Ledger.Extended as Consensus +import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Network.Block (Tip (..)) -import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -- | Thin layer around 'Chain' that knows how to apply blocks and maintain -- new and old states. The state here, which is the 'Chain', is not a MVar, @@ -72,7 +72,7 @@ replaceGenesisDB :: replaceGenesisDB chainDB st = chainDB {cchain = Genesis st} extendChainDB :: - LedgerSupportsProtocol block => + LedgerSupportsProtocol block => ChainDB block -> block -> ChainDB block @@ -81,14 +81,14 @@ extendChainDB chainDB blk = do -- Get the current ledger state !tipState = getTipState chain -- Apply the block and compute the diffs - !diffState = tickThenReapply - ComputeLedgerEvents - (Consensus.ExtLedgerCfg $ chainConfig chainDB) - blk - tipState + !diffState = + tickThenReapply + ComputeLedgerEvents + (Consensus.ExtLedgerCfg $ chainConfig chainDB) + blk + tipState -- Apply the diffs !newTipState = applyDiffs tipState diffState - in chainDB {cchain = chain :> (blk, newTipState)} findFirstPoint :: HasHeader block => [Point block] -> ChainDB block -> Maybe (Point block) diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs index ec208a35c..b121aa0d4 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs @@ -55,7 +55,8 @@ import Network.TypedProtocol.Stateful.Codec () import qualified Network.TypedProtocol.Stateful.Peer as St import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint) import Ouroboros.Consensus.Config (TopLevelConfig, configCodec) -import Ouroboros.Consensus.Ledger.Query (BlockQuery, ShowQuery, QueryFootprint (..), BlockSupportsLedgerQuery) +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) +import Ouroboros.Consensus.Ledger.Query (BlockQuery, BlockSupportsLedgerQuery, QueryFootprint (..), ShowQuery) import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx, TxId) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Network.NodeToClient (Apps (..), Codecs' (..), DefaultCodecs) @@ -107,7 +108,6 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQu import Ouroboros.Network.Snocket (LocalAddress, LocalSnocket, LocalSocket (..)) import qualified Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Util.ShowProxy (Proxy (..), ShowProxy (..)) -import Ouroboros.Consensus.Ledger.Basics (ValuesMK) {- HLINT ignore "Use readTVarIO" -} @@ -126,17 +126,17 @@ readChain :: MonadSTM m => ServerHandle m blk -> STM m (Chain blk) readChain handle = do cchain . chainDB <$> readTVar (chainProducerState handle) -addBlock :: - (LedgerSupportsProtocol blk, MonadSTM m) => - ServerHandle m blk -> - blk -> +addBlock :: + (LedgerSupportsProtocol blk, MonadSTM m) => + ServerHandle m blk -> + blk -> STM m () addBlock handle blk = modifyTVar (chainProducerState handle) $ addBlockState blk -rollback :: - (LedgerSupportsProtocol blk, MonadSTM m) => +rollback :: + (LedgerSupportsProtocol blk, MonadSTM m) => ServerHandle m blk -> Point blk -> STM m () diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs b/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs index 73e094e38..99b9e0142 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs @@ -24,8 +24,8 @@ import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block (HasHeader, HeaderHash, Point, blockPoint, castPoint) import Ouroboros.Consensus.Config (TopLevelConfig) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) -import Ouroboros.Network.Block (ChainUpdate (..)) import Ouroboros.Consensus.Ledger.Tables (ValuesMK) +import Ouroboros.Network.Block (ChainUpdate (..)) data ChainProducerState block = ChainProducerState { chainDB :: ChainDB block @@ -54,7 +54,7 @@ data FollowerNext | FollowerForwardFrom deriving (Eq, Show) -initChainProducerState :: +initChainProducerState :: TopLevelConfig block -> Chain.State block ValuesMK -> ChainProducerState block diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs index 27baa9473..473b5915c 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs @@ -32,7 +32,6 @@ module Cardano.Mock.Forging.Interpreter ( mkTxId, ) where -import Ouroboros.Consensus.Shelley.Ledger.Ledger import Cardano.Ledger.Core (txIdTx) import qualified Cardano.Ledger.Shelley.API.Mempool as Ledger import Cardano.Ledger.Shelley.LedgerState (NewEpochState (..)) @@ -89,6 +88,7 @@ import Ouroboros.Consensus.Config ( configLedger, topLevelConfigLedger, ) +import Ouroboros.Consensus.Shelley.Ledger.Ledger import Ouroboros.Consensus.Forecast (Forecast (..)) import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus @@ -365,7 +365,7 @@ forgeNextLeaders interpreter txes possibleLeaders = do -- Tick the ledger state for the 'SlotNo' we're producing a block for let ledgerState' = ledgerState $ currentState (istChain interState) - tickedLedgerSt = + tickedLedgerSt = applyChainTick ComputeLedgerEvents (configLedger cfg) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs index 907fa9691..eb862a471 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs @@ -31,10 +31,10 @@ import Cardano.Prelude import Data.List.Extra (chunksOf) import Data.Maybe.Strict (StrictMaybe (..)) import Ouroboros.Consensus.Cardano.Block (LedgerState (..)) +import Ouroboros.Consensus.Ledger.Basics (ValuesMK) import Ouroboros.Consensus.Shelley.Eras (ConwayEra ()) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock ()) import qualified Prelude -import Ouroboros.Consensus.Ledger.Basics (ValuesMK) newtype ShelleyLedgerState era mk = ShelleyLedgerState {unState :: LedgerState (ShelleyBlock PraosStandard era) mk} diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs index 8ea6c5c93..ae197bd10 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/UnifiedApi.hs @@ -109,7 +109,7 @@ withAlonzoFindLeaderAndSubmitTx interpreter mockServer mkTxs = do withBabbageFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> + ( LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> Either ForgingError (Core.Tx BabbageEra) ) -> IO CardanoBlock diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs index db303c2ec..5f75d4198 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/Balance.hs @@ -67,9 +67,9 @@ vBErr :: String vBErr = "Validation Balance Error - " -- Given an address, return it's current UTxO balance. -ledgerAddrBalance :: - Text -> - LedgerState (CardanoBlock StandardCrypto) mk -> +ledgerAddrBalance :: + Text -> + LedgerState (CardanoBlock StandardCrypto) mk -> Either ValidateBalanceError Word64 ledgerAddrBalance addr lsc = case lsc of From 0557bf670bf659d3b6d6743b66f40a9dd5213b01 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Tue, 26 Aug 2025 15:44:20 -0400 Subject: [PATCH 6/6] Resurrect ledger snapshots --- .../src/Cardano/DbSync/Ledger/State.hs | 106 ++++++++++++------ 1 file changed, 69 insertions(+), 37 deletions(-) diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index 60ba68b34..ac011bf5e 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -71,7 +71,7 @@ import Control.Concurrent.Class.MonadSTM.Strict ( readTVar, writeTVar, ) -import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue) +import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue, writeTBQueue) import qualified Control.Exception as Exception import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS @@ -105,21 +105,9 @@ import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState (..)) import Ouroboros.Consensus.HardFork.Combinator.State (epochInfoLedger) import qualified Ouroboros.Consensus.HardFork.History as History -import Ouroboros.Consensus.Ledger.Abstract ( - ApplyBlock (..), - LedgerResult (..), - getTip, - ledgerTipHash, - ledgerTipSlot, - tickThenReapplyLedgerResult, - ) -import Ouroboros.Consensus.Ledger.Basics ( - ComputeLedgerEvents (..), - EmptyMK, - HasLedgerTables (..), - KeysMK, - LedgerTables (..), - ) +import Ouroboros.Consensus.Ledger.Abstract (LedgerResult) +import qualified Ouroboros.Consensus.Ledger.Abstract as Consensus +import Ouroboros.Consensus.Ledger.Basics (EmptyMK, KeysMK, LedgerTables) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerCfg (..), ExtLedgerState (..)) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffsMK, forgetLedgerTables, restrictValuesMK) @@ -131,10 +119,10 @@ import Ouroboros.Network.AnchoredSeq (AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredSeq as AS import Ouroboros.Network.Block (HeaderHash, Point (..), blockNo) import qualified Ouroboros.Network.Point as Point -import System.Directory (listDirectory, removeFile) +import System.Directory (doesFileExist, listDirectory, removeFile) import System.FilePath (dropExtension, takeExtension, ()) import System.Mem (performMajorGC) -import Prelude (id) +import Prelude (String, id) -- Note: The decision on whether a ledger-state is written to disk is based on the block number -- rather than the slot number because while the block number is fully populated (for every block @@ -198,7 +186,7 @@ initCardanoLedgerState :: Consensus.ProtocolInfo CardanoBlock -> CardanoLedgerSt initCardanoLedgerState pInfo = CardanoLedgerState { clsState = forgetLedgerTables initState - , clsTables = projectLedgerTables initState + , clsTables = Consensus.projectLedgerTables initState , clsEpochBlockNo = GenesisEpochBlockNo } where @@ -245,17 +233,17 @@ applyBlock env blk = do blk oldState -- Extract the ledger events - let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (lrEvents result) + let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (Consensus.lrEvents result) -- Find the deposits let (ledgerEvents, deposits) = splitDeposits ledgerEventsFull -- Calculate DRep distribution - let !newLedgerState = finaliseDrepDistr $ clsState (lrResult result) + let !newLedgerState = finaliseDrepDistr $ clsState (Consensus.lrResult result) -- Apply the ledger diffs -- Construct the new ledger state !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 (clsTables $ lrResult result) newEpochBlockNo + let !newState = CardanoLedgerState newLedgerState (clsTables $ Consensus.lrResult result) newEpochBlockNo -- Add the new ledger state to the in-memory db let !ledgerDB' = pushLedgerDB ledgerDB newState writeTVar (leStateVar env) (Strict.Just ledgerDB') @@ -372,7 +360,17 @@ storeSnapshotAndCleanupMaybe env oldState appResult blkNo isCons syncState = (SyncLagging, _) -> False saveCurrentLedgerState :: HasLedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () -saveCurrentLedgerState _ _ _ = pure () +saveCurrentLedgerState env lState mEpochNo = do + case mkLedgerStateFilename (leDir env) (clsState lState) mEpochNo of + Origin -> pure () -- we don't store genesis + At file -> do + exists <- doesFileExist file + if exists + then + logInfo (leTrace env) $ + mconcat + ["File ", Text.pack file, " exists"] + else atomically $ writeTBQueue (leStateWriteQueue env) (file, lState) runLedgerStateWriteThread :: Trace IO Text -> LedgerEnv -> IO () runLedgerStateWriteThread tracer lenv = @@ -415,12 +413,18 @@ ledgerStateWriteLoop tracer swQueue codecConfig = , "." ] +mkLedgerStateFilename :: LedgerStateDir -> ExtLedgerState CardanoBlock mk -> Maybe EpochNo -> WithOrigin FilePath +mkLedgerStateFilename dir ledger mEpochNo = + lsfFilePath + . dbPointToFileName dir mEpochNo + <$> getPoint (Consensus.ledgerTipPoint @CardanoBlock (ledgerState ledger)) + saveCleanupState :: HasLedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () saveCleanupState env ledger mEpochNo = do let st = clsState ledger saveCurrentLedgerState env ledger mEpochNo cleanupLedgerStateFiles env $ - fromWithOrigin (SlotNo 0) (ledgerTipSlot $ ledgerState st) + fromWithOrigin (SlotNo 0) (Consensus.ledgerTipSlot $ ledgerState st) hashToAnnotation :: ByteString -> ByteString hashToAnnotation = Base16.encode . BS.take 5 @@ -428,6 +432,34 @@ hashToAnnotation = Base16.encode . BS.take 5 mkRawHash :: HeaderHash CardanoBlock -> ByteString mkRawHash = toRawHash (Proxy @CardanoBlock) +mkShortHash :: HeaderHash CardanoBlock -> ByteString +mkShortHash = hashToAnnotation . mkRawHash + +dbPointToFileName :: LedgerStateDir -> Maybe EpochNo -> Point.Block SlotNo (HeaderHash CardanoBlock) -> LedgerStateFile +dbPointToFileName (LedgerStateDir stateDir) mEpochNo (Point.Block slot hash) = + LedgerStateFile + { lsfSlotNo = slot + , lsfHash = shortHash + , lsNewEpoch = maybeToStrict mEpochNo + , lsfFilePath = + mconcat + [ stateDir show (unSlotNo slot) + , "-" + , BS.unpack shortHash + , epochSuffix + , ".lstate" + ] + } + where + shortHash :: ByteString + shortHash = mkShortHash hash + + epochSuffix :: String + epochSuffix = + case mEpochNo of + Nothing -> "" + Just epoch -> "-" ++ show (unEpochNo epoch) + parseLedgerStateFileName :: LedgerStateDir -> FilePath -> Maybe LedgerStateFile parseLedgerStateFileName (LedgerStateDir stateDir) fp = case break (== '-') (dropExtension fp) of @@ -682,7 +714,7 @@ listMemorySnapshots env = do pure $ filter notGenesis - (castPoint . getTip . clsState <$> getEdgePoints ledgerDB) + (castPoint . Consensus.getTip . clsState <$> getEdgePoints ledgerDB) where getEdgePoints ldb = case AS.toNewestFirst $ ledgerDbCheckpoints ldb of @@ -738,7 +770,7 @@ getRegisteredPoolShelley lState = ledgerEpochNo :: HasLedgerEnv -> ExtLedgerState CardanoBlock mk -> Either SyncNodeError (Maybe EpochNo) ledgerEpochNo env cls = - case ledgerTipSlot (ledgerState cls) of + case Consensus.ledgerTipSlot (ledgerState cls) of Origin -> Right Nothing NotOrigin slot -> case runExcept $ epochInfoEpoch epochInfo slot of @@ -761,21 +793,21 @@ tickThenReapplyCheckHash :: CardanoLedgerState ) tickThenReapplyCheckHash cfg block state'@CardanoLedgerState {..} = - if blockPrevHash block == ledgerTipHash (ledgerState clsState) + if blockPrevHash block == Consensus.ledgerTipHash (ledgerState clsState) then let -- Get utxo keys set to update keys :: LedgerTables (ExtLedgerState CardanoBlock) KeysMK - keys = getBlockKeySets block + keys = Consensus.getBlockKeySets block -- Get the current ledger tables - ledgerTables = getLedgerTables clsTables + ledgerTables = Consensus.getLedgerTables clsTables -- Limit ledger tables to utxo keys above - restrictedTables = restrictValuesMK ledgerTables (getLedgerTables keys) + restrictedTables = restrictValuesMK ledgerTables (Consensus.getLedgerTables keys) -- Attach the tables back to the ledger state - ledgerState' = withLedgerTables clsState (LedgerTables restrictedTables) + ledgerState' = Consensus.withLedgerTables clsState (Consensus.LedgerTables restrictedTables) -- Apply the block newLedgerState = - tickThenReapplyLedgerResult ComputeLedgerEvents cfg block ledgerState' + Consensus.tickThenReapplyLedgerResult Consensus.ComputeLedgerEvents cfg block ledgerState' in Right $ fmap @@ -783,10 +815,10 @@ tickThenReapplyCheckHash cfg block state'@CardanoLedgerState {..} = state' { clsState = forgetLedgerTables stt , clsTables = - LedgerTables + Consensus.LedgerTables . applyDiffsMK ledgerTables - . getLedgerTables - . projectLedgerTables + . Consensus.getLedgerTables + . Consensus.projectLedgerTables $ stt } ) @@ -800,11 +832,11 @@ tickThenReapplyCheckHash cfg block state'@CardanoLedgerState {..} = ( unSlotNo $ fromWithOrigin (SlotNo 0) - (ledgerTipSlot $ ledgerState clsState) + (Consensus.ledgerTipSlot $ ledgerState clsState) ) , " hash " , Text.unpack $ - renderByteArray (Cardano.unChainHash (ledgerTipHash $ ledgerState clsState)) + renderByteArray (Cardano.unChainHash (Consensus.ledgerTipHash $ ledgerState clsState)) , " but block previous hash is " , Text.unpack $ renderByteArray (Cardano.unChainHash $ blockPrevHash block)