From adfff05faf70e2fc178d98e031d3938a713651c5 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 17 Oct 2025 10:21:44 +0200 Subject: [PATCH 01/12] Bump the s-r-p on Ledger --- cabal.project | 4 ++-- .../ouroboros-consensus-cardano.cabal | 17 ++++++++--------- .../Consensus/Shelley/Ledger/Mempool.hs | 2 +- .../ouroboros-consensus-protocol.cabal | 2 +- .../Consensus/Protocol/Praos/Header.hs | 9 +++------ 5 files changed, 15 insertions(+), 19 deletions(-) diff --git a/cabal.project b/cabal.project index 82cbf035ba..75eea310c1 100644 --- a/cabal.project +++ b/cabal.project @@ -53,8 +53,8 @@ if impl (ghc >= 9.10) source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger - tag: fb09078fa55015c881303a2ddb609c024cec258f - --sha256: sha256-9Y9CRiyMn0AWD+C4aNVMaJgrj3FDAYfCX4VrLvtoMaI= + tag: c9cd2e7e9eed58320b252b92edbe6afe276a10a5 + --sha256: sha256-0HM06cQfij8OFAjlcqIXkvKQYpT/is383BPzGJAJgqc= subdir: eras/allegra/impl eras/alonzo/impl diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 399435917f..1662f97857 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -142,16 +142,16 @@ library cardano-ledger-allegra ^>=1.9, cardano-ledger-alonzo ^>=1.15, cardano-ledger-api ^>=1.13, - cardano-ledger-babbage ^>=1.12, - cardano-ledger-binary ^>=1.7, - cardano-ledger-byron ^>=1.2, + cardano-ledger-babbage ^>=1.13, + cardano-ledger-binary ^>=1.8, + cardano-ledger-byron ^>=1.3, cardano-ledger-conway ^>=1.21, cardano-ledger-core ^>=1.19, cardano-ledger-dijkstra ^>=0.2, - cardano-ledger-mary ^>=1.9, - cardano-ledger-shelley ^>=1.17, + cardano-ledger-mary ^>=1.10, + cardano-ledger-shelley ^>=1.18, cardano-prelude, - cardano-protocol-tpraos ^>=1.4.1, + cardano-protocol-tpraos ^>=1.5, cardano-slotting, cardano-strict-containers, cborg ^>=0.2.2, @@ -238,8 +238,7 @@ library unstable-byron-testlib cardano-binary, cardano-crypto, cardano-crypto-class, - cardano-crypto-test, - cardano-crypto-wrapper, + cardano-crypto-wrapper:{cardano-crypto-wrapper, testlib}, cardano-ledger-binary:{cardano-ledger-binary, testlib}, cardano-ledger-byron:{cardano-ledger-byron, testlib}, cardano-ledger-core, @@ -570,7 +569,7 @@ library unstable-cardano-tools cardano-ledger-mary, cardano-ledger-shelley, cardano-prelude, - cardano-protocol-tpraos ^>=1.4.1, + cardano-protocol-tpraos ^>=1.5, cardano-slotting, cardano-strict-containers, cborg ^>=0.2.2, diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 8871e22df7..124d33b7e1 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -202,7 +202,7 @@ newtype instance TxId (GenTx (ShelleyBlock proto era)) = ShelleyTxId SL.TxId deriving newtype (Eq, Ord, NoThunks) deriving newtype instance - (Typeable era, Typeable proto, Crypto (ProtoCrypto proto)) => + Crypto (ProtoCrypto proto) => EncCBOR (TxId (GenTx (ShelleyBlock proto era))) deriving newtype instance (Typeable era, Typeable proto, Crypto (ProtoCrypto proto)) => diff --git a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal index 8afd2fdbd1..3dec6f9580 100644 --- a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal +++ b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal @@ -130,7 +130,7 @@ test-suite protocol-test cardano-crypto-class ^>=2.2, cardano-ledger-binary:testlib, cardano-ledger-core >=1.17 && <1.20, - cardano-protocol-tpraos ^>=1.4.1, + cardano-protocol-tpraos ^>=1.5, containers, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, ouroboros-consensus-protocol, diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs index 00e6bf205c..8f1aa4ade4 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -42,7 +42,6 @@ import Cardano.Ledger.Binary , DecCBOR (decCBOR) , EncCBOR (..) , ToCBOR (..) - , encodedSigKESSizeExpr , serialize' , unCBORGroup ) @@ -225,11 +224,9 @@ instance Crypto crypto => DecCBOR (HeaderRaw crypto) where instance Crypto crypto => DecCBOR (Annotator (HeaderRaw crypto)) where decCBOR = pure <$> decCBOR -instance Crypto c => EncCBOR (Header c) where - encodedSizeExpr size proxy = - 1 - + encodedSizeExpr size (headerBody <$> proxy) - + encodedSigKESSizeExpr (KES.getSig . headerSig <$> proxy) +-- TODO(geo2a): can we derive this instance? +-- previously, it had an additional method defined, which was removed +instance Crypto c => EncCBOR (Header c) deriving via Mem (HeaderRaw crypto) From 10683affc2970916352b0112aa4266835ed94272 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 12 Nov 2025 12:28:58 +0100 Subject: [PATCH 02/12] WIP new Ledger: adapt to change of StakePoolParams --- .../Consensus/Shelley/Ledger/PeerSelection.hs | 16 +++++++++---- .../Consensus/Shelley/Ledger/Query.hs | 2 +- .../Test/ThreadNet/TxGen/Cardano.hs | 22 ++++++++--------- .../Test/ThreadNet/Infra/Shelley.hs | 24 +++++++++---------- 4 files changed, 36 insertions(+), 28 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index 3ba52298cb..6e4f664737 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -37,6 +37,14 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto poolDistr :: SL.PoolDistr poolDistr = SL.nesPd shelleyLedgerState + futurePoolParams + , poolParams :: + Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams + (futurePoolParams, poolParams) = + ( SL.psFutureStakePoolParams pstate + , Map.mapWithKey SL.stakePoolStateToStakePoolParams (SL.psStakePools pstate) + ) + -- Sort stake pools by descending stake orderByStake :: SL.PoolDistr -> @@ -72,14 +80,14 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto -- Note that a stake pool can have multiple registered relays pparamsLedgerRelayAccessPoints :: (LedgerRelayAccessPoint -> StakePoolRelay) -> - SL.StakePoolState -> + SL.StakePoolParams -> Maybe (NonEmpty StakePoolRelay) pparamsLedgerRelayAccessPoints injStakePoolRelay = NE.nonEmpty . force . mapMaybe (fmap injStakePoolRelay . relayToLedgerRelayAccessPoint) . toList - . SL.spsRelays + . SL.sppRelays -- Combine the stake pools registered in the future and the current pool -- parameters, and remove duplicates. @@ -88,8 +96,8 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto poolLedgerRelayAccessPoints = Map.unionWith (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays)) - (Map.mapMaybe (pparamsLedgerRelayAccessPoints FutureRelay) (SL.psStakePools pstate)) - (Map.mapMaybe (pparamsLedgerRelayAccessPoints CurrentRelay) (SL.psFutureStakePools pstate)) + (Map.mapMaybe (pparamsLedgerRelayAccessPoints FutureRelay) futurePoolParams) + (Map.mapMaybe (pparamsLedgerRelayAccessPoints CurrentRelay) poolParams) pstate :: SL.PState era pstate = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index f27c67032d..dd8626a99a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -232,7 +232,7 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where BlockQuery (ShelleyBlock proto era) QFNoTables - (Map (SL.KeyHash 'SL.StakePool) SL.PoolParams) + (Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams) GetRewardInfoPools :: BlockQuery (ShelleyBlock proto era) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs index e906d945c8..e37ac3dc28 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs @@ -256,19 +256,19 @@ migrateUTxO migrationInfo curSlot lcfg lst (SL.StakeRefBase $ Shelley.mkCredential stakingSK) -- A simplistic individual pool - poolParams :: SL.Coin -> SL.PoolParams + poolParams :: SL.Coin -> SL.StakePoolParams poolParams pledge = - SL.PoolParams - { SL.ppCost = SL.Coin 1 - , SL.ppMetadata = SL.SNothing - , SL.ppMargin = minBound - , SL.ppOwners = Set.singleton $ Shelley.mkKeyHash poolSK - , SL.ppPledge = pledge - , SL.ppId = Shelley.mkKeyHash poolSK - , SL.ppRewardAccount = + SL.StakePoolParams + { SL.sppCost = SL.Coin 1 + , SL.sppMetadata = SL.SNothing + , SL.sppMargin = minBound + , SL.sppOwners = Set.singleton $ Shelley.mkKeyHash poolSK + , SL.sppPledge = pledge + , SL.sppId = Shelley.mkKeyHash poolSK + , SL.sppRewardAccount = SL.RewardAccount Shelley.networkId $ Shelley.mkCredential poolSK - , SL.ppRelays = StrictSeq.empty - , SL.ppVrf = Shelley.mkKeyHashVrf @c vrfSK + , SL.sppRelays = StrictSeq.empty + , SL.sppVrf = Shelley.mkKeyHashVrf @c vrfSK } ----- diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index db30a8e3e1..e6cc90443a 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs @@ -417,7 +417,7 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = { sgsPools = ListMap [ (pk, pp) - | pp@SL.PoolParams{ppId = pk} <- Map.elems coreNodeToPoolMapping + | pp@SL.StakePoolParams{sppId = pk} <- Map.elems coreNodeToPoolMapping ] , -- The staking key maps to the key hash of the pool, which is set to the -- "delegate key" in order that nodes may issue blocks both as delegates @@ -432,23 +432,23 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = } where coreNodeToPoolMapping :: - Map (SL.KeyHash 'SL.StakePool) SL.PoolParams + Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams coreNodeToPoolMapping = Map.fromList [ ( SL.hashKey . SL.VKey . deriveVerKeyDSIGN $ cnStakingKey - , SL.PoolParams - { SL.ppId = poolHash - , SL.ppVrf = vrfHash + , SL.StakePoolParams + { SL.sppId = poolHash + , SL.sppVrf = vrfHash , -- Each core node pledges its full stake to the pool. - SL.ppPledge = SL.Coin $ fromIntegral initialLovelacePerCoreNode - , SL.ppCost = SL.Coin 1 - , SL.ppMargin = minBound + SL.sppPledge = SL.Coin $ fromIntegral initialLovelacePerCoreNode + , SL.sppCost = SL.Coin 1 + , SL.sppMargin = minBound , -- Reward accounts live in a separate "namespace" to other -- accounts, so it should be fine to use the same address. - SL.ppRewardAccount = SL.RewardAccount networkId $ mkCredential cnDelegateKey - , SL.ppOwners = Set.singleton poolOwnerHash - , SL.ppRelays = Seq.empty - , SL.ppMetadata = SL.SNothing + SL.sppRewardAccount = SL.RewardAccount networkId $ mkCredential cnDelegateKey + , SL.sppOwners = Set.singleton poolOwnerHash + , SL.sppRelays = Seq.empty + , SL.sppMetadata = SL.SNothing } ) | CoreNode{cnDelegateKey, cnStakingKey, cnVRF} <- coreNodes From b89b9d92277469bf6b8a2cd778c1a5b1834cfd55 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 12 Nov 2025 12:31:08 +0100 Subject: [PATCH 03/12] WIP Ledger: introduce Core.Tx levels --- .../src/shelley/Ouroboros/Consensus/Shelley/Eras.hs | 12 ++++++------ .../Ouroboros/Consensus/Shelley/Ledger/Forge.hs | 4 ++-- .../Ouroboros/Consensus/Shelley/Ledger/Mempool.hs | 12 +++++++----- .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 10 +++++----- .../Test/ThreadNet/Infra/ShelleyBasedHardFork.hs | 2 +- .../Test/ThreadNet/TxGen/Cardano.hs | 2 +- .../Cardano/Tools/DBAnalyser/Block/Shelley.hs | 6 +++--- .../Test/Consensus/Shelley/Examples.hs | 2 +- .../Test/Consensus/Shelley/MockCrypto.hs | 4 ++-- .../Test/ThreadNet/Infra/Shelley.hs | 4 ++-- 10 files changed, 30 insertions(+), 28 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index f9cf5d0dca..cccfc1ab0b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -123,11 +123,11 @@ class SL.LedgerEnv era -> SL.LedgerState era -> WhetherToIntervene -> - Core.Tx era -> + Core.Tx TopTx era -> Except (SL.ApplyTxError era) ( SL.LedgerState era - , SL.Validated (Core.Tx era) + , SL.Validated (Core.Tx TopTx era) ) -- | Whether the era has an instance of 'CG.ConwayEraGov' @@ -148,11 +148,11 @@ defaultApplyShelleyBasedTx :: SL.LedgerEnv era -> SL.LedgerState era -> WhetherToIntervene -> - Core.Tx era -> + Core.Tx TopTx era -> Except (SL.ApplyTxError era) ( SL.LedgerState era - , SL.Validated (Core.Tx era) + , SL.Validated (Core.Tx TopTx era) ) defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx = liftEither $ @@ -210,11 +210,11 @@ applyAlonzoBasedTx :: SL.LedgerEnv era -> SL.LedgerState era -> WhetherToIntervene -> - Core.Tx era -> + Core.Tx TopTx era -> Except (SL.ApplyTxError era) ( SL.LedgerState era - , SL.Validated (Core.Tx era) + , SL.Validated (Core.Tx TopTx era) ) applyAlonzoBasedTx globals ledgerEnv mempoolState wti tx = do (mempoolState', vtx) <- diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index fb1d5bb4ed..53897caaa7 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -6,7 +6,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where -import qualified Cardano.Ledger.Core as Core (Tx) +import qualified Cardano.Ledger.Core as Core (TopTx, Tx) import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL) import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx) import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize) @@ -85,7 +85,7 @@ forgeShelleyBlock actualBodySize = SL.bBodySize protocolVersion body - extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era + extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx Core.TopTx era extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx prevHash :: SL.PrevHash diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 124d33b7e1..99d9ccd5a0 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -45,6 +45,7 @@ import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Ledger.Allegra.Rules as AllegraEra import Cardano.Ledger.Alonzo.Core ( BlockBody + , TopTx , Tx , allInputsTxBodyF , bodyTxL @@ -112,7 +113,7 @@ import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet) import Ouroboros.Consensus.Util.Condense import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR) -data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx era) +data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx TopTx era) deriving stock Generic deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock proto era)) @@ -126,7 +127,7 @@ instance data instance Validated (GenTx (ShelleyBlock proto era)) = ShelleyValidatedTx !SL.TxId - !(SL.Validated (Tx era)) + !(SL.Validated (Tx TopTx era)) deriving stock Generic deriving instance ShelleyBasedEra era => NoThunks (Validated (GenTx (ShelleyBlock proto era))) @@ -186,13 +187,14 @@ instance coerceSet (tx ^. bodyTxL . allInputsTxBodyF) -mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era) +mkShelleyTx :: + forall era proto. ShelleyBasedEra era => Tx TopTx era -> GenTx (ShelleyBlock proto era) mkShelleyTx tx = ShelleyTx (txIdTx tx) tx mkShelleyValidatedTx :: forall era proto. ShelleyBasedEra era => - SL.Validated (Tx era) -> + SL.Validated (Tx TopTx era) -> Validated (GenTx (ShelleyBlock proto era)) mkShelleyValidatedTx vtx = ShelleyValidatedTx txid vtx where @@ -226,7 +228,7 @@ instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where . SL.blockBody . shelleyBlockRaw where - blockBodyToTxList :: BlockBody era -> [Tx era] + blockBodyToTxList :: BlockBody era -> [Tx TopTx era] blockBodyToTxList blockBody = toList $ blockBody ^. txSeqBlockBodyL {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index f03c7320ea..daeb3a49dd 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -391,30 +391,30 @@ translateShelleyTables (LedgerTables utxoTable) = instance ( ShelleyBasedEra era - , SL.TranslateEra era SL.Tx + , SL.TranslateEra era (SL.Tx SL.TopTx) ) => SL.TranslateEra era (GenTx :.: ShelleyBlock proto) where - type TranslationError era (GenTx :.: ShelleyBlock proto) = SL.TranslationError era SL.Tx + type TranslationError era (GenTx :.: ShelleyBlock proto) = SL.TranslationError era (SL.Tx SL.TopTx) translateEra ctxt (Comp (ShelleyTx _txId tx)) = Comp . mkShelleyTx <$> SL.translateEra ctxt tx instance ( ShelleyBasedEra era - , SL.TranslateEra era SL.Tx + , SL.TranslateEra era (SL.Tx SL.TopTx) ) => SL.TranslateEra era (WrapValidatedGenTx :.: ShelleyBlock proto) where type TranslationError era (WrapValidatedGenTx :.: ShelleyBlock proto) = - SL.TranslationError era SL.Tx + SL.TranslationError era (SL.Tx SL.TopTx) translateEra ctxt (Comp (WrapValidatedGenTx (ShelleyValidatedTx _txId vtx))) = Comp . WrapValidatedGenTx . mkShelleyValidatedTx . SL.coerceValidated - <$> SL.translateValidated @era @SL.Tx ctxt (SL.coerceValidated vtx) + <$> SL.translateValidated @era @(SL.Tx SL.TopTx) ctxt (SL.coerceValidated vtx) {------------------------------------------------------------------------------- Canonical TxIn diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index 7394a16518..6400cf0e80 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -188,7 +188,7 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , TranslateTxMeasure (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2)) , SL.PreviousEra era2 ~ era1 , SL.TranslateEra era2 SL.NewEpochState - , SL.TranslateEra era2 SL.Tx + , SL.TranslateEra era2 (SL.Tx SL.TopTx) , SL.TranslationError era2 SL.NewEpochState ~ Void , -- At the moment, fix the protocols together ProtoCrypto proto1 ~ ProtoCrypto proto2 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs index e37ac3dc28..07ad03ed15 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs @@ -176,7 +176,7 @@ migrateUTxO migrationInfo curSlot lcfg lst assert (pickedCoin > spentCoin) $ pickedCoin <-> spentCoin - body :: SL.TxBody ShelleyEra + body :: SL.TxBody SL.TopTx ShelleyEra body = SL.mkBasicTxBody & SL.certsTxBodyL diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs index acdd8e6745..b5dec3468b 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs @@ -65,7 +65,7 @@ instance countTxOutputs blk = case Shelley.shelleyBlockRaw blk of SL.Block _ body -> getSum $ foldMap (Sum . countOutputs) (body ^. Core.txSeqBlockBodyL) where - countOutputs :: Core.Tx era -> Int + countOutputs :: Core.Tx Core.TopTx era -> Int countOutputs tx = length $ tx ^. Core.bodyTxL . Core.outputsTxBodyL blockTxSizes blk = case Shelley.shelleyBlockRaw blk of @@ -100,7 +100,7 @@ instance | f <- maybeToList txExUnitsSteps ] where - txs :: StrictSeq (Core.Tx era) + txs :: StrictSeq (Core.Tx Core.TopTx era) txs = case Shelley.shelleyBlockRaw blk of SL.Block _ body -> body ^. Core.txSeqBlockBodyL @@ -109,7 +109,7 @@ instance blockApplicationMetrics = [] class PerEraAnalysis era where - txExUnitsSteps :: Maybe (Core.Tx era -> Word64) + txExUnitsSteps :: Maybe (Core.Tx Core.TopTx era -> Word64) instance PerEraAnalysis ShelleyEra where txExUnitsSteps = Nothing instance PerEraAnalysis AllegraEra where txExUnitsSteps = Nothing diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index 7d7bba34f5..fb5086cf62 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -94,7 +94,7 @@ codecConfig = ShelleyCodecConfig mkLedgerTables :: forall proto era. ShelleyCompatible proto era => - LC.Tx era -> + LC.Tx LC.TopTx era -> LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK mkLedgerTables tx = LedgerTables $ diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs index 60007eecda..4027bbcd1d 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs @@ -79,8 +79,8 @@ type CanMock proto era = , Arbitrary (Core.PParams era) , Arbitrary (Core.PParamsUpdate era) , Arbitrary (Core.Script era) - , Arbitrary (Core.TxBody era) - , Arbitrary (Core.Tx era) + , Arbitrary (Core.TxBody Core.TopTx era) + , Arbitrary (Core.Tx Core.TopTx era) , Arbitrary (Core.TxOut era) , Arbitrary (Core.Value era) , Arbitrary (PredicateFailure (SL.ShelleyUTXOW era)) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index e6cc90443a..e3110dd683 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs @@ -525,7 +525,7 @@ mkSetDecentralizationParamTxs coreNodes pVer ttl dNew = -- Nothing but the parameter update and the obligatory touching of an -- input. - body :: SL.TxBody ShelleyEra + body :: SL.TxBody SL.TopTx ShelleyEra body = SL.mkBasicTxBody & SL.inputsTxBodyL .~ Set.singleton (fst touchCoins) @@ -646,7 +646,7 @@ mkMASetDecentralizationParamTxs coreNodes pVer ttl dNew = -- Nothing but the parameter update and the obligatory touching of an -- input. - body :: SL.TxBody era + body :: SL.TxBody SL.TopTx era body = SL.mkBasicTxBody & SL.inputsTxBodyL .~ inputs From 39200416bdf90072945ac25a34d879eca8a62d59 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 12 Nov 2025 13:01:49 +0100 Subject: [PATCH 04/12] WIP Ledger: adapt to changes in `runAnnotator` The commit should be revised --- .../shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs | 9 +++++++-- .../Ouroboros/Consensus/Shelley/Ledger/Mempool.hs | 3 ++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 751d63ddd1..957f346db3 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -62,6 +62,7 @@ import Cardano.Protocol.Crypto (Crypto) import qualified Cardano.Protocol.TPraos.BHeader as SL import qualified Data.ByteString.Lazy as Lazy import Data.Coerce (coerce) +import Data.Either (fromRight) import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) @@ -311,7 +312,9 @@ decodeShelleyBlock :: ShelleyCompatible proto era => forall s. Plain.Decoder s (Lazy.ByteString -> ShelleyBlock proto era) -decodeShelleyBlock = eraDecoder @era $ (. Full) . runAnnotator <$> decCBOR +decodeShelleyBlock = + eraDecoder @era $ + (. Full) . (fromRight (error "TODO(geo2a): remove fromRight") .) . runAnnotator <$> decCBOR shelleyBinaryBlockInfo :: forall proto era. ShelleyCompatible proto era => ShelleyBlock proto era -> BinaryBlockInfo @@ -335,7 +338,9 @@ decodeShelleyHeader :: ShelleyCompatible proto era => forall s. Plain.Decoder s (Lazy.ByteString -> Header (ShelleyBlock proto era)) -decodeShelleyHeader = eraDecoder @era $ (. Full) . runAnnotator <$> decCBOR +decodeShelleyHeader = + eraDecoder @era $ + (. Full) . (fromRight (error "TODO(geo2a): remove fromRight") .) . runAnnotator <$> decCBOR {------------------------------------------------------------------------------- Condense diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 99d9ccd5a0..c8da26202a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -87,6 +87,7 @@ import Control.Monad (guard) import Control.Monad.Except (Except, liftEither) import Control.Monad.Identity (Identity (..)) import Data.DerivingVia (InstantiatedAt (..)) +import Data.Either (fromRight) import Data.Foldable (toList) import Data.Measure (Measure) import Data.Typeable (Typeable) @@ -245,7 +246,7 @@ instance ShelleyCompatible proto era => FromCBOR (GenTx (ShelleyBlock proto era) fmap mkShelleyTx $ unwrapCBORinCBOR $ eraDecoder @era $ - (. Full) . runAnnotator <$> decCBOR + (. Full) . (fromRight (error "TODO(geo2a): remove fromRight") .) . runAnnotator <$> decCBOR {------------------------------------------------------------------------------- Pretty-printing From 06a0972c94fe7efa5bd119654e0cf33577016f43 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 25 Nov 2025 12:20:26 +0100 Subject: [PATCH 05/12] Fix the fixup for Ledger CDDLs - replace distinct_VBytes with distinct_bytes - alonzo and babbage CDDLs also need fixing up --- .../Test/Consensus/Cardano/GenCDDLs.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/GenCDDLs.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/GenCDDLs.hs index 2e88ebd3b2..bc3fb88c21 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/GenCDDLs.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/GenCDDLs.hs @@ -45,14 +45,14 @@ withCDDLs f = setupCDDLCEnv ntnBlock <- cddlc "cddl/node-to-node/blockfetch/block.cddl" - ntnBlock' <- fixupBlockCDDL ntnBlock + ntnBlock' <- fixupLedgerCDDL ntnBlock BS.writeFile "ntnblock.cddl" . cddlSpec $ ntnBlock' ntnHeader <- cddlc "cddl/node-to-node/chainsync/header.cddl" BS.writeFile "ntnheader.cddl" . cddlSpec $ ntnHeader ntnTx <- cddlc "cddl/node-to-node/txsubmission2/tx.cddl" - ntnTx' <- fixupBlockCDDL ntnTx + ntnTx' <- fixupLedgerCDDL ntnTx BS.writeFile "ntntx.cddl" . cddlSpec $ ntnTx' ntnTxId <- cddlc "cddl/node-to-node/txsubmission2/txId.cddl" @@ -66,17 +66,20 @@ withCDDLs f = ) (\_ -> f) --- | The Ledger CDDL specs are not _exactly_ correct. Here we do some dirty --- sed-replace to make them able to validate blocks. See cardano-ledger#5054. -fixupBlockCDDL :: CDDLSpec -> IO CDDLSpec -fixupBlockCDDL spec = +-- | The Ledger CDDL specs for transactions and blocks are too restrictive. +-- Here we do some dirty sed-replace to make them able to validate blocks. +-- See cardano-ledger#5054. +fixupLedgerCDDL :: CDDLSpec -> IO CDDLSpec +fixupLedgerCDDL spec = withTempFile "." "block-temp.cddl" $ \fp h -> do hClose h BS.writeFile fp . cddlSpec $ spec -- For plutus, the type is actually `bytes`, but the distinct construct is -- for forcing generation of different values. See cardano-ledger#5054 - sed fp ["-i", "s/\\(conway\\.distinct_VBytes = \\)/\\1 bytes ;\\//g"] - sed fp ["-i", "s/\\(dijkstra\\.distinct_VBytes = \\)/\\1 bytes ;\\//g"] + sed fp ["-i", "s/\\(alonzo\\.distinct_bytes = \\)/\\1 bytes ;\\//g"] + sed fp ["-i", "s/\\(babbage\\.distinct_bytes = \\)/\\1 bytes ;\\//g"] + sed fp ["-i", "s/\\(conway\\.distinct_bytes = \\)/\\1 bytes ;\\//g"] + sed fp ["-i", "s/\\(dijkstra\\.distinct_bytes = \\)/\\1 bytes ;\\//g"] -- These 3 below are hardcoded for generation. See cardano-ledger#5054 sed fp ["-i", "s/\\([yaoye]\\.address = \\)/\\1 bytes ;/g"] sed fp ["-i", "s/\\(reward_account = \\)/\\1 bytes ;/g"] From 3b9d181b83d27b17c3f61ee979a7a156a29c1625 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Wed, 26 Nov 2025 14:13:22 +0100 Subject: [PATCH 06/12] WIP use `KeyRole` types instead of promoted constructors --- cabal.project | 4 +- .../Consensus/Shelley/Ledger/Config.hs | 6 +- .../Consensus/Shelley/Ledger/PeerSelection.hs | 6 +- .../Consensus/Shelley/Ledger/Protocol.hs | 2 +- .../Consensus/Shelley/Ledger/Query.hs | 64 +++++++++---------- .../Ouroboros/Consensus/Shelley/Node.hs | 4 +- .../Consensus/Shelley/Node/Common.hs | 2 +- .../Consensus/Shelley/Protocol/Abstract.hs | 2 +- .../Test/ThreadNet/TxGen/Cardano.hs | 4 +- .../Cardano/Api/KeysShelley.hs | 4 +- .../Test/ThreadNet/Infra/Shelley.hs | 18 +++--- .../Ouroboros/Consensus/Protocol/Praos.hs | 13 ++-- .../Consensus/Protocol/Praos/Common.hs | 6 +- .../Consensus/Protocol/Praos/Header.hs | 4 +- .../Consensus/Protocol/Praos/Views.hs | 2 +- .../Ouroboros/Consensus/Protocol/TPraos.hs | 4 +- 16 files changed, 72 insertions(+), 73 deletions(-) diff --git a/cabal.project b/cabal.project index 75eea310c1..d9412f2d4d 100644 --- a/cabal.project +++ b/cabal.project @@ -53,8 +53,8 @@ if impl (ghc >= 9.10) source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger - tag: c9cd2e7e9eed58320b252b92edbe6afe276a10a5 - --sha256: sha256-0HM06cQfij8OFAjlcqIXkvKQYpT/is383BPzGJAJgqc= + tag: 1258f444774a2360ab2d0cad1b9b1a7152b12bfa + --sha256: sha256-fqT8zlcreIZzGCZU9IX+7JqJM/Sjrd68ub96klEfw/w= subdir: eras/allegra/impl eras/alonzo/impl diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs index 6bbcd70ede..1c1b511787 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs @@ -52,8 +52,8 @@ data instance BlockConfig (ShelleyBlock proto era) = ShelleyConfig , shelleyNetworkMagic :: !NetworkMagic , shelleyBlockIssuerVKeys :: !( Map - (SL.KeyHash 'SL.BlockIssuer) - (SL.VKey 'SL.BlockIssuer) + (SL.KeyHash SL.BlockIssuer) + (SL.VKey SL.BlockIssuer) ) -- ^ For nodes that can produce blocks, this should be set to the -- verification key(s) corresponding to the node's signing key(s). For non @@ -70,7 +70,7 @@ mkShelleyBlockConfig :: ShelleyBasedEra era => SL.ProtVer -> SL.ShelleyGenesis -> - [SL.VKey 'SL.BlockIssuer] -> + [SL.VKey SL.BlockIssuer] -> BlockConfig (ShelleyBlock proto era) mkShelleyBlockConfig protVer genesis blockIssuerVKeys = ShelleyConfig diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index 6e4f664737..fba14ecc5a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -39,7 +39,7 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto futurePoolParams , poolParams :: - Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams + Map (SL.KeyHash SL.StakePool) SL.StakePoolParams (futurePoolParams, poolParams) = ( SL.psFutureStakePoolParams pstate , Map.mapWithKey SL.stakePoolStateToStakePoolParams (SL.psStakePools pstate) @@ -48,7 +48,7 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto -- Sort stake pools by descending stake orderByStake :: SL.PoolDistr -> - [(SL.KeyHash 'SL.StakePool, PoolStake)] + [(SL.KeyHash SL.StakePool, PoolStake)] orderByStake = sortOn (Down . snd) . map (second (PoolStake . SL.individualPoolStake)) @@ -92,7 +92,7 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto -- Combine the stake pools registered in the future and the current pool -- parameters, and remove duplicates. poolLedgerRelayAccessPoints :: - Map (SL.KeyHash 'SL.StakePool) (NonEmpty StakePoolRelay) + Map (SL.KeyHash SL.StakePool) (NonEmpty StakePoolRelay) poolLedgerRelayAccessPoints = Map.unionWith (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays)) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs index 10c4302cc6..76c2be9a76 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Protocol.hs @@ -38,7 +38,7 @@ instance ShelleyCompatible proto era => BlockSupportsProtocol (ShelleyBlock prot , ptvTieBreakVRF = pTieBreakVRFValue shdr } where - hdrIssuer :: SL.VKey 'SL.BlockIssuer + hdrIssuer :: SL.VKey SL.BlockIssuer hdrIssuer = pHeaderIssuer shdr projectChainOrderConfig = shelleyVRFTiebreakerFlavor diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index dd8626a99a..e25afa3c35 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -55,7 +55,7 @@ import qualified Cardano.Ledger.Conway.Governance as CG import qualified Cardano.Ledger.Conway.State as CG import qualified Cardano.Ledger.Core as SL import Cardano.Ledger.Credential (StakeCredential) -import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) +import Cardano.Ledger.Keys (KeyHash) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Core as LC import qualified Cardano.Ledger.Shelley.RewardProvenance as SL @@ -127,15 +127,15 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Utils newtype NonMyopicMemberRewards = NonMyopicMemberRewards { unNonMyopicMemberRewards :: Map - (Either SL.Coin (SL.Credential 'SL.Staking)) - (Map (SL.KeyHash 'SL.StakePool) SL.Coin) + (Either SL.Coin (SL.Credential SL.Staking)) + (Map (SL.KeyHash SL.StakePool) SL.Coin) } deriving stock Show deriving newtype (Eq, ToCBOR, FromCBOR) -type Delegations = Map (SL.Credential 'SL.Staking) (SL.KeyHash 'SL.StakePool) +type Delegations = Map (SL.Credential SL.Staking) (SL.KeyHash SL.StakePool) -type VoteDelegatees = Map (SL.Credential 'SL.Staking) SL.DRep +type VoteDelegatees = Map (SL.Credential SL.Staking) SL.DRep {-# DEPRECATED GetProposedPParamsUpdates "Deprecated in ShelleyNodeToClientVersion12" #-} {-# DEPRECATED @@ -153,7 +153,7 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where -- | Calculate the Non-Myopic Pool Member Rewards for a set of -- credentials. See 'SL.getNonMyopicMemberRewards' GetNonMyopicMemberRewards :: - Set (Either SL.Coin (SL.Credential 'SL.Staking)) -> + Set (Either SL.Coin (SL.Credential SL.Staking)) -> BlockQuery (ShelleyBlock proto era) QFNoTables NonMyopicMemberRewards GetCurrentPParams :: BlockQuery (ShelleyBlock proto era) QFNoTables (LC.PParams era) @@ -200,11 +200,11 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where BlockQuery (ShelleyBlock proto era) fp result -> BlockQuery (ShelleyBlock proto era) fp (Serialised result) GetFilteredDelegationsAndRewardAccounts :: - Set (SL.Credential 'SL.Staking) -> + Set (SL.Credential SL.Staking) -> BlockQuery (ShelleyBlock proto era) QFNoTables - (Delegations, Map (SL.Credential 'Staking) Coin) + (Delegations, Map (SL.Credential SL.Staking) Coin) GetGenesisConfig :: BlockQuery (ShelleyBlock proto era) QFNoTables CompactGenesis -- | Only for debugging purposes, we make no effort to ensure binary @@ -226,36 +226,36 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where BlockQuery (ShelleyBlock proto era) QFNoTables - (Set (SL.KeyHash 'SL.StakePool)) + (Set (SL.KeyHash SL.StakePool)) GetStakePoolParams :: - Set (SL.KeyHash 'SL.StakePool) -> + Set (SL.KeyHash SL.StakePool) -> BlockQuery (ShelleyBlock proto era) QFNoTables - (Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams) + (Map (SL.KeyHash SL.StakePool) SL.StakePoolParams) GetRewardInfoPools :: BlockQuery (ShelleyBlock proto era) QFNoTables ( SL.RewardParams , Map - (SL.KeyHash 'SL.StakePool) + (SL.KeyHash SL.StakePool) (SL.RewardInfoPool) ) GetPoolState :: - Maybe (Set (SL.KeyHash 'SL.StakePool)) -> + Maybe (Set (SL.KeyHash SL.StakePool)) -> BlockQuery (ShelleyBlock proto era) QFNoTables SL.QueryPoolStateResult GetStakeSnapshots :: - Maybe (Set (SL.KeyHash 'SL.StakePool)) -> + Maybe (Set (SL.KeyHash SL.StakePool)) -> BlockQuery (ShelleyBlock proto era) QFNoTables StakeSnapshots GetPoolDistr :: - Maybe (Set (SL.KeyHash 'SL.StakePool)) -> + Maybe (Set (SL.KeyHash SL.StakePool)) -> BlockQuery (ShelleyBlock proto era) QFNoTables @@ -280,12 +280,12 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where -- Not supported in eras before Conway. GetDRepState :: (CG.ConwayEraGov era, CG.ConwayEraCertState era) => - Set (SL.Credential 'DRepRole) -> + Set (SL.Credential SL.DRepRole) -> BlockQuery (ShelleyBlock proto era) QFNoTables ( Map - (SL.Credential 'DRepRole) + (SL.Credential SL.DRepRole) SL.DRepState ) -- | Query the 'DRep' stake distribution. Note that this can be an expensive @@ -305,8 +305,8 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where -- Not supported in eras before Conway. GetCommitteeMembersState :: (CG.ConwayEraGov era, CG.ConwayEraCertState era) => - Set (SL.Credential 'ColdCommitteeRole) -> - Set (SL.Credential 'HotCommitteeRole) -> + Set (SL.Credential SL.ColdCommitteeRole) -> + Set (SL.Credential SL.HotCommitteeRole) -> Set SL.MemberStatus -> BlockQuery (ShelleyBlock proto era) QFNoTables SL.CommitteeMembersState -- | The argument specifies the credential of each account whose delegatee @@ -316,7 +316,7 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where -- Not supported in eras before Conway. GetFilteredVoteDelegatees :: CG.ConwayEraGov era => - Set (SL.Credential 'SL.Staking) -> + Set (SL.Credential SL.Staking) -> BlockQuery (ShelleyBlock proto era) QFNoTables VoteDelegatees GetAccountState :: BlockQuery (ShelleyBlock proto era) QFNoTables SL.ChainAccountState @@ -328,8 +328,8 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where -- Not supported in eras before Conway. GetSPOStakeDistr :: CG.ConwayEraGov era => - Set (KeyHash 'StakePool) -> - BlockQuery (ShelleyBlock proto era) QFNoTables (Map (KeyHash 'StakePool) Coin) + Set (KeyHash SL.StakePool) -> + BlockQuery (ShelleyBlock proto era) QFNoTables (Map (KeyHash SL.StakePool) Coin) GetProposals :: CG.ConwayEraGov era => Set CG.GovActionId -> @@ -347,10 +347,10 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where BlockQuery (ShelleyBlock proto era) QFNoTables LedgerPeerSnapshot QueryStakePoolDefaultVote :: CG.ConwayEraGov era => - KeyHash 'StakePool -> + KeyHash SL.StakePool -> BlockQuery (ShelleyBlock proto era) QFNoTables CG.DefaultVote GetPoolDistr2 :: - Maybe (Set (SL.KeyHash 'SL.StakePool)) -> + Maybe (Set (SL.KeyHash SL.StakePool)) -> BlockQuery (ShelleyBlock proto era) QFNoTables @@ -441,16 +441,16 @@ instance , SL.ssStakeGo } = SL.esSnapshots . SL.nesEs $ st - totalMarkByPoolId :: Map (KeyHash 'StakePool) Coin + totalMarkByPoolId :: Map (KeyHash SL.StakePool) Coin totalMarkByPoolId = SL.sumStakePerPool (SL.ssDelegations ssStakeMark) (SL.ssStake ssStakeMark) - totalSetByPoolId :: Map (KeyHash 'StakePool) Coin + totalSetByPoolId :: Map (KeyHash SL.StakePool) Coin totalSetByPoolId = SL.sumStakePerPool (SL.ssDelegations ssStakeSet) (SL.ssStake ssStakeSet) - totalGoByPoolId :: Map (KeyHash 'StakePool) Coin + totalGoByPoolId :: Map (KeyHash SL.StakePool) Coin totalGoByPoolId = SL.sumStakePerPool (SL.ssDelegations ssStakeGo) (SL.ssStake ssStakeGo) - getPoolStakes :: Set (KeyHash 'StakePool) -> Map (KeyHash 'StakePool) StakeSnapshot + getPoolStakes :: Set (KeyHash SL.StakePool) -> Map (KeyHash SL.StakePool) StakeSnapshot getPoolStakes poolIds = Map.fromSet mkStakeSnapshot poolIds where mkStakeSnapshot poolId = @@ -821,14 +821,14 @@ getDState = view SL.certDStateL . SL.lsCertState . SL.esLState . SL.nesEs getFilteredDelegationsAndRewardAccounts :: SL.EraCertState era => SL.NewEpochState era -> - Set (SL.Credential 'SL.Staking) -> - (Delegations, Map (SL.Credential 'Staking) Coin) + Set (SL.Credential SL.Staking) -> + (Delegations, Map (SL.Credential SL.Staking) Coin) getFilteredDelegationsAndRewardAccounts = SL.queryStakePoolDelegsAndRewards getFilteredVoteDelegatees :: (SL.EraCertState era, CG.ConwayEraAccounts era) => SL.NewEpochState era -> - Set (SL.Credential 'SL.Staking) -> + Set (SL.Credential SL.Staking) -> VoteDelegatees getFilteredVoteDelegatees ss creds | Set.null creds = @@ -1163,7 +1163,7 @@ instance FromCBOR StakeSnapshot where <*> fromCBOR data StakeSnapshots = StakeSnapshots - { ssStakeSnapshots :: !(Map (SL.KeyHash 'SL.StakePool) StakeSnapshot) + { ssStakeSnapshots :: !(Map (SL.KeyHash SL.StakePool) StakeSnapshot) , ssMarkTotal :: !SL.Coin , ssSetTotal :: !SL.Coin , ssGoTotal :: !SL.Coin diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs index ac9256e7cc..75102cd714 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -107,8 +107,8 @@ instance ShelleyCompatible proto era => BlockSupportsMetrics (ShelleyBlock proto where issuerVKeys :: Map - (SL.KeyHash 'SL.BlockIssuer) - (SL.VKey 'SL.BlockIssuer) + (SL.KeyHash SL.BlockIssuer) + (SL.VKey SL.BlockIssuer) issuerVKeys = shelleyBlockIssuerVKeys cfg instance ConsensusProtocol proto => BlockSupportsSanityCheck (ShelleyBlock proto era) where diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs index 0627992c1a..6cd5b3f7a5 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs @@ -65,7 +65,7 @@ data ShelleyLeaderCredentials c = ShelleyLeaderCredentials } shelleyBlockIssuerVKey :: - ShelleyLeaderCredentials c -> SL.VKey 'SL.BlockIssuer + ShelleyLeaderCredentials c -> SL.VKey SL.BlockIssuer shelleyBlockIssuerVKey = praosCanBeLeaderColdVerKey . shelleyLeaderCredentialsCanBeLeader diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs index 85fda96eb1..abd571ebad 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs @@ -174,7 +174,7 @@ class ProtocolHeaderSupportsProtocol proto where ShelleyProtocolHeader proto -> ValidateView proto pHeaderIssuer :: - ShelleyProtocolHeader proto -> VKey 'BlockIssuer + ShelleyProtocolHeader proto -> VKey BlockIssuer pHeaderIssueNo :: ShelleyProtocolHeader proto -> Word64 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs index 07ad03ed15..7ecb77b739 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs @@ -203,14 +203,14 @@ migrateUTxO migrationInfo curSlot lcfg lst Byron.addrAttributes byronAddr -- Witness the stake delegation. - delegWit :: SL.WitVKey 'SL.Witness + delegWit :: SL.WitVKey SL.Witness delegWit = TL.mkWitnessVKey bodyHash (Shelley.mkKeyPair stakingSK) -- Witness the pool registration. - poolWit :: SL.WitVKey 'SL.Witness + poolWit :: SL.WitVKey SL.Witness poolWit = TL.mkWitnessVKey bodyHash diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs index 844e3a2681..b235f23ed2 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysShelley.hs @@ -568,7 +568,7 @@ instance HasTypeProxy GenesisKey where instance Key GenesisKey where newtype VerificationKey GenesisKey - = GenesisVerificationKey (Shelley.VKey Shelley.Genesis) + = GenesisVerificationKey (Shelley.VKey Shelley.GenesisRole) deriving stock Eq deriving (Show, IsString) via UsingRawBytesHex (VerificationKey GenesisKey) deriving newtype (ToCBOR, FromCBOR) @@ -615,7 +615,7 @@ instance SerialiseAsRawBytes (SigningKey GenesisKey) where GenesisSigningKey <$> Crypto.rawDeserialiseSignKeyDSIGN bs newtype instance Hash GenesisKey - = GenesisKeyHash (Shelley.KeyHash Shelley.Genesis) + = GenesisKeyHash (Shelley.KeyHash Shelley.GenesisRole) deriving stock (Eq, Ord) deriving (Show, IsString) via UsingRawBytesHex (Hash GenesisKey) deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash GenesisKey) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index e3110dd683..229add050f 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs @@ -179,12 +179,12 @@ data CoreNode c = CoreNode data CoreNodeKeyInfo c = CoreNodeKeyInfo { cnkiKeyPair :: - ( TL.KeyPair 'SL.Payment - , TL.KeyPair 'SL.Staking + ( TL.KeyPair SL.Payment + , TL.KeyPair SL.Staking ) , cnkiCoreNode :: - ( TL.KeyPair 'SL.Genesis - , Gen.AllIssuerKeys c 'SL.GenesisDelegate + ( TL.KeyPair SL.GenesisRole + , Gen.AllIssuerKeys c SL.GenesisDelegate ) } @@ -380,11 +380,11 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = & SL.ppProtocolVersionL .~ pVer coreNodesToGenesisMapping :: - Map (SL.KeyHash 'SL.Genesis) SL.GenDelegPair + Map (SL.KeyHash SL.GenesisRole) SL.GenDelegPair coreNodesToGenesisMapping = Map.fromList [ let - gkh :: SL.KeyHash 'SL.Genesis + gkh :: SL.KeyHash SL.GenesisRole gkh = SL.hashKey . SL.VKey $ deriveVerKeyDSIGN cnGenesisKey gdpair :: SL.GenDelegPair @@ -432,7 +432,7 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = } where coreNodeToPoolMapping :: - Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams + Map (SL.KeyHash SL.StakePool) SL.StakePoolParams coreNodeToPoolMapping = Map.fromList [ ( SL.hashKey . SL.VKey . deriveVerKeyDSIGN $ cnStakingKey @@ -513,7 +513,7 @@ mkSetDecentralizationParamTxs coreNodes pVer ttl dNew = -- Every node signs the transaction body, since it includes a " vote " from -- every node. - signatures :: Set (SL.WitVKey 'SL.Witness) + signatures :: Set (SL.WitVKey SL.Witness) signatures = TL.mkWitnessesVKey (hashAnnotated body) @@ -634,7 +634,7 @@ mkMASetDecentralizationParamTxs coreNodes pVer ttl dNew = -- Every node signs the transaction body, since it includes a " vote " from -- every node. - signatures :: Set (SL.WitVKey 'SL.Witness) + signatures :: Set (SL.WitVKey SL.Witness) signatures = TL.mkWitnessesVKey (eraIndTxBodyHash' body) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 772f3c2550..29ab9eee8e 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -46,7 +46,6 @@ import Cardano.Ledger.Hashes (HASH) import Cardano.Ledger.Keys ( DSIGN , KeyHash - , KeyRole (BlockIssuer) , VKey (VKey) , coerceKeyRole , hashKey @@ -155,7 +154,7 @@ deriving instance -- | Fields arising from praos execution which must be included in -- the block signature. data PraosToSign c = PraosToSign - { praosToSignIssuerVK :: SL.VKey 'SL.BlockIssuer + { praosToSignIssuerVK :: SL.VKey SL.BlockIssuer -- ^ Verification key for the issuer of this block. , praosToSignVrfVK :: VRF.VerKeyVRF (VRF c) , praosToSignVrfRes :: VRF.CertifiedVRF (VRF c) InputVRF @@ -271,7 +270,7 @@ instance HasMaxMajorProtVer (Praos c) where -- an epoch. data PraosState = PraosState { praosStateLastSlot :: !(WithOrigin SlotNo) - , praosStateOCertCounters :: !(Map (KeyHash 'BlockIssuer) Word64) + , praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64) -- ^ Operation Certificate counters , praosStateEvolvingNonce :: !Nonce -- ^ Evolving nonce @@ -376,7 +375,7 @@ data PraosValidationErr c !Word64 -- max KES evolutions !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT - !(KeyHash 'BlockIssuer) -- stake pool key hash + !(KeyHash SL.BlockIssuer) -- stake pool key hash deriving Generic deriving instance PraosCrypto c => Eq (PraosValidationErr c) @@ -528,7 +527,7 @@ meetsLeaderThreshold :: forall c. ConsensusConfig (Praos c) -> LedgerView (Praos c) -> - SL.KeyHash 'SL.StakePool -> + SL.KeyHash SL.StakePool -> VRF.CertifiedVRF (VRF c) InputVRF -> Bool meetsLeaderThreshold @@ -595,7 +594,7 @@ validateKESSignature :: PraosCrypto c => ConsensusConfig (Praos c) -> LedgerView (Praos c) -> - Map (KeyHash 'BlockIssuer) Word64 -> + Map (KeyHash SL.BlockIssuer) Word64 -> Views.HeaderView c -> Except (PraosValidationErr c) () validateKESSignature @@ -614,7 +613,7 @@ doValidateKESSignature :: Word64 -> Word64 -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> - Map (KeyHash BlockIssuer) Word64 -> + Map (KeyHash SL.BlockIssuer) Word64 -> Views.HeaderView c -> Except (PraosValidationErr c) () doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 2c255a6089..a08b6edb29 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs @@ -83,7 +83,7 @@ class HasMaxMajorProtVer proto where -- length. data PraosTiebreakerView c = PraosTiebreakerView { ptvSlotNo :: SlotNo - , ptvIssuer :: SL.VKey 'SL.BlockIssuer + , ptvIssuer :: SL.VKey BlockIssuer , ptvIssueNo :: Word64 , ptvTieBreakVRF :: VRF.OutputVRF (VRF c) } @@ -254,7 +254,7 @@ instance Crypto c => ChainOrder (PraosTiebreakerView c) where preferCandidate cfg ours cand = comparePraos cfg ours cand == LT data PraosCanBeLeader c = PraosCanBeLeader - { praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer) + { praosCanBeLeaderColdVerKey :: !(SL.VKey BlockIssuer) -- ^ Stake pool cold key or genesis stakeholder delegate cold key. , praosCanBeLeaderSignKeyVRF :: !(SignKeyVRF (VRF c)) , praosCanBeLeaderCredentialsSource :: !(PraosCredentialsSource c) @@ -336,4 +336,4 @@ class ConsensusProtocol p => PraosProtocolSupportsNode p where getPraosNonces :: proxy p -> ChainDepState p -> PraosNonces - getOpCertCounters :: proxy p -> ChainDepState p -> Map (KeyHash 'BlockIssuer) Word64 + getOpCertCounters :: proxy p -> ChainDepState p -> Map (KeyHash BlockIssuer) Word64 diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs index 8f1aa4ade4..399a2080c7 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -87,7 +87,7 @@ data HeaderBody crypto = HeaderBody -- ^ block slot , hbPrev :: !PrevHash -- ^ Hash of the previous block header - , hbVk :: !(VKey 'BlockIssuer) + , hbVk :: !(VKey BlockIssuer) -- ^ verification key of block issuer , hbVrfVk :: !(VRF.VerKeyVRF (VRF crypto)) -- ^ VRF verification key for block issuer @@ -211,7 +211,7 @@ instance Crypto crypto => DecCBOR (HeaderBody crypto) where encodeHeaderRaw :: Crypto crypto => HeaderRaw crypto -> - Encode ('Closed 'Dense) (HeaderRaw crypto) + Encode (Closed Dense) (HeaderRaw crypto) encodeHeaderRaw (HeaderRaw body sig) = Rec HeaderRaw !> To body !> E encodeSignedKES sig diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index 3c0e8c8594..a8e1af5be2 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -22,7 +22,7 @@ import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) data HeaderView crypto = HeaderView { hvPrevHash :: !PrevHash -- ^ Hash of the previous block - , hvVK :: !(VKey 'BlockIssuer) + , hvVK :: !(VKey BlockIssuer) -- ^ verification key of block issuer , hvVrfVK :: !(VerKeyVRF (VRF crypto)) -- ^ VRF verification key for block issuer diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs index 478ce19b18..352e720dc0 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs @@ -106,7 +106,7 @@ deriving instance -- | Fields arising from transitional praos execution which must be included in -- the block signature. data TPraosToSign c = TPraosToSign - { tpraosToSignIssuerVK :: SL.VKey 'SL.BlockIssuer + { tpraosToSignIssuerVK :: SL.VKey SL.BlockIssuer -- ^ Verification key for the issuer of this block. -- -- Note that unlike in Classic/BFT where we have a key for the genesis @@ -432,7 +432,7 @@ meetsLeaderThreshold :: SL.PraosCrypto c => ConsensusConfig (TPraos c) -> LedgerView (TPraos c) -> - SL.KeyHash 'SL.StakePool -> + SL.KeyHash SL.StakePool -> VRF.CertifiedVRF (VRF c) SL.Seed -> Bool meetsLeaderThreshold From c430a7f5a22128db6bd430af6faacd31476bb014 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 4 Dec 2025 17:39:29 +0100 Subject: [PATCH 07/12] WIP update to latest Ledger and index states --- cabal.project | 9 ++++----- flake.lock | 12 ++++++------ 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/cabal.project b/cabal.project index d9412f2d4d..60cd66e810 100644 --- a/cabal.project +++ b/cabal.project @@ -14,9 +14,9 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2025-10-23T13:39:53Z + , hackage.haskell.org 2025-12-01T13:39:53Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-10-01T14:54:25Z + , cardano-haskell-packages 2025-12-01T07:41:27Z packages: ouroboros-consensus @@ -53,8 +53,8 @@ if impl (ghc >= 9.10) source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger - tag: 1258f444774a2360ab2d0cad1b9b1a7152b12bfa - --sha256: sha256-fqT8zlcreIZzGCZU9IX+7JqJM/Sjrd68ub96klEfw/w= + tag: f4dec1cb721e23f02aefbd74674c9f343bca61db + --sha256: sha256-yrdAtIzTQCgMuTpMEA5ch8op5MdSp47cXI90Nbp4KLU= subdir: eras/allegra/impl eras/alonzo/impl @@ -73,7 +73,6 @@ source-repository-package 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 diff --git a/flake.lock b/flake.lock index 65bf9573ef..54ca6a5743 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1761315163, - "narHash": "sha256-h+JPIMflNAOpY3XhZNcS5sUAOyO06499uWATj2j6P5Q=", + "lastModified": 1764582977, + "narHash": "sha256-PeIEFK8P22ZsEst7wIow9cJqDaDpeM8BtNIV9isZJaU=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "131bcd51c4869b191e8c3afbb9f3fd326cd6e5e1", + "rev": "80fdfffd6f59dda5025310b7b8e261fc5df202eb", "type": "github" }, "original": { @@ -270,11 +270,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1761733768, - "narHash": "sha256-49u0SAbp4J9MqqbtKeTo+mVFuwA1CDb/ssc+AZtjgiI=", + "lastModified": 1764864712, + "narHash": "sha256-g2LzJdR5R3bAbs8D4HyBk3IvlfnAUspdlPivLJlEPpg=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "35e8a092207e6d5d921efffc59ec0a3c1b450d48", + "rev": "bb1e9a636491e05aa06f1015568a78d9560408e8", "type": "github" }, "original": { From d826a9e7ae4bd4817de94e18da5d7a81b3342207 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Fri, 5 Dec 2025 12:54:49 +0100 Subject: [PATCH 08/12] WIP start integrating new Ledger --- .../src/shelley/Ouroboros/Consensus/Shelley/Eras.hs | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index cccfc1ab0b..5de6ed884c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -317,14 +317,4 @@ instance SupportsTwoPhaseValidation ConwayEra where _ -> False instance SupportsTwoPhaseValidation DijkstraEra where - isIncorrectClaimedFlag _ = \case - SL.ConwayUtxowFailure - ( Conway.UtxoFailure - ( Conway.UtxosFailure - ( Conway.ValidationTagMismatch - (Alonzo.IsValid _claimedFlag) - _validationErrs - ) - ) - ) -> True - _ -> False + isIncorrectClaimedFlag _ = error "TODO(ledger)" From 21315b6b1903290ee450b675c248ac3d14b3e516 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 5 Dec 2025 16:26:16 +0000 Subject: [PATCH 09/12] [wip] - Add missing (undefined!) `networkId` --- .../Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs | 3 ++- .../src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs | 6 ++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index fba14ecc5a..1f0bf211f3 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -42,7 +42,8 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto Map (SL.KeyHash SL.StakePool) SL.StakePoolParams (futurePoolParams, poolParams) = ( SL.psFutureStakePoolParams pstate - , Map.mapWithKey SL.stakePoolStateToStakePoolParams (SL.psStakePools pstate) + -- TODO: undefined + , Map.mapWithKey (\k v -> SL.stakePoolStateToStakePoolParams k undefined v) (SL.psStakePools pstate) ) -- Sort stake pools by descending stake diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index e25afa3c35..be8e9da1c0 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -429,11 +429,13 @@ instance GetStakePools -> SL.getPools st GetStakePoolParams poolids -> - SL.queryPoolParameters st poolids + -- TODO: networkId here + SL.queryPoolParameters undefined st poolids GetRewardInfoPools -> SL.getRewardInfoPools globals st GetPoolState mPoolIds -> - SL.queryPoolState st mPoolIds + -- TODO: networkId here + SL.queryPoolState st mPoolIds undefined GetStakeSnapshots mPoolIds -> let SL.SnapShots { SL.ssStakeMark From ab0a41274a9ac204c4b92727501c14e81f7f4ee4 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 5 Dec 2025 16:43:12 +0000 Subject: [PATCH 10/12] Fix`MaxTxSizeUTxO`,`ExUnitsTooBigUTxO`,`TxRefScriptsSizeTooBig`instances for DijkstraEra --- .../Ouroboros/Consensus/Shelley/Ledger/Mempool.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index c8da26202a..69a58d7d97 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -78,6 +78,7 @@ import Cardano.Ledger.Binary import qualified Cardano.Ledger.Conway.PParams as SL import qualified Cardano.Ledger.Conway.Rules as ConwayEra import qualified Cardano.Ledger.Conway.UTxO as SL +import qualified Cardano.Ledger.Dijkstra.Rules as DijkstraEra import qualified Cardano.Ledger.Hashes as SL import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Rules as ShelleyEra @@ -483,9 +484,9 @@ instance MaxTxSizeUTxO ConwayEra where instance MaxTxSizeUTxO DijkstraEra where maxTxSizeUTxO txSize txSizeLimit = SL.ApplyTxError . pure $ - ConwayEra.ConwayUtxowFailure $ - ConwayEra.UtxoFailure $ - ConwayEra.MaxTxSizeUTxO $ + DijkstraEra.DijkstraUtxowFailure $ + DijkstraEra.UtxoFailure $ + DijkstraEra.MaxTxSizeUTxO $ L.Mismatch { mismatchSupplied = txSize , mismatchExpected = txSizeLimit @@ -620,9 +621,9 @@ instance ExUnitsTooBigUTxO ConwayEra where instance ExUnitsTooBigUTxO DijkstraEra where exUnitsTooBigUTxO txsz limit = SL.ApplyTxError . pure $ - ConwayEra.ConwayUtxowFailure $ - ConwayEra.UtxoFailure $ - ConwayEra.ExUnitsTooBigUTxO $ + DijkstraEra.DijkstraUtxowFailure $ + DijkstraEra.UtxoFailure $ + DijkstraEra.ExUnitsTooBigUTxO $ L.Mismatch { mismatchSupplied = txsz , mismatchExpected = limit @@ -764,7 +765,7 @@ instance TxRefScriptsSizeTooBig ConwayEra where instance TxRefScriptsSizeTooBig DijkstraEra where txRefScriptsSizeTooBig txsz limit = SL.ApplyTxError . pure $ - ConwayEra.ConwayTxRefScriptsSizeTooBig $ + DijkstraEra.DijkstraTxRefScriptsSizeTooBig $ L.Mismatch { mismatchSupplied = txsz , mismatchExpected = limit From b37c7404c3f3cbeb57ea9172a9f467abe5a3ec3b Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 5 Dec 2025 16:44:02 +0000 Subject: [PATCH 11/12] Implement `SupportsTwoPhaseValidation` instance for `DijkstraEra` --- .../shelley/Ouroboros/Consensus/Shelley/Eras.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index 5de6ed884c..149ca2643d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -53,6 +53,10 @@ import qualified Cardano.Ledger.Conway.Rules as SL ) import qualified Cardano.Ledger.Conway.State as CG import Cardano.Ledger.Dijkstra (DijkstraEra) +import qualified Cardano.Ledger.Dijkstra.Rules as Dijkstra +import qualified Cardano.Ledger.Dijkstra.Rules as SL + (DijkstraLedgerPredFailure (..) + ) import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Shelley (ShelleyEra) import qualified Cardano.Ledger.Shelley.API as SL @@ -317,4 +321,14 @@ instance SupportsTwoPhaseValidation ConwayEra where _ -> False instance SupportsTwoPhaseValidation DijkstraEra where - isIncorrectClaimedFlag _ = error "TODO(ledger)" + isIncorrectClaimedFlag _ = \case + SL.DijkstraUtxowFailure + ( Dijkstra.UtxoFailure + ( Dijkstra.UtxosFailure + ( Conway.ValidationTagMismatch + (Alonzo.IsValid _claimedFlag) + _validationErrs + ) + ) + ) -> True + _ -> False From c900684a5a6a1d8fe780e2469fe01771b2f3c2c6 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Fri, 5 Dec 2025 17:32:36 +0000 Subject: [PATCH 12/12] Replace usage of deprecated `StakeCredential` --- .../src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index be8e9da1c0..17f1895f9b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -54,7 +54,6 @@ import Cardano.Ledger.Compactible (Compactible (fromCompact)) import qualified Cardano.Ledger.Conway.Governance as CG import qualified Cardano.Ledger.Conway.State as CG import qualified Cardano.Ledger.Core as SL -import Cardano.Ledger.Credential (StakeCredential) import Cardano.Ledger.Keys (KeyHash) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Core as LC @@ -261,11 +260,11 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where QFNoTables (PoolDistr (ProtoCrypto proto)) GetStakeDelegDeposits :: - Set StakeCredential -> + Set (SL.Credential LC.Staking) -> BlockQuery (ShelleyBlock proto era) QFNoTables - (Map StakeCredential Coin) + (Map (SL.Credential LC.Staking) Coin) -- | Not supported in eras before Conway GetConstitution :: CG.ConwayEraGov era =>