diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 1807e65b7e..f2be56aad6 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -80,6 +80,19 @@ jobs: with: use-sodium-vrf: true # default is true + - name: Linux install lmdb + if: matrix.sys.os == 'ubuntu-latest' + run: sudo apt install liblmdb-dev + + - name: Mac install lmdb + if: matrix.sys.os == 'macos-latest' + run: brew install lmdb + + - name: Windows install lmdb + if: matrix.sys.os == 'windows-latest' + shell: 'C:/msys64/usr/bin/bash.exe -e {0}' + run: /usr/bin/pacman --noconfirm -S mingw-w64-x86_64-lmdb + - uses: actions/checkout@v4 - name: Cabal update diff --git a/cabal.project b/cabal.project index 995fd5d99b..57f56d8747 100644 --- a/cabal.project +++ b/cabal.project @@ -13,7 +13,7 @@ repository cardano-haskell-packages -- See CONTRIBUTING for information about these, including some Nix commands -- you need to run if you change them index-state: - , hackage.haskell.org 2024-12-24T12:56:48Z + , hackage.haskell.org 2024-12-31T10:16:13Z , cardano-haskell-packages 2025-01-08T16:35:32Z packages: @@ -54,3 +54,60 @@ semaphore: True constraints: Cabal < 3.14, + +-- UTxO-HD for 10.2 +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-consensus + tag: 54ac1b2f5bd15f3f0f70e9f4a9ebf3e34792dcf2 + --sha256: sha256-PdzKg4PA6DnzhRVUF2kiBfvf8S+ekXmws73XDXSZdnY= + subdir: + ouroboros-consensus + ouroboros-consensus-cardano + ouroboros-consensus-diffusion + ouroboros-consensus-protocol + sop-extras + strict-sop-core + +-- mempack support +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-base.git + tag: fb9b71f3bc33f8de673c6427736f09bf7972e81f + subdir: + cardano-crypto-class + --sha256: sha256-ExQ497FDYlmQyZaXOTddU+KraAUHnTAqPiyt055v0+M= + +-- mempack support +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: c50d89688d9f30ea2dbd01afb19dbcaaf03e3da7 + --sha256: sha256-3OVXLYCKSN4HPd3nsObK2mG8mB28AX46vuMqs+Jn3kw= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/babbage/test-suite + eras/conway/impl + eras/conway/test-suite + eras/mary/impl + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + libs/cardano-ledger-api + libs/cardano-ledger-core + libs/cardano-ledger-binary + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/cardano-data + libs/set-algebra + libs/vector-map + eras/byron/chain/executable-spec + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/ledger/impl/test + eras/byron/crypto + eras/byron/crypto/test diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index d57bcad5e4..bcaca30d26 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -220,8 +220,10 @@ library internal safe-exceptions, scientific, serialise, + singletons, small-steps ^>=1.1, sop-core, + sop-extras, stm, strict-sop-core, time, diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index a8175a074a..09dbedd913 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -34,6 +34,7 @@ module Cardano.Api.LedgerState , applyBlockWithEvents , AnyNewEpochState (..) , getAnyNewEpochState + , getUTxOValues -- * Traversing the block chain , foldBlocks @@ -119,6 +120,7 @@ import Cardano.Api.Query (CurrentEpochState (..), PoolDistribution (un decodeCurrentEpochState, decodePoolDistribution, decodeProtocolState) import qualified Cardano.Api.ReexposeLedger as Ledger import Cardano.Api.SpecialByron as Byron +import Cardano.Api.Tx.Body import Cardano.Api.Utils (textShow) import qualified Cardano.Binary as CBOR @@ -161,18 +163,24 @@ import qualified Ouroboros.Consensus.Cardano.CanHardFork as Consensus import qualified Ouroboros.Consensus.Cardano.Node as Consensus import qualified Ouroboros.Consensus.Config as Consensus import qualified Ouroboros.Consensus.HardFork.Combinator as Consensus -import qualified Ouroboros.Consensus.HardFork.Combinator.AcrossEras as HFC -import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as HFC +import qualified Ouroboros.Consensus.HardFork.Combinator as HFC +import qualified Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common as HFC +import Ouroboros.Consensus.HardFork.Combinator.State.Types import qualified Ouroboros.Consensus.Ledger.Abstract as Ledger import qualified Ouroboros.Consensus.Ledger.Extended as Ledger +import Ouroboros.Consensus.Ledger.Tables (LedgerTables (..)) +import Ouroboros.Consensus.Ledger.Tables.Utils import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..)) +import qualified Ouroboros.Consensus.Protocol.Praos as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus import Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue) +import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos +import qualified Ouroboros.Consensus.Shelley.Eras as Shelley hiding (StandardCrypto) import qualified Ouroboros.Consensus.Shelley.HFEras as Shelley -import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley -import qualified Ouroboros.Consensus.Shelley.Ledger.Query.Types as Consensus -import Ouroboros.Consensus.Storage.Serialisation +import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley +import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley hiding (LedgerState) +import qualified Ouroboros.Consensus.Shelley.Ledger.Query.Types as Shelley import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (WrapLedgerEvent)) import Ouroboros.Network.Block (blockNo) import qualified Ouroboros.Network.Block @@ -208,7 +216,12 @@ import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import qualified Data.Set as Set -import Data.SOP.Strict.NP +import Data.SOP (K (K), (:.:) (Comp)) +import Data.SOP.Functors (Flip (..)) +import Data.SOP.Index +import Data.SOP.Strict (NP (..), fn) +import Data.SOP.Strict.NS +import qualified Data.SOP.Telescope as Telescope import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -262,7 +275,10 @@ data LedgerStateError | UnexpectedLedgerState AnyShelleyBasedEra -- ^ Expected era - (Consensus.CardanoLedgerState Consensus.StandardCrypto) + ( NS + (Current (Flip Consensus.LedgerState Ledger.EmptyMK)) + (Consensus.CardanoEras Consensus.StandardCrypto) + ) -- ^ Ledgerstate from an unexpected era | ByronEraUnsupported | DebugError !String @@ -326,39 +342,39 @@ applyBlock env oldState validationMode = applyBlock' env oldState validationMode . toConsensusBlock pattern LedgerStateByron - :: Ledger.LedgerState Byron.ByronBlock + :: Ledger.LedgerState Byron.ByronBlock Ledger.EmptyMK -> LedgerState -pattern LedgerStateByron st <- LedgerState (Consensus.LedgerStateByron st) +pattern LedgerStateByron st <- LedgerState (Consensus.LedgerStateByron st) _ pattern LedgerStateShelley - :: Ledger.LedgerState Shelley.StandardShelleyBlock + :: Ledger.LedgerState Shelley.StandardShelleyBlock Ledger.EmptyMK -> LedgerState -pattern LedgerStateShelley st <- LedgerState (Consensus.LedgerStateShelley st) +pattern LedgerStateShelley st <- LedgerState (Consensus.LedgerStateShelley st) _ pattern LedgerStateAllegra - :: Ledger.LedgerState Shelley.StandardAllegraBlock + :: Ledger.LedgerState Shelley.StandardAllegraBlock Ledger.EmptyMK -> LedgerState -pattern LedgerStateAllegra st <- LedgerState (Consensus.LedgerStateAllegra st) +pattern LedgerStateAllegra st <- LedgerState (Consensus.LedgerStateAllegra st) _ pattern LedgerStateMary - :: Ledger.LedgerState Shelley.StandardMaryBlock + :: Ledger.LedgerState Shelley.StandardMaryBlock Ledger.EmptyMK -> LedgerState -pattern LedgerStateMary st <- LedgerState (Consensus.LedgerStateMary st) +pattern LedgerStateMary st <- LedgerState (Consensus.LedgerStateMary st) _ pattern LedgerStateAlonzo - :: Ledger.LedgerState Shelley.StandardAlonzoBlock + :: Ledger.LedgerState Shelley.StandardAlonzoBlock Ledger.EmptyMK -> LedgerState -pattern LedgerStateAlonzo st <- LedgerState (Consensus.LedgerStateAlonzo st) +pattern LedgerStateAlonzo st <- LedgerState (Consensus.LedgerStateAlonzo st) _ pattern LedgerStateBabbage - :: Ledger.LedgerState Shelley.StandardBabbageBlock + :: Ledger.LedgerState Shelley.StandardBabbageBlock Ledger.EmptyMK -> LedgerState -pattern LedgerStateBabbage st <- LedgerState (Consensus.LedgerStateBabbage st) +pattern LedgerStateBabbage st <- LedgerState (Consensus.LedgerStateBabbage st) _ pattern LedgerStateConway - :: Ledger.LedgerState Shelley.StandardConwayBlock + :: Ledger.LedgerState Shelley.StandardConwayBlock Ledger.EmptyMK -> LedgerState -pattern LedgerStateConway st <- LedgerState (Consensus.LedgerStateConway st) +pattern LedgerStateConway st <- LedgerState (Consensus.LedgerStateConway st) _ {-# COMPLETE LedgerStateByron @@ -1168,13 +1184,26 @@ readByteString fp cfgType = (liftEither <=< liftIO) $ initLedgerStateVar :: GenesisConfig -> LedgerState initLedgerStateVar genesisConfig = LedgerState - { clsState = Ledger.ledgerState $ Consensus.pInfoInitLedger $ fst protocolInfo + { clsState = + Ledger.ledgerState $ + forgetLedgerTables $ + Consensus.pInfoInitLedger $ + fst protocolInfo + , clsTables = + Ledger.projectLedgerTables $ + Ledger.ledgerState $ + Consensus.pInfoInitLedger $ + fst protocolInfo } where protocolInfo = mkProtocolInfoCardano genesisConfig -newtype LedgerState = LedgerState - { clsState :: Consensus.CardanoLedgerState Consensus.StandardCrypto +data LedgerState = LedgerState + { clsState :: Consensus.CardanoLedgerState Consensus.StandardCrypto Ledger.EmptyMK + , clsTables + :: Ledger.LedgerTables + (Ledger.LedgerState (Consensus.HardForkBlock (Consensus.CardanoEras Consensus.StandardCrypto))) + Ledger.ValuesMK } deriving Show @@ -1183,71 +1212,154 @@ getAnyNewEpochState :: ShelleyBasedEra era -> LedgerState -> Either LedgerStateError AnyNewEpochState -getAnyNewEpochState sbe (LedgerState ls) = - AnyNewEpochState sbe <$> getNewEpochState sbe ls +getAnyNewEpochState sbe (LedgerState ls tbs) = + flip (AnyNewEpochState sbe) tbs <$> getNewEpochState sbe ls getNewEpochState :: ShelleyBasedEra era - -> Consensus.CardanoLedgerState Consensus.StandardCrypto + -> Consensus.CardanoLedgerState Consensus.StandardCrypto Ledger.EmptyMK -> Either LedgerStateError (ShelleyAPI.NewEpochState (ShelleyLedgerEra era)) getNewEpochState era x = do - let err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ AnyShelleyBasedEra era) x + let tip = Telescope.tip $ getHardForkState $ HFC.hardForkLedgerStatePerEra x + err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ AnyShelleyBasedEra era) tip case era of ShelleyBasedEraShelley -> - case x of - Consensus.LedgerStateShelley current -> - pure $ Shelley.shelleyLedgerState current + case tip of + ShelleyLedgerState shelleyCurrent -> + pure $ Shelley.shelleyLedgerState $ unFlip $ currentState shelleyCurrent _ -> Left err ShelleyBasedEraAllegra -> - case x of - Consensus.LedgerStateAllegra current -> - pure $ Shelley.shelleyLedgerState current + case tip of + AllegraLedgerState allegraCurrent -> + pure $ Shelley.shelleyLedgerState $ unFlip $ currentState allegraCurrent _ -> Left err ShelleyBasedEraMary -> - case x of - Consensus.LedgerStateMary current -> - pure $ Shelley.shelleyLedgerState current + case tip of + MaryLedgerState maryCurrent -> + pure $ Shelley.shelleyLedgerState $ unFlip $ currentState maryCurrent _ -> Left err ShelleyBasedEraAlonzo -> - case x of - Consensus.LedgerStateAlonzo current -> - pure $ Shelley.shelleyLedgerState current + case tip of + AlonzoLedgerState alonzoCurrent -> + pure $ Shelley.shelleyLedgerState $ unFlip $ currentState alonzoCurrent _ -> Left err ShelleyBasedEraBabbage -> - case x of - Consensus.LedgerStateBabbage current -> - pure $ Shelley.shelleyLedgerState current + case tip of + BabbageLedgerState babbageCurrent -> + pure $ Shelley.shelleyLedgerState $ unFlip $ currentState babbageCurrent _ -> Left err ShelleyBasedEraConway -> - case x of - Consensus.LedgerStateConway current -> - pure $ Shelley.shelleyLedgerState current + case tip of + ConwayLedgerState conwayCurrent -> + pure $ Shelley.shelleyLedgerState $ unFlip $ currentState conwayCurrent _ -> Left err -encodeLedgerState - :: Consensus.CardanoCodecConfig Consensus.StandardCrypto - -> LedgerState - -> CBOR.Encoding -encodeLedgerState ccfg (LedgerState st) = - encodeDisk @(Consensus.CardanoBlock Consensus.StandardCrypto) ccfg st +{-# COMPLETE + ShelleyLedgerState + , AllegraLedgerState + , MaryLedgerState + , AlonzoLedgerState + , BabbageLedgerState + , ConwayLedgerState + #-} -decodeLedgerState - :: Consensus.CardanoCodecConfig Consensus.StandardCrypto - -> forall s - . CBOR.Decoder s LedgerState -decodeLedgerState ccfg = - LedgerState <$> decodeDisk @(Consensus.CardanoBlock Consensus.StandardCrypto) ccfg +pattern ShelleyLedgerState + :: Current + (Flip Consensus.LedgerState mk) + ( Shelley.ShelleyBlock + (TPraos.TPraos Ledger.StandardCrypto) + (Shelley.ShelleyEra Ledger.StandardCrypto) + ) + -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) +pattern ShelleyLedgerState x = S (Z x) + +pattern AllegraLedgerState + :: Current + (Flip Consensus.LedgerState mk) + ( Shelley.ShelleyBlock + (TPraos.TPraos Ledger.StandardCrypto) + (Shelley.AllegraEra Ledger.StandardCrypto) + ) + -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) +pattern AllegraLedgerState x = S (S (Z x)) + +pattern MaryLedgerState + :: Current + (Flip Consensus.LedgerState mk) + (Shelley.ShelleyBlock (TPraos.TPraos Ledger.StandardCrypto) (Shelley.MaryEra Ledger.StandardCrypto)) + -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) +pattern MaryLedgerState x = S (S (S (Z x))) + +pattern AlonzoLedgerState + :: Current + (Flip Consensus.LedgerState mk) + (Shelley.ShelleyBlock (TPraos.TPraos Ledger.StandardCrypto) (Shelley.AlonzoEra Ledger.StandardCrypto)) + -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) +pattern AlonzoLedgerState x = S (S (S (S (Z x)))) + +pattern BabbageLedgerState + :: Current + (Flip Consensus.LedgerState mk) + ( Shelley.ShelleyBlock + (Consensus.Praos Ledger.StandardCrypto) + (Shelley.BabbageEra Ledger.StandardCrypto) + ) + -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) +pattern BabbageLedgerState x = S (S (S (S (S (Z x))))) + +pattern ConwayLedgerState + :: Current + (Flip Consensus.LedgerState mk) + ( Shelley.ShelleyBlock + (Consensus.Praos Ledger.StandardCrypto) + (Shelley.ConwayEra Ledger.StandardCrypto) + ) + -> NS (Current (Flip Consensus.LedgerState mk)) (Consensus.CardanoEras Consensus.StandardCrypto) +pattern ConwayLedgerState x = S (S (S (S (S (S (Z x)))))) + +encodeLedgerState :: LedgerState -> CBOR.Encoding +encodeLedgerState (LedgerState (HFC.HardForkLedgerState st) tbs) = + mconcat + [ CBOR.encodeListLen 2 + , HFC.encodeTelescope + (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* Nil) + st + , Ledger.valuesMKEncoder tbs + ] + where + byron = fn (K . Byron.encodeByronLedgerState . unFlip) + shelley = fn (K . Shelley.encodeShelleyLedgerState . unFlip) + allegra = fn (K . Shelley.encodeShelleyLedgerState . unFlip) + mary = fn (K . Shelley.encodeShelleyLedgerState . unFlip) + alonzo = fn (K . Shelley.encodeShelleyLedgerState . unFlip) + babbage = fn (K . Shelley.encodeShelleyLedgerState . unFlip) + conway = fn (K . Shelley.encodeShelleyLedgerState . unFlip) + +decodeLedgerState :: forall s. CBOR.Decoder s LedgerState +decodeLedgerState = do + 2 <- CBOR.decodeListLen + LedgerState . HFC.HardForkLedgerState + <$> HFC.decodeTelescope (byron :* shelley :* allegra :* mary :* alonzo :* babbage :* conway :* Nil) + <*> Ledger.valuesMKDecoder + where + byron = Comp $ Flip <$> Byron.decodeByronLedgerState + shelley = Comp $ Flip <$> Shelley.decodeShelleyLedgerState + allegra = Comp $ Flip <$> Shelley.decodeShelleyLedgerState + mary = Comp $ Flip <$> Shelley.decodeShelleyLedgerState + alonzo = Comp $ Flip <$> Shelley.decodeShelleyLedgerState + babbage = Comp $ Flip <$> Shelley.decodeShelleyLedgerState + conway = Comp $ Flip <$> Shelley.decodeShelleyLedgerState type LedgerStateEvents = (LedgerState, [LedgerEvent]) toLedgerStateEvents :: Ledger.LedgerResult - (Consensus.CardanoLedgerState Consensus.StandardCrypto) - (Consensus.CardanoLedgerState Consensus.StandardCrypto) + (Ledger.LedgerState (Consensus.HardForkBlock (Consensus.CardanoEras Consensus.StandardCrypto))) + LedgerState -> LedgerStateEvents toLedgerStateEvents lr = (ledgerState, ledgerEvents) where - ledgerState = LedgerState (Ledger.lrResult lr) + ledgerState = Ledger.lrResult lr ledgerEvents = mapMaybe ( toLedgerEvent @@ -1640,10 +1752,9 @@ applyBlock' -> Either LedgerStateError LedgerStateEvents applyBlock' env oldState validationMode block = do let config = envLedgerConfig env - stateOld = clsState oldState case validationMode of - FullValidation -> tickThenApply config block stateOld - QuickValidation -> tickThenReapplyCheckHash config block stateOld + FullValidation -> tickThenApply config block oldState + QuickValidation -> tickThenReapplyCheckHash config block oldState applyBlockWithEvents :: Env @@ -1654,23 +1765,46 @@ applyBlockWithEvents -> Either LedgerStateError LedgerStateEvents applyBlockWithEvents env oldState enableValidation block = do let config = envLedgerConfig env - stateOld = clsState oldState if enableValidation - then tickThenApply config block stateOld - else tickThenReapplyCheckHash config block stateOld + then tickThenApply config block oldState + else tickThenReapplyCheckHash config block oldState -- Like 'Consensus.tickThenReapply' but also checks that the previous hash from -- the block matches the head hash of the ledger state. tickThenReapplyCheckHash :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto -> Consensus.CardanoBlock Consensus.StandardCrypto - -> Consensus.CardanoLedgerState Consensus.StandardCrypto + -> LedgerState -> Either LedgerStateError LedgerStateEvents -tickThenReapplyCheckHash cfg block lsb = - if Consensus.blockPrevHash block == Ledger.ledgerTipHash lsb +tickThenReapplyCheckHash cfg block (LedgerState st tbs) = + if Consensus.blockPrevHash block == Ledger.ledgerTipHash st then - Right . toLedgerStateEvents $ - Ledger.tickThenReapplyLedgerResult cfg block lsb + let + keys + :: LedgerTables (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) Ledger.KeysMK + keys = Ledger.getBlockKeySets block + + restrictedTables = + LedgerTables (restrictValuesMK (getLedgerTables tbs) (getLedgerTables keys)) + + ledgerResult = + Ledger.tickThenReapplyLedgerResult cfg block $ + st `Ledger.withLedgerTables` restrictedTables + in + Right + . toLedgerStateEvents + . fmap + ( \stt -> + LedgerState + (forgetLedgerTables stt) + ( LedgerTables + . applyDiffsMK (getLedgerTables tbs) + . getLedgerTables + . Ledger.projectLedgerTables + $ stt + ) + ) + $ ledgerResult else Left $ ApplyBlockHashMismatch $ @@ -1680,11 +1814,11 @@ tickThenReapplyCheckHash cfg block lsb = Slot.unSlotNo $ Slot.fromWithOrigin (Slot.SlotNo 0) - (Ledger.ledgerTipSlot lsb) + (Ledger.ledgerTipSlot st) , " hash " , renderByteArray $ unChainHash $ - Ledger.ledgerTipHash lsb + Ledger.ledgerTipHash st , " but block previous hash is " , renderByteArray (unChainHash $ Consensus.blockPrevHash block) , " and block current hash is " @@ -1700,12 +1834,39 @@ tickThenReapplyCheckHash cfg block lsb = tickThenApply :: Consensus.CardanoLedgerConfig Consensus.StandardCrypto -> Consensus.CardanoBlock Consensus.StandardCrypto - -> Consensus.CardanoLedgerState Consensus.StandardCrypto + -> LedgerState -> Either LedgerStateError LedgerStateEvents -tickThenApply cfg block lsb = - either (Left . ApplyBlockError) (Right . toLedgerStateEvents) $ - runExcept $ - Ledger.tickThenApplyLedgerResult cfg block lsb +tickThenApply cfg block (LedgerState st tbs) = + let + keys + :: LedgerTables (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) Ledger.KeysMK + keys = Ledger.getBlockKeySets block + + restrictedTables = + LedgerTables (restrictValuesMK (getLedgerTables tbs) (getLedgerTables keys)) + + eLedgerResult = + runExcept $ + Ledger.tickThenApplyLedgerResult cfg block $ + st `Ledger.withLedgerTables` restrictedTables + in + either + (Left . ApplyBlockError) + ( Right + . toLedgerStateEvents + . fmap + ( \stt -> + LedgerState + (forgetLedgerTables stt) + ( LedgerTables + . applyDiffsMK (getLedgerTables tbs) + . getLedgerTables + . Ledger.projectLedgerTables + $ stt + ) + ) + ) + eLedgerResult renderByteArray :: ByteArrayAccess bin => bin -> Text renderByteArray = @@ -2017,12 +2178,42 @@ data AnyNewEpochState where AnyNewEpochState :: ShelleyBasedEra era -> ShelleyAPI.NewEpochState (ShelleyLedgerEra era) + -> Ledger.LedgerTables + (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) + Ledger.ValuesMK -> AnyNewEpochState instance Show AnyNewEpochState where - showsPrec p (AnyNewEpochState sbe ledgerNewEpochState) = + showsPrec p (AnyNewEpochState sbe ledgerNewEpochState _) = shelleyBasedEraConstraints sbe $ showsPrec p ledgerNewEpochState +getUTxOValues + :: forall era + . ShelleyBasedEra era + -> Ledger.LedgerTables + (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) + Ledger.ValuesMK + -> Map TxIn (TxOut CtxUTxO era) +getUTxOValues sbe tbs = + let + ejectTables + :: Shelley.EraCrypto (ShelleyLedgerEra era) ~ Consensus.StandardCrypto + => Index + (Consensus.CardanoEras Consensus.StandardCrypto) + (Shelley.ShelleyBlock proto (ShelleyLedgerEra era)) + -> Map TxIn (TxOut CtxUTxO era) + ejectTables idx = + let LedgerTables (Ledger.ValuesMK values) = HFC.ejectLedgerTables idx tbs + in Map.mapKeys (fromShelleyTxIn . Shelley.getShelleyTxIn) $ Map.map (fromShelleyTxOut sbe) values + in + case sbe of + ShelleyBasedEraShelley -> ejectTables (IS IZ) + ShelleyBasedEraAllegra -> ejectTables (IS (IS IZ)) + ShelleyBasedEraMary -> ejectTables (IS (IS (IS IZ))) + ShelleyBasedEraAlonzo -> ejectTables (IS (IS (IS (IS IZ)))) + ShelleyBasedEraBabbage -> ejectTables (IS (IS (IS (IS (IS IZ))))) + ShelleyBasedEraConway -> ejectTables (IS (IS (IS (IS (IS (IS IZ)))))) + -- | Reconstructs the ledger's new epoch state and applies a supplied condition to it for every block. This -- function only terminates if the condition is met or we have reached the termination epoch. We need to -- provide a termination epoch otherwise blocks would be applied indefinitely. @@ -2200,7 +2391,7 @@ foldEpochState nodeConfigFilePath socketPath validationMode terminationEpoch ini let !err = Just e in clientIdle_DoneNwithMaybeError n err Right lState -> do - let newEpochState = AnyNewEpochState sbe lState + let newEpochState = AnyNewEpochState sbe lState (clsTables newLedgerState) -- Run the condition function in an exclusive lock. -- There can be only one place where `takeMVar stateMv` exists otherwise this -- code will deadlock! @@ -2278,19 +2469,19 @@ handleExceptions = liftEither <=< liftIO . runExceptT . flip catches handlers -- WARNING: Do NOT use this function anywhere else except in its current call sites. -- This is a temporary work around. -fromConsensusPoolDistr :: Consensus.PoolDistr c -> SL.PoolDistr c +fromConsensusPoolDistr :: Shelley.PoolDistr c -> SL.PoolDistr c fromConsensusPoolDistr cpd = SL.PoolDistr - { SL.unPoolDistr = Map.map toLedgerIndividualPoolStake $ Consensus.unPoolDistr cpd + { SL.unPoolDistr = Map.map toLedgerIndividualPoolStake $ Shelley.unPoolDistr cpd , SL.pdTotalActiveStake = SL.CompactCoin 0 } -- WARNING: Do NOT use this function anywhere else except in its current call sites. -- This is a temporary work around. -toLedgerIndividualPoolStake :: Consensus.IndividualPoolStake c -> SL.IndividualPoolStake c +toLedgerIndividualPoolStake :: Shelley.IndividualPoolStake c -> SL.IndividualPoolStake c toLedgerIndividualPoolStake ips = SL.IndividualPoolStake - { SL.individualPoolStake = Consensus.individualPoolStake ips - , SL.individualPoolStakeVrf = SL.toVRFVerKeyHash $ Consensus.individualPoolStakeVrf ips + { SL.individualPoolStake = Shelley.individualPoolStake ips + , SL.individualPoolStakeVrf = SL.toVRFVerKeyHash $ Shelley.individualPoolStakeVrf ips , SL.individualTotalPoolStake = SL.CompactCoin 0 } diff --git a/cardano-api/internal/Cardano/Api/Query.hs b/cardano-api/internal/Cardano/Api/Query.hs index 2d1ac760e0..f8e58d138d 100644 --- a/cardano-api/internal/Cardano/Api/Query.hs +++ b/cardano-api/internal/Cardano/Api/Query.hs @@ -128,6 +128,7 @@ import Data.Maybe (mapMaybe) import Data.Sequence (Seq) import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Singletons as Singletons import Data.SOP.Constraint (SListI) import Data.Text (Text) import qualified Data.Text as Text @@ -722,24 +723,25 @@ toConsensusQueryShelleyBased sbe = \case era = toCardanoEra sbe consensusQueryInEraInMode - :: forall era erablock modeblock result result' xs + :: forall era erablock modeblock result result' fp xs . ConsensusBlockForEra era ~ erablock => Consensus.CardanoBlock L.StandardCrypto ~ modeblock => modeblock ~ Consensus.HardForkBlock xs => Consensus.HardForkQueryResult xs result ~ result' + => Singletons.SingI fp => CardanoEra era - -> Consensus.BlockQuery erablock result + -> Consensus.BlockQuery erablock fp result -> Consensus.Query modeblock result' -consensusQueryInEraInMode era = - Consensus.BlockQuery - . case era of - ByronEra -> Consensus.QueryIfCurrentByron - ShelleyEra -> Consensus.QueryIfCurrentShelley - AllegraEra -> Consensus.QueryIfCurrentAllegra - MaryEra -> Consensus.QueryIfCurrentMary - AlonzoEra -> Consensus.QueryIfCurrentAlonzo - BabbageEra -> Consensus.QueryIfCurrentBabbage - ConwayEra -> Consensus.QueryIfCurrentConway +consensusQueryInEraInMode erainmode b = + Consensus.BlockQuery @fp $ + case erainmode of + ByronEra -> Consensus.QueryIfCurrentByron b + ShelleyEra -> Consensus.QueryIfCurrentShelley b + AllegraEra -> Consensus.QueryIfCurrentAllegra b + MaryEra -> Consensus.QueryIfCurrentMary b + AlonzoEra -> Consensus.QueryIfCurrentAlonzo b + BabbageEra -> Consensus.QueryIfCurrentBabbage b + ConwayEra -> Consensus.QueryIfCurrentConway b -- ---------------------------------------------------------------------------- -- Conversions of query results from the consensus types. @@ -862,14 +864,14 @@ fromConsensusQueryResult (QueryInEra (QueryInShelleyBasedEra ShelleyBasedEraConw -- on the @QueryInShelleyBasedEra era result@ value. Don't change the top-level -- @case sbeQuery of ...@! fromConsensusQueryResultShelleyBased - :: forall era ledgerera protocol result result' + :: forall era ledgerera protocol result fp result' . HasCallStack => ShelleyLedgerEra era ~ ledgerera => Core.EraCrypto ledgerera ~ Consensus.StandardCrypto => ConsensusProtocol era ~ protocol => ShelleyBasedEra era -> QueryInShelleyBasedEra era result - -> Consensus.BlockQuery (Consensus.ShelleyBlock protocol ledgerera) result' + -> Consensus.BlockQuery (Consensus.ShelleyBlock protocol ledgerera) fp result' -> result' -> result fromConsensusQueryResultShelleyBased sbe sbeQuery q' r' = diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 4ca9994569..bfd9683542 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -814,6 +814,7 @@ module Cardano.Api , AnyNewEpochState (..) , foldEpochState , getAnyNewEpochState + , getUTxOValues -- *** Errors , LedgerStateError (..)