diff --git a/cabal.project b/cabal.project index 9fe63e3b89..36b0c36f77 100644 --- a/cabal.project +++ b/cabal.project @@ -13,8 +13,8 @@ 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 2025-04-06T22:39:33Z - , cardano-haskell-packages 2025-04-07T00:07:03Z + , hackage.haskell.org 2025-04-08T10:52:25Z + , cardano-haskell-packages 2025-04-16T15:55:07Z packages: cardano-api diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 1e76d5160b..cd602b1c92 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -155,9 +155,9 @@ library network-mux, nothunks, ordered-containers, - ouroboros-consensus ^>=0.24, - ouroboros-consensus-cardano ^>=0.23, - ouroboros-consensus-diffusion ^>=0.19 || ^>=0.21, + ouroboros-consensus ^>=0.25, + ouroboros-consensus-cardano ^>=0.24, + ouroboros-consensus-diffusion ^>=0.22, ouroboros-consensus-protocol ^>=0.11, ouroboros-network, ouroboros-network-api >=0.13, @@ -172,8 +172,10 @@ library safe-exceptions, scientific, serialise, + singletons, small-steps ^>=1.1, sop-core, + sop-extras, stm, strict-sop-core, time, diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 46772341cd..9c2f3be337 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -850,6 +850,7 @@ module Cardano.Api , AnyNewEpochState (..) , foldEpochState , getAnyNewEpochState + , getLedgerTablesUTxOValues -- *** Errors , LedgerStateError (..) diff --git a/cardano-api/src/Cardano/Api/Internal/LedgerState.hs b/cardano-api/src/Cardano/Api/Internal/LedgerState.hs index 8772bf83f8..dbccc9cf04 100644 --- a/cardano-api/src/Cardano/Api/Internal/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/Internal/LedgerState.hs @@ -34,6 +34,7 @@ module Cardano.Api.Internal.LedgerState , applyBlockWithEvents , AnyNewEpochState (..) , getAnyNewEpochState + , getLedgerTablesUTxOValues -- * Traversing the block chain , foldBlocks @@ -130,6 +131,7 @@ import Cardano.Api.Internal.Query ) import Cardano.Api.Internal.ReexposeLedger qualified as Ledger import Cardano.Api.Internal.SpecialByron as Byron +import Cardano.Api.Internal.Tx.Body import Cardano.Api.Internal.Utils (textShow) import Cardano.Binary qualified as CBOR @@ -175,16 +177,24 @@ import Ouroboros.Consensus.Config qualified as Consensus import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus import Ouroboros.Consensus.HardFork.Combinator.AcrossEras qualified as HFC import Ouroboros.Consensus.HardFork.Combinator.Basics qualified as HFC +import Ouroboros.Consensus.HardFork.Combinator.Ledger qualified as HFC +import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common qualified as HFC +import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.Ledger.Abstract qualified as Ledger +import Ouroboros.Consensus.Ledger.Basics qualified as Consensus import Ouroboros.Consensus.Ledger.Extended qualified as Ledger +import Ouroboros.Consensus.Ledger.Tables.Utils qualified as Ledger import Ouroboros.Consensus.Node.ProtocolInfo qualified as Consensus import Ouroboros.Consensus.Protocol.Abstract (ChainDepState, ConsensusProtocol (..)) +import Ouroboros.Consensus.Protocol.Praos qualified as Praos import Ouroboros.Consensus.Protocol.Praos.Common qualified as Consensus import Ouroboros.Consensus.Protocol.Praos.VRF (mkInputVRF, vrfLeaderValue) +import Ouroboros.Consensus.Protocol.TPraos qualified as TPraos import Ouroboros.Consensus.Shelley.HFEras qualified as Shelley +import Ouroboros.Consensus.Shelley.Ledger.Block qualified as Shelley import Ouroboros.Consensus.Shelley.Ledger.Ledger qualified as Shelley import Ouroboros.Consensus.Shelley.Ledger.Query.Types qualified as Consensus -import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.Shelley.Ledger.Query.Types qualified as Shelley import Ouroboros.Consensus.TypeFamilyWrappers (WrapLedgerEvent (WrapLedgerEvent)) import Ouroboros.Network.Block (blockNo) import Ouroboros.Network.Block qualified @@ -222,7 +232,11 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe import Data.Proxy (Proxy (Proxy)) -import Data.SOP.Strict.NP +import Data.SOP.BasicFunctors +import Data.SOP.Functors +import Data.SOP.Index +import Data.SOP.Strict +import Data.SOP.Telescope qualified as Telescope import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Data.Set (Set) @@ -280,7 +294,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 @@ -345,45 +362,45 @@ applyBlock env oldState validationMode = {-# DEPRECATED LedgerStateByron "Use 'LedgerState $ Consensus.LedgerStateByron' instead" #-} 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) _ {-# DEPRECATED LedgerStateShelley "Use 'LedgerState $ Consensus.LedgerStateShelley' instead" #-} 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) _ {-# DEPRECATED LedgerStateAllegra "Use 'LedgerState $ Consensus.LedgerStateAllegra' instead" #-} 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) _ {-# DEPRECATED LedgerStateMary "Use 'LedgerState $ Consensus.LedgerStateMary' instead" #-} 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) _ {-# DEPRECATED LedgerStateAlonzo "Use 'LedgerState $ Consensus.LedgerAlonzo' instead" #-} 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) _ {-# DEPRECATED LedgerStateBabbage "Use 'LedgerState $ Consensus.LedgerBabbage' instead" #-} 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) _ {-# DEPRECATED LedgerStateConway "Use 'LedgerState $ Consensus.LedgerConway' instead" #-} 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 @@ -1196,13 +1213,26 @@ readByteString fp cfgType = (liftEither <=< liftIO) $ initLedgerStateVar :: GenesisConfig -> LedgerState initLedgerStateVar genesisConfig = LedgerState - { clsState = Ledger.ledgerState $ Consensus.pInfoInitLedger $ fst protocolInfo + { clsState = + Ledger.ledgerState $ + Ledger.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 @@ -1211,71 +1241,160 @@ 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) + Consensus.ShelleyEra + ) + -> 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) + Consensus.AllegraEra + ) + -> 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) + Consensus.MaryEra + ) + -> 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) + Consensus.AlonzoEra + ) + -> 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 + (Praos.Praos Ledger.StandardCrypto) + Consensus.BabbageEra + ) + -> 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 + (Praos.Praos Ledger.StandardCrypto) + Consensus.ConwayEra + ) + -> 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 @@ -1668,10 +1787,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 @@ -1682,23 +1800,49 @@ 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 Ledger.ComputeLedgerEvents cfg block lsb + let + keys + :: Consensus.LedgerTables + (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) + Ledger.KeysMK + keys = Ledger.getBlockKeySets block + + restrictedTables = + Consensus.LedgerTables + (Ledger.restrictValuesMK (Ledger.getLedgerTables tbs) (Ledger.getLedgerTables keys)) + + ledgerResult = + Ledger.tickThenReapplyLedgerResult Ledger.ComputeLedgerEvents cfg block $ + st `Ledger.withLedgerTables` restrictedTables + in + Right + . toLedgerStateEvents + . fmap + ( \stt -> + LedgerState + (Ledger.forgetLedgerTables stt) + ( Consensus.LedgerTables + . Ledger.applyDiffsMK (Ledger.getLedgerTables tbs) + . Ledger.getLedgerTables + . Ledger.projectLedgerTables + $ stt + ) + ) + $ ledgerResult else Left $ ApplyBlockHashMismatch $ @@ -1708,11 +1852,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 " @@ -1728,12 +1872,42 @@ 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 Ledger.ComputeLedgerEvents cfg block lsb +tickThenApply cfg block (LedgerState st tbs) = + let + keys + :: Consensus.LedgerTables + (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) + Ledger.KeysMK + keys = Ledger.getBlockKeySets block + + restrictedTables = + Consensus.LedgerTables + (Ledger.restrictValuesMK (Ledger.getLedgerTables tbs) (Ledger.getLedgerTables keys)) + + eLedgerResult = + runExcept $ + Ledger.tickThenApplyLedgerResult Ledger.ComputeLedgerEvents cfg block $ + st `Ledger.withLedgerTables` restrictedTables + in + either + (Left . ApplyBlockError) + ( Right + . toLedgerStateEvents + . fmap + ( \stt -> + LedgerState + (Ledger.forgetLedgerTables stt) + ( Consensus.LedgerTables + . Ledger.applyDiffsMK (Ledger.getLedgerTables tbs) + . Ledger.getLedgerTables + . Ledger.projectLedgerTables + $ stt + ) + ) + ) + eLedgerResult renderByteArray :: ByteArrayAccess bin => bin -> Text renderByteArray = @@ -2045,12 +2219,41 @@ 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 +getLedgerTablesUTxOValues + :: forall era + . ShelleyBasedEra era + -> Ledger.LedgerTables + (Ledger.LedgerState (Consensus.CardanoBlock Consensus.StandardCrypto)) + Ledger.ValuesMK + -> Map TxIn (TxOut CtxUTxO era) +getLedgerTablesUTxOValues sbe tbs = + let + ejectTables + :: Index + (Consensus.CardanoEras Consensus.StandardCrypto) + (Shelley.ShelleyBlock proto (ShelleyLedgerEra era)) + -> Map TxIn (TxOut CtxUTxO era) + ejectTables idx = + let Consensus.LedgerTables (Ledger.ValuesMK values) = HFC.ejectLedgerTables idx tbs + in Map.mapKeys fromShelleyTxIn $ 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. @@ -2229,7 +2432,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! @@ -2310,7 +2513,7 @@ handleExceptions = liftEither <=< liftIO . runExceptT . flip catches handlers fromConsensusPoolDistr :: Consensus.PoolDistr c -> SL.PoolDistr 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 } @@ -2319,7 +2522,7 @@ fromConsensusPoolDistr cpd = toLedgerIndividualPoolStake :: Consensus.IndividualPoolStake c -> SL.IndividualPoolStake 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/src/Cardano/Api/Internal/Query.hs b/cardano-api/src/Cardano/Api/Internal/Query.hs index 02d30281f0..b7db57c883 100644 --- a/cardano-api/src/Cardano/Api/Internal/Query.hs +++ b/cardano-api/src/Cardano/Api/Internal/Query.hs @@ -134,6 +134,7 @@ import Data.SOP.Constraint (SListI) import Data.Sequence (Seq) import Data.Set (Set) import Data.Set qualified as Set +import Data.Singletons qualified as Singletons import Data.Text (Text) import Data.Text qualified as Text import Data.Word (Word64) @@ -707,24 +708,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 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. @@ -852,14 +854,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 => ConsensusProtocol era ~ protocol => ProtoCrypto protocol ~ StandardCrypto => 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/flake.lock b/flake.lock index 1e069d2618..c48f136fde 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1743673076, - "narHash": "sha256-vYFyxz6cTWqDWHI88PI43uzHxDE3HeF/mXF0C3ou4cU=", + "lastModified": 1744854726, + "narHash": "sha256-IyHNBx1paanaIziKoyqCLtvO+tz9mM6bETQXdJzxxN8=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "cc548eaa23f765af603023a231fec8181e92536b", + "rev": "f1058ac21b1356deca7256a2cb692e6e01c1666d", "type": "github" }, "original": { @@ -206,11 +206,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1741047865, - "narHash": "sha256-ajzqKMFjuP5gkkZV6RAGl4tMLzkH+GIqBlSvyX3GNmI=", + "lastModified": 1744244700, + "narHash": "sha256-ZCMyJhQjILu30A1ZHjUvzX0FsZnRzW+6JHysKcV1hNw=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "bd467f7a1674145459c31b9f12543492ca9f7010", + "rev": "8a0751e5be7bf9b1c519ec075f3d6083145dbc71", "type": "github" }, "original": {