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 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..73469a543 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 (EmptyMK, ValuesMK) import qualified Ouroboros.Consensus.Ledger.Extended as Consensus import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block @@ -28,7 +30,7 @@ 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) diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs b/cardano-chain-gen/src/Cardano/Mock/ChainDB.hs index c281adb3b..ab9464fe9 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,15 @@ 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 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 (..)) -- | Thin layer around 'Chain' that knows how to apply blocks and maintain @@ -41,7 +48,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 -> + ChainDB block initChainDB config st = ChainDB config (Genesis st) headTip :: HasHeader block => ChainDB block -> Tip block @@ -56,14 +66,42 @@ currentState chainDB = Genesis st -> st _ :> (_, st) -> st -replaceGenesisDB :: ChainDB block -> State block -> ChainDB block +replaceGenesisDB :: + ChainDB block -> + State block -> + ChainDB block replaceGenesisDB chainDB st = chainDB {cchain = Genesis st} -extendChainDB :: LedgerSupportsProtocol block => ChainDB block -> block -> ChainDB block +extendChainDB :: + forall block. + 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, 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 + 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 d742e5865..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,7 @@ import Network.TypedProtocol.Stateful.Codec () import qualified Network.TypedProtocol.Stateful.Peer as St import Ouroboros.Consensus.Block (CodecConfig, HasHeader, Point, StandardHash, castPoint) import Ouroboros.Consensus.Config (TopLevelConfig, configCodec) -import Ouroboros.Consensus.Ledger.Query (BlockQuery, ShowQuery) +import Ouroboros.Consensus.Ledger.Query (BlockQuery, 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) @@ -125,12 +125,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 +161,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,7 +176,6 @@ type MockServerConstraint blk = ) forkServerThread :: - forall blk. MockServerConstraint blk => IOManager -> TopLevelConfig blk -> @@ -183,7 +191,6 @@ forkServerThread iom config initSt netMagic path = do pure $ ServerHandle chainSt threadVar runThread withServerHandle :: - forall blk a. MockServerConstraint blk => IOManager -> TopLevelConfig blk -> diff --git a/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs b/cardano-chain-gen/src/Cardano/Mock/ChainSync/State.hs index 3b4e4b57a..255e0dbfd 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 #-} @@ -52,7 +53,10 @@ data FollowerNext | FollowerForwardFrom deriving (Eq, Show) -initChainProducerState :: TopLevelConfig block -> Chain.State block -> ChainProducerState block +initChainProducerState :: + TopLevelConfig block -> + Chain.State block -> + 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..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, @@ -81,20 +82,22 @@ 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 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.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, @@ -104,6 +107,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 +122,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 +236,15 @@ 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 - , istForecast = ledgerView + { istChain = initChainDB topLeverCfg (st, tables) + , istForecast = ledgerView' , istSlot = SlotNo 0 , -- The first real Byron block (ie block that can contain txs) is number 1. istNextBlockNo = BlockNo 1 @@ -320,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' @@ -360,20 +366,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 $ fst $ 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 +392,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 +413,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,9 +425,9 @@ tryAllForging interpreter interState currentSlot xs = do !tickedChainDepState = tickChainDepState (configConsensus cfg) - ledgerView + ledgerView' currentSlot - (headerStateChainDep (headerState $ currentState $ istChain interState)) + (headerStateChainDep (headerState $ fst $ currentState $ istChain interState)) !shouldForge <- checkShouldForge @@ -450,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) @@ -458,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 @@ -471,8 +479,10 @@ rollbackInterpreter interpreter pnt = do getCurrentInterpreterState :: Interpreter -> IO InterpreterState getCurrentInterpreterState = readTVarIO . interpState -getCurrentLedgerState :: Interpreter -> IO (ExtLedgerState CardanoBlock) -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 = @@ -495,7 +505,7 @@ getCurrentSlot interp = istSlot <$> readTVarIO (interpState interp) withBabbageLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock PraosStandard BabbageEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock PraosStandard BabbageEra) EmptyMK -> Either ForgingError a) -> IO a withBabbageLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -507,7 +517,7 @@ withBabbageLedgerState inter mk = do withConwayLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock PraosStandard ConwayEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock PraosStandard ConwayEra) EmptyMK -> Either ForgingError a) -> IO a withConwayLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -519,7 +529,7 @@ withConwayLedgerState inter mk = do withAlonzoLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK -> Either ForgingError a) -> IO a withAlonzoLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -531,7 +541,7 @@ withAlonzoLedgerState inter mk = do withShelleyLedgerState :: Interpreter -> - (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) -> Either ForgingError a) -> + (LedgerState (ShelleyBlock TPraosStandard ShelleyEra) EmptyMK -> Either ForgingError a) -> IO a withShelleyLedgerState inter mk = do st <- getCurrentLedgerState inter @@ -623,7 +633,7 @@ mkValidated txe = mkForecast :: TopLevelConfig CardanoBlock -> - ExtLedgerState CardanoBlock -> + ExtLedgerState CardanoBlock mk -> Forecast (LedgerView (BlockProtocol CardanoBlock)) mkForecast cfg st = ledgerViewForecastAt (configLedger cfg) (ledgerState st) 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..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,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 (EmptyMK) 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 EmptyMK -> 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/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 8273f1c2a..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) +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) -> + ( 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) -> 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) -> 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) -> + ( LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK -> 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) EmptyMK -> + 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) EmptyMK -> + 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) EmptyMK -> 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) EmptyMK -> 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) EmptyMK) getShelleyLedgerState interpreter = withShelleyLedgerState interpreter Right -getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard AlonzoEra)) +getAlonzoLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock TPraosStandard AlonzoEra) EmptyMK) getAlonzoLedgerState interpreter = withAlonzoLedgerState interpreter Right -getBabbageLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard BabbageEra)) +getBabbageLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard BabbageEra) EmptyMK) getBabbageLedgerState interpreter = withBabbageLedgerState interpreter Right -getConwayLedgerState :: Interpreter -> IO (LedgerState (ShelleyBlock PraosStandard ConwayEra)) +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 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..f31d88fdd 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,7 +49,9 @@ 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 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 (..)) @@ -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,19 +105,25 @@ 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) , toCBOR (clsEpochBlockNo cls) + , valuesMKEncoder (clsState cls) (clsTables 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 + lState <- decodeExt + eBlockNo <- fromCBOR + lTables <- valuesMKDecoder lState + pure $ CardanoLedgerState lState lTables eBlockNo data LedgerStateFile = LedgerStateFile { lsfSlotNo :: !SlotNo @@ -201,12 +211,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 +225,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 +240,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 +255,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 +270,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 +285,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 +300,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 +322,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 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; })) ({