From 8b47bebf71b7ca59dbe2a368192309938f2b0561 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Mon, 11 Aug 2025 16:22:37 -0400 Subject: [PATCH 1/5] feature: Implement UTxO-HD --- cabal.project | 2 +- cardano-chain-gen/src/Cardano/Mock/Chain.hs | 4 +- cardano-chain-gen/src/Cardano/Mock/ChainDB.hs | 42 ++++- .../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 +- cardano-db-sync/cardano-db-sync.cabal | 1 + .../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 | 153 ++++++++++++------ .../src/Cardano/DbSync/Ledger/Types.hs | 86 +++++++--- .../src/Cardano/DbTool/Validate/Balance.hs | 7 +- 22 files changed, 346 insertions(+), 191 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..8985fada7 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Chain.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Chain.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,6 +18,7 @@ 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 @@ -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..33aeae059 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs @@ -2,13 +2,15 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} module Cardano.Mock.ChainDB ( ChainDB (..), + currentState, initChainDB, headTip, - currentState, replaceGenesisDB, extendChainDB, findFirstPoint, @@ -19,10 +21,14 @@ module Cardano.Mock.ChainDB ( 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 +import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) +import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffs) +import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Network.Block (Tip (..)) -- | Thin layer around 'Chain' that knows how to apply blocks and maintain @@ -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..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) +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) @@ -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..99b9e0142 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 #-} @@ -23,6 +24,7 @@ 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.Consensus.Ledger.Tables (ValuesMK) import Ouroboros.Network.Block (ChainUpdate (..)) data ChainProducerState block = ChainProducerState @@ -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..473b5915c 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs @@ -81,12 +81,14 @@ import Ouroboros.Consensus.Cardano.Block ( ShelleyEra, ) import Ouroboros.Consensus.Cardano.CanHardFork () +import Ouroboros.Consensus.Cardano.Ledger () import Ouroboros.Consensus.Config ( TopLevelConfig, configConsensus, configLedger, topLevelConfigLedger, ) +import Ouroboros.Consensus.Shelley.Ledger.Ledger import Ouroboros.Consensus.Forecast (Forecast (..)) import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus @@ -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..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,12 +31,13 @@ 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 -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..ae197bd10 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/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/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..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 @@ -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 p mk. 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 p mk. + 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..ac011bf5e 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 #-} -#if __GLASGOW_HASKELL__ >= 908 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - 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, writeTBQueue) 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 @@ -110,17 +105,12 @@ 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 ( - LedgerResult (..), - getTip, - ledgerTipHash, - ledgerTipPoint, - ledgerTipSlot, - tickThenReapplyLedgerResult, - ) -import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..)) +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) import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Shelley.Ledger.Block import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Consensus @@ -195,15 +185,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 = Consensus.projectLedgerTables initState , clsEpochBlockNo = GenesisEpochBlockNo } + where + initState = Consensus.pInfoInitLedger pInfo getTopLevelconfigHasLedger :: HasLedgerEnv -> TopLevelConfig CardanoBlock getTopLevelconfigHasLedger = Consensus.pInfoConfig . leProtocolInfo -readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock) -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'. @@ -227,16 +222,29 @@ 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 - !result <- fromEitherSTM $ tickThenReapplyCheckHash (ExtLedgerCfg (getTopLevelconfigHasLedger env)) blk (clsState oldState) - let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (lrEvents result) + -- Calculate ledger diffs + !result <- + fromEitherSTM $ + tickThenReapplyCheckHash + (ExtLedgerCfg (getTopLevelconfigHasLedger env)) + blk + oldState + -- Extract the ledger events + let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (Consensus.lrEvents result) + -- Find the deposits let (ledgerEvents, deposits) = splitDeposits ledgerEventsFull - let !newLedgerState = finaliseDrepDistr (lrResult result) + -- Calculate DRep distribution + 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 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') let !appResult = @@ -258,7 +266,7 @@ 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 +300,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 +400,7 @@ ledgerStateWriteLoop tracer swQueue codecConfig = (encodeDisk codecConfig) (encodeDisk codecConfig) (encodeDisk codecConfig) + . forgetLedgerTables ) ledger endTime <- getCurrentTime @@ -404,17 +413,18 @@ 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)) + 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 @@ -704,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 @@ -745,9 +755,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,9 +768,9 @@ 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 + case Consensus.ledgerTipSlot (ledgerState cls) of Origin -> Right Nothing NotOrigin slot -> case runExcept $ epochInfoEpoch epochInfo slot of @@ -775,30 +785,71 @@ ledgerEpochNo env cls = tickThenReapplyCheckHash :: ExtLedgerCfg CardanoBlock -> CardanoBlock -> - ExtLedgerState CardanoBlock -> - Either SyncNodeError (LedgerResult (ExtLedgerState CardanoBlock) (ExtLedgerState CardanoBlock)) -tickThenReapplyCheckHash cfg block lsb = - if blockPrevHash block == ledgerTipHash (ledgerState lsb) - then Right $ tickThenReapplyLedgerResult ComputeLedgerEvents cfg block lsb + CardanoLedgerState -> + Either + SyncNodeError + ( LedgerResult + (ExtLedgerState CardanoBlock) + CardanoLedgerState + ) +tickThenReapplyCheckHash cfg block state'@CardanoLedgerState {..} = + if blockPrevHash block == Consensus.ledgerTipHash (ledgerState clsState) + then + let + -- Get utxo keys set to update + keys :: LedgerTables (ExtLedgerState CardanoBlock) KeysMK + keys = Consensus.getBlockKeySets block + -- Get the current ledger tables + ledgerTables = Consensus.getLedgerTables clsTables + -- Limit ledger tables to utxo keys above + restrictedTables = restrictValuesMK ledgerTables (Consensus.getLedgerTables keys) + -- Attach the tables back to the ledger state + ledgerState' = Consensus.withLedgerTables clsState (Consensus.LedgerTables restrictedTables) + -- Apply the block + newLedgerState = + Consensus.tickThenReapplyLedgerResult Consensus.ComputeLedgerEvents cfg block ledgerState' + in + Right $ + fmap + ( \stt -> + state' + { clsState = forgetLedgerTables stt + , clsTables = + Consensus.LedgerTables + . applyDiffsMK ledgerTables + . Consensus.getLedgerTables + . Consensus.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) + (Consensus.ledgerTipSlot $ ledgerState clsState) + ) , " hash " - , Text.unpack $ renderByteArray (Cardano.unChainHash (ledgerTipHash $ ledgerState lsb)) + , Text.unpack $ + renderByteArray (Cardano.unChainHash (Consensus.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) , "." ] 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..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,6 +49,8 @@ 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) @@ -75,7 +78,8 @@ data HasLedgerEnv = HasLedgerEnv } data CardanoLedgerState = CardanoLedgerState - { clsState :: !(ExtLedgerState CardanoBlock) + { clsState :: !(ExtLedgerState CardanoBlock EmptyMK) + , clsTables :: !(LedgerTables (ExtLedgerState CardanoBlock) ValuesMK) , clsEpochBlockNo :: !EpochBlockNo } @@ -101,7 +105,10 @@ instance FromCBOR EpochBlockNo where 2 -> EpochBlockNo <$> fromCBOR n -> fail $ "unexpected EpochBlockNo value " <> show n -encodeCardanoLedgerState :: (ExtLedgerState CardanoBlock -> Encoding) -> CardanoLedgerState -> Encoding +encodeCardanoLedgerState :: + (ExtLedgerState CardanoBlock EmptyMK -> Encoding) -> + CardanoLedgerState -> + Encoding encodeCardanoLedgerState encodeExt cls = mconcat [ encodeExt (clsState cls) @@ -109,11 +116,12 @@ encodeCardanoLedgerState encodeExt cls = ] decodeCardanoLedgerState :: - (forall s. Decoder s (ExtLedgerState CardanoBlock)) -> + (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 @@ -201,12 +209,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 @@ -215,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 @@ -224,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 @@ -233,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 @@ -242,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 @@ -251,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 @@ -260,12 +298,18 @@ 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 (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 +320,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..5f75d4198 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 bb9183f9b9a46797c2637f0f48af664d313ed721 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Thu, 4 Sep 2025 13:59:25 +0300 Subject: [PATCH 2/5] Fix snapshots This still suffers from https://github.com/IntersectMBO/ouroboros-consensus/pull/1577 so Byron snapshots don't deserialise, until we update CHaP further --- cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs index 48b312539..f31d88fdd 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs @@ -50,8 +50,8 @@ 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.Basics (EmptyMK, LedgerTables, ValuesMK) -import qualified Ouroboros.Consensus.Ledger.Basics as Consensus import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) +import Ouroboros.Consensus.Ledger.Tables (valuesMKDecoder, valuesMKEncoder) import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Shelley.Ledger (LedgerState (..), ShelleyBlock) import Ouroboros.Network.AnchoredSeq (Anchorable (..), AnchoredSeq (..)) @@ -113,15 +113,17 @@ encodeCardanoLedgerState encodeExt cls = mconcat [ encodeExt (clsState cls) , toCBOR (clsEpochBlockNo cls) + , valuesMKEncoder (clsState cls) (clsTables cls) ] decodeCardanoLedgerState :: (forall s. Decoder s (ExtLedgerState CardanoBlock EmptyMK)) -> (forall s. Decoder s CardanoLedgerState) decodeCardanoLedgerState decodeExt = do - ldgrState <- decodeExt - let ldgrTables = Consensus.projectLedgerTables (Consensus.unstowLedgerTables ldgrState) - CardanoLedgerState ldgrState ldgrTables <$> fromCBOR + lState <- decodeExt + eBlockNo <- fromCBOR + lTables <- valuesMKDecoder lState + pure $ CardanoLedgerState lState lTables eBlockNo data LedgerStateFile = LedgerStateFile { lsfSlotNo :: !SlotNo From c046698079500490072e925b6a59cf410703db17 Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Thu, 4 Sep 2025 13:59:43 +0300 Subject: [PATCH 3/5] Fix tests --- cardano-chain-gen/src/Cardano/Mock/Chain.hs | 6 +-- cardano-chain-gen/src/Cardano/Mock/ChainDB.hs | 30 +++++++++---- .../src/Cardano/Mock/ChainSync/Server.hs | 7 ++-- .../src/Cardano/Mock/ChainSync/State.hs | 3 +- .../src/Cardano/Mock/Forging/Interpreter.hs | 42 ++++++++++--------- .../Mock/Forging/Tx/Conway/Scenarios.hs | 4 +- .../test/Test/Cardano/Db/Mock/Config.hs | 4 +- .../test/Test/Cardano/Db/Mock/UnifiedApi.hs | 26 ++++++------ .../test/Test/Cardano/Db/Mock/Unit/Conway.hs | 18 ++++---- 9 files changed, 77 insertions(+), 63 deletions(-) diff --git a/cardano-chain-gen/src/Cardano/Mock/Chain.hs b/cardano-chain-gen/src/Cardano/Mock/Chain.hs index 8985fada7..73469a543 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Chain.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Chain.hs @@ -18,7 +18,7 @@ module Cardano.Mock.Chain ( ) where import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Ledger.Basics (ValuesMK) +import Ouroboros.Consensus.Ledger.Basics (EmptyMK, ValuesMK) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block @@ -30,9 +30,9 @@ data Chain' block st | Chain' block st :> (block, st) deriving (Eq, Ord, Show, Functor) -type State block = Consensus.ExtLedgerState block +type State block = (Consensus.ExtLedgerState block EmptyMK, Consensus.LedgerTables (Consensus.ExtLedgerState block) ValuesMK) -type Chain block = Chain' block (State block ValuesMK) +type Chain block = Chain' block (State block) infixl 5 :> diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs index 33aeae059..ab9464fe9 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs @@ -27,7 +27,8 @@ 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 qualified Ouroboros.Consensus.Ledger.Tables as Consensus +import Ouroboros.Consensus.Ledger.Tables.Utils (applyDiffsMK, forgetLedgerTables, restrictValuesMK) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Network.Block (Tip (..)) @@ -49,7 +50,7 @@ instance Show (Chain block) => Show (ChainDB block) where initChainDB :: TopLevelConfig block -> - State block ValuesMK -> + State block -> ChainDB block initChainDB config st = ChainDB config (Genesis st) @@ -59,7 +60,7 @@ headTip chainDB = Genesis _ -> TipGenesis (_ :> (b, _)) -> Tip (blockSlot b) (blockHash b) (blockNo b) -currentState :: ChainDB block -> State block ValuesMK +currentState :: ChainDB block -> State block currentState chainDB = case cchain chainDB of Genesis st -> st @@ -67,11 +68,12 @@ currentState chainDB = replaceGenesisDB :: ChainDB block -> - State block ValuesMK -> + State block -> ChainDB block replaceGenesisDB chainDB st = chainDB {cchain = Genesis st} extendChainDB :: + forall block. LedgerSupportsProtocol block => ChainDB block -> block -> @@ -79,17 +81,27 @@ extendChainDB :: extendChainDB chainDB blk = do let !chain = cchain chainDB -- Get the current ledger state - !tipState = getTipState chain + (tipState, tables) = getTipState chain -- Apply the block and compute the diffs + keys :: LedgerTables (Consensus.ExtLedgerState block) KeysMK + keys = getBlockKeySets blk + ledgerTables = Consensus.getLedgerTables tables + restrictedTables = restrictValuesMK ledgerTables (Consensus.getLedgerTables keys) + ledgerState = Consensus.withLedgerTables tipState (Consensus.LedgerTables restrictedTables) !diffState = tickThenReapply ComputeLedgerEvents (Consensus.ExtLedgerCfg $ chainConfig chainDB) blk - tipState - -- Apply the diffs - !newTipState = applyDiffs tipState diffState - in chainDB {cchain = chain :> (blk, newTipState)} + ledgerState + !ledgerTables' = + Consensus.LedgerTables + . applyDiffsMK ledgerTables + . Consensus.getLedgerTables + . Consensus.projectLedgerTables + $ diffState + !ledgerState' = forgetLedgerTables diffState + in chainDB {cchain = chain :> (blk, (ledgerState', ledgerTables'))} 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 b121aa0d4..6db91a4ee 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/Server.hs @@ -55,7 +55,6 @@ 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.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) @@ -117,7 +116,7 @@ data ServerHandle m blk = ServerHandle , forkAgain :: m (Async ()) } -replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk ValuesMK -> STM m () +replaceGenesis :: MonadSTM m => ServerHandle m blk -> State blk -> STM m () replaceGenesis handle st = modifyTVar (chainProducerState handle) $ \cps -> cps {chainDB = replaceGenesisDB (chainDB cps) st} @@ -180,7 +179,7 @@ forkServerThread :: MockServerConstraint blk => IOManager -> TopLevelConfig blk -> - State blk ValuesMK -> + State blk -> NetworkMagic -> FilePath -> IO (ServerHandle IO blk) @@ -195,7 +194,7 @@ withServerHandle :: MockServerConstraint blk => IOManager -> TopLevelConfig blk -> - State blk ValuesMK -> + State blk -> 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 99b9e0142..255e0dbfd 100644 --- a/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs +++ b/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs @@ -24,7 +24,6 @@ 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.Consensus.Ledger.Tables (ValuesMK) import Ouroboros.Network.Block (ChainUpdate (..)) data ChainProducerState block = ChainProducerState @@ -56,7 +55,7 @@ data FollowerNext initChainProducerState :: TopLevelConfig block -> - Chain.State block ValuesMK -> + Chain.State block -> ChainProducerState block initChainProducerState config st = ChainProducerState (initChainDB config st) Map.empty 0 diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs index 473b5915c..5e8457a41 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Interpreter.hs @@ -12,6 +12,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Mock.Forging.Interpreter ( + InterpreterState (..), Interpreter, initInterpreter, withInterpreter, @@ -95,8 +96,8 @@ import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as Consensus 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 (..), ValuesMK) +import Ouroboros.Consensus.Ledger.Abstract (TickedLedgerState, applyChainTick, projectLedgerTables, stowLedgerTables, withLedgerTables) +import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), EmptyMK, ValuesMK) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, headerState, ledgerState) import Ouroboros.Consensus.Ledger.SupportsMempool ( ApplyTxErr, @@ -235,12 +236,14 @@ initInterpreter :: initInterpreter pinfo forging traceForge mFingerprintFile = do let topLeverCfg = pInfoConfig pinfo let initSt = pInfoInitLedger pinfo - let ledgerView' = mkForecast topLeverCfg initSt + let st = forgetLedgerTables initSt + let tables = projectLedgerTables initSt + let ledgerView' = mkForecast topLeverCfg st (mode, fingerprint) <- mkFingerprint mFingerprintFile stvar <- newTVarIO $ InterpreterState - { istChain = initChainDB topLeverCfg initSt + { istChain = initChainDB topLeverCfg (st, tables) , istForecast = ledgerView' , istSlot = SlotNo 0 , -- The first real Byron block (ie block that can contain txs) is number 1. @@ -323,7 +326,7 @@ forgeNextLeaders interpreter txes possibleLeaders = do interState <- getCurrentInterpreterState interpreter (blk, fingerprint) <- tryOrValidateSlot interState possibleLeaders let !chain' = extendChainDB (istChain interState) blk - let !newSt = currentState chain' + let (newSt, _) = currentState chain' let newInterState = InterpreterState { istChain = chain' @@ -363,7 +366,7 @@ 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 ledgerState' = ledgerState $ currentState (istChain interState) + let ledgerState' = ledgerState $ fst $ currentState (istChain interState) tickedLedgerSt = applyChainTick @@ -424,7 +427,7 @@ tryAllForging interpreter interState currentSlot xs = do (configConsensus cfg) ledgerView' currentSlot - (headerStateChainDep (headerState $ currentState $ istChain interState)) + (headerStateChainDep (headerState $ fst $ currentState $ istChain interState)) !shouldForge <- checkShouldForge @@ -455,7 +458,7 @@ rollbackInterpreter interpreter pnt = do !chain' <- case rollbackChainDB (istChain interState) pnt of Just c -> pure c Nothing -> throwIO RollbackFailed - let newSt = currentState chain' + let (newSt, _) = currentState chain' let tip = headTip chain' let (nextSlot, nextBlock) = case tip of TipGenesis -> (SlotNo 0, BlockNo 1) @@ -463,7 +466,7 @@ rollbackInterpreter interpreter pnt = do let !newInterState = InterpreterState { istChain = chain' - , istForecast = mkForecast cfg newSt + , istForecast = mkForecast cfg $ forgetLedgerTables newSt , istSlot = nextSlot , istNextBlockNo = nextBlock , istFingerprint = istFingerprint interState @@ -476,8 +479,10 @@ rollbackInterpreter interpreter pnt = do getCurrentInterpreterState :: Interpreter -> IO InterpreterState getCurrentInterpreterState = readTVarIO . interpState -getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock ValuesMK) -getCurrentLedgerState = fmap (currentState . istChain) . getCurrentInterpreterState +getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock EmptyMK) +getCurrentLedgerState = fmap (stow . currentState . istChain) . getCurrentInterpreterState + where + stow (st, tables) = stowLedgerTables $ st `withLedgerTables` tables getNextBlockNo :: Interpreter -> IO BlockNo getNextBlockNo inter = @@ -500,7 +505,7 @@ getCurrentSlot interp = istSlot <$> readTVarIO (interpState interp) withBabbageLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> Either ForgingError a) -> + (LedgerState (ShelleyBlock PraosStandard BabbageEra) EmptyMK -> Either ForgingError a) -> IO a withBabbageLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -512,7 +517,7 @@ withBabbageLedgerState inter mk = do withConwayLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK -> Either ForgingError a) -> + (LedgerState (ShelleyBlock PraosStandard ConwayEra) EmptyMK -> Either ForgingError a) -> IO a withConwayLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -524,7 +529,7 @@ withConwayLedgerState inter mk = do withAlonzoLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK -> Either ForgingError a) -> + (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK -> Either ForgingError a) -> IO a withAlonzoLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -536,7 +541,7 @@ withAlonzoLedgerState inter mk = do withShelleyLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> Either ForgingError a) -> + (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) EmptyMK -> Either ForgingError a) -> IO a withShelleyLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -628,12 +633,9 @@ mkValidated txe = mkForecast :: TopLevelConfig CardanoBlock -> - ExtLedgerState CardanoBlock ValuesMK -> + ExtLedgerState CardanoBlock mk -> Forecast (LedgerView (BlockProtocol CardanoBlock)) -mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st') - where - st' :: ExtLedgerState CardanoBlock ValuesMK - st' = st +mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st) throwLeftIO :: Exception e => Either e a -> IO a throwLeftIO = either throwIO pure 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 eb862a471..06b2e6e53 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,7 +31,7 @@ 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.Ledger.Basics (EmptyMK) import Ouroboros.Consensus.Shelley.Eras (ConwayEra ()) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock ()) import qualified Prelude @@ -87,7 +87,7 @@ mkPaymentBlocks utxoIx addresses interpreter = forgeBlocksChunked :: Interpreter -> [a] -> - ([a] -> ShelleyLedgerState ConwayEra ValuesMK -> Either ForgingError (Tx ConwayEra)) -> + ([a] -> ShelleyLedgerState ConwayEra EmptyMK -> Either ForgingError (Tx ConwayEra)) -> IO [CardanoBlock] forgeBlocksChunked interpreter vs f = forM (chunksOf 500 vs) $ \blockCreds -> do blockTxs <- withConwayLedgerState interpreter $ \state' -> diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs index 956173f27..121de9aed 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Config.hs @@ -97,6 +97,8 @@ import Ouroboros.Consensus.Block.Forging import Ouroboros.Consensus.Byron.Ledger.Mempool () import Ouroboros.Consensus.Config (TopLevelConfig) import Ouroboros.Consensus.HardFork.Combinator.Mempool () +import Ouroboros.Consensus.Ledger.Abstract (projectLedgerTables) +import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import Ouroboros.Consensus.Shelley.Ledger.Mempool () @@ -565,7 +567,7 @@ withFullConfig' WithConfigArgs {..} cmdLineArgs mSyncNodeConfig configFilePath t withServerHandle @CardanoBlock iom (topLevelConfig cfg) - initSt + (forgetLedgerTables initSt, projectLedgerTables initSt) (NetworkMagic 42) (unSocketPath (enpSocketPath $ syncNodeParams cfg)) $ \mockServer -> 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 ae197bd10..9decefaf3 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, ValuesMK) +import Ouroboros.Consensus.Ledger.Basics (EmptyMK, LedgerState) 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) ValuesMK -> + ( LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK -> 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) ValuesMK -> Either ForgingError [Core.Tx BabbageEra]) -> + (LedgerState (ShelleyBlock PraosStandard BabbageEra) EmptyMK -> 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) ValuesMK -> Either ForgingError [Core.Tx ConwayEra]) -> + (LedgerState (ShelleyBlock PraosStandard ConwayEra) EmptyMK -> 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) ValuesMK -> + ( LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK -> Either ForgingError (Core.Tx AlonzoEra) ) -> IO CardanoBlock @@ -109,7 +109,7 @@ withAlonzoFindLeaderAndSubmitTx interpreter mockServer mkTxs = do withBabbageFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK -> + ( LedgerState (ShelleyBlock PraosStandard BabbageEra) EmptyMK -> Either ForgingError (Core.Tx BabbageEra) ) -> IO CardanoBlock @@ -121,7 +121,7 @@ withBabbageFindLeaderAndSubmitTx interpreter mockServer mkTxs = do withConwayFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK -> + ( LedgerState (ShelleyBlock PraosStandard ConwayEra) EmptyMK -> Either ForgingError (Core.Tx ConwayEra) ) -> IO CardanoBlock @@ -133,7 +133,7 @@ withConwayFindLeaderAndSubmitTx interpreter mockServer mkTx = withShelleyFindLeaderAndSubmit :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> + ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) EmptyMK -> Either ForgingError [Core.Tx ShelleyEra] ) -> IO CardanoBlock @@ -144,7 +144,7 @@ withShelleyFindLeaderAndSubmit interpreter mockServer mkTxs = do withShelleyFindLeaderAndSubmitTx :: Interpreter -> ServerHandle IO CardanoBlock -> - ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK -> + ( LedgerState (ShelleyBlock TPraosStandard ShelleyEra) EmptyMK -> Either ForgingError (Core.Tx ShelleyEra) ) -> IO CardanoBlock @@ -153,16 +153,16 @@ withShelleyFindLeaderAndSubmitTx interpreter mockServer mkTxs = tx <- mkTxs st pure [tx] -getShelleyLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) ValuesMK) +getShelleyLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) EmptyMK) getShelleyLedgerState interpreter = withShelleyLedgerState interpreter Right -getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) ValuesMK) +getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK) getAlonzoLedgerState interpreter = withAlonzoLedgerState interpreter Right -getBabbageLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard BabbageEra) ValuesMK) +getBabbageLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard BabbageEra) EmptyMK) getBabbageLedgerState interpreter = withBabbageLedgerState interpreter Right -getConwayLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard ConwayEra) ValuesMK) +getConwayLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard ConwayEra) EmptyMK) getConwayLedgerState interpreter = withConwayLedgerState interpreter Right skipUntilNextEpoch :: Interpreter -> ServerHandle IO CardanoBlock -> [TxEra] -> IO CardanoBlock diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs index 96fb45ec8..da0b68088 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway.hs @@ -34,6 +34,15 @@ unitTests iom knownMigrations = , testCase "mismatched conway genesis hash" Config.wrongConwayGenesisHash , testCase "default insert config" Config.defaultInsertConfig , testCase "insert config" Config.insertConfig + , testGroup + "simple" + [ test "simple forge blocks" Simple.forgeBlocks + , test "sync one block" Simple.addSimple + , test "sync small chain" Simple.addSimpleChain + , test "restart db-sync" Simple.restartDBSync + , test "node restart" Simple.nodeRestart + , test "node restart boundary" Simple.nodeRestartBoundary + ] , testGroup "jsonb-in-schema" [ test "jsonb in schema true" Config.configRemoveJsonbFromSchemaEnabled @@ -86,15 +95,6 @@ unitTests iom knownMigrations = $ MigrateConsumedPruneTxOut.populateDbRestartWithAddressConfig iom knownMigrations ] ] - , testGroup - "simple" - [ test "simple forge blocks" Simple.forgeBlocks - , test "sync one block" Simple.addSimple - , test "sync small chain" Simple.addSimpleChain - , test "restart db-sync" Simple.restartDBSync - , test "node restart" Simple.nodeRestart - , test "node restart boundary" Simple.nodeRestartBoundary - ] , testGroup "Command Line Arguments" [ testGroup From 383a60d1d1e3e8e8ea12342997411efdc6ddfbb0 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Thu, 11 Sep 2025 14:42:49 -0400 Subject: [PATCH 4/5] Fix nix devShell ghc912 musl Fixes the following error: > error: executing '/nix/store/xy4jjgw87sbgwylm5kn047d9gkbhsr9x-bash-5.2p37/bin/bash': > Argument list too long We are attempting to reduce the number of packages required for the shell by disabling haddock and hoogle. Longer term, it would be better to disable devShells for cross builds entirely. --- flake.nix | 53 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 22 deletions(-) diff --git a/flake.nix b/flake.nix index 7346234a9..c5052df26 100644 --- a/flake.nix +++ b/flake.nix @@ -186,24 +186,30 @@ "https://chap.intersectmbo.org/" = inputs.CHaP; }; - shell.tools = { - cabal = "latest"; - fourmolu = "latest"; - haskell-language-server = { - src = nixpkgs.haskell-nix.sources."hls-2.11"; + shell = { + tools = { + cabal = "latest"; + fourmolu = "latest"; + hlint = "latest"; + + haskell-language-server = { + src = nixpkgs.haskell-nix.sources."hls-2.11"; + }; + } // lib.optionalAttrs (config.compiler-nix-name == "ghc967") { + weeder = "latest"; }; - hlint = "latest"; - } // lib.optionalAttrs (config.compiler-nix-name == "ghc967") { - weeder = "latest"; + + # Now we use pkgsBuildBuild, to make sure that even in the cross + # compilation setting, we don't run into issues where we pick tools + # for the target. + buildInputs = with nixpkgs.pkgsBuildBuild; [ + git + ]; + + withHoogle = true; + + crossPlatforms = _: []; }; - # Now we use pkgsBuildBuild, to make sure that even in the cross - # compilation setting, we don't run into issues where we pick tools - # for the target. - shell.buildInputs = with nixpkgs.pkgsBuildBuild; [ - gitAndTools.git - ]; - shell.withHoogle = true; - shell.crossPlatforms = _: []; modules = [ ({ lib, pkgs, ... }: { @@ -212,7 +218,7 @@ packages.katip.doExactConfig = true; # Split data to reduce closure size packages.ekg.components.library.enableSeparateDataOutput = true; - # Haddock is failing for these two packages (at least with GHC 8.10.7) + # Haddock is failing for these two packages (at least with GHC 8.10.7) packages.ouroboros-network.doHaddock = config.compiler-nix-name != "ghc8107"; packages.cardano-node.doHaddock = config.compiler-nix-name != "ghc8107"; }) @@ -232,11 +238,11 @@ }) ({ lib, pkgs, config, ... }: { - # lib:ghc is a bit annoying in that it comes with it's own build-type:Custom, and then tries - # to call out to all kinds of silly tools that GHC doesn't really provide. - # For this reason, we try to get away without re-installing lib:ghc for now. - reinstallableLibGhc = false; - }) + # lib:ghc is a bit annoying in that it comes with it's own build-type:Custom, and then tries + # to call out to all kinds of silly tools that GHC doesn't really provide. + # For this reason, we try to get away without re-installing lib:ghc for now. + reinstallableLibGhc = false; + }) (pkgs.lib.mkIf pkgs.hostPlatform.isMusl (let @@ -267,6 +273,9 @@ packages.cardano-db.ghcOptions = ghcOptions; packages.cardano-db-tool.ghcOptions = ghcOptions; packages.cardano-smash-server.ghcOptions = ghcOptions; + + doHoogle = false; + doHaddock = false; })) ({ From 9402ddc02d15b064313b73266f9dffeef74a8817 Mon Sep 17 00:00:00 2001 From: Sean D Gillespie Date: Thu, 11 Sep 2025 14:54:15 -0400 Subject: [PATCH 5/5] Update PR CI workflow: Drop GHC 8.10 and add 9.10 GHC 8.10 was dropped from Hydra (CI) some time ago, so it needs to be dropped from GitHub CI too. GHC 9.10 was broken a while ago in the upstream devShell (input-output-hk/devx), but hopefully it is fixed now. --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 6aca50a07..bd0b53db3 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -20,7 +20,7 @@ jobs: matrix: os: [ubuntu-latest] # TODO: Add ghc910 when input-output-hk/devx is fixed - compiler-nix-name: [ghc810, ghc96, ghc98, ghc912] + compiler-nix-name: [ghc96, ghc98, ghc910, ghc912] include: # We want a single job, because macOS runners are scarce. - os: macos-latest