From 8963273bdc60e7e3039e353f4bab538c158f6a5e Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 00:59:13 -0400 Subject: [PATCH 01/19] Praos2: introduce Praos2, via shared types and functions This commit is best reviewed with `git diff -w`, to suppress the whitespace changes. This incurs some duplication (notably signatures), but it's worth it. - The duplication is not overly burdensome to compensate for by factoring the Praos impl so its types and functions can be reused as much as possible. For Leios, at least, that's easy since Leios only adds a few independent fields to the header semantics. - Duplicating instances between Praos and PraosWithLeios instead of having them share some instances (ala a shared-head `BasePraos leiosFlag` protocol type) has a couple benefits. First, most code outside of the PolyPraos functions are either monomorphic or reuses the existing parameterizations over `proto`, which is already ubiquitous. Second, it avoids _implicit_ reuse of today's Praos's rules for Leios, which makes _accidental_ reuse less likely---compare to type class method defaults. We do _not_ duplicate more than we need to, though. In particular, many of Praos's data types and some of its classes gain a `proto` parameter, which is used so that the single data type definition can be reused for Praos with and without Leios. The benefit is that there is just one constructor/field per Praos concept, regardless of whether Leios is enabled. This is not a fully modular design: subsequent additional extensions will also need to add to these same definitions (eg adding fields for Ouroboros Phalanx). That is intentional. This code does not need to be classically extensible, since there is, unfortunately, no such thing as an extensible security proof. Our protocol changes are well studied before implemented, and have never happened concurrently. In other words: it's a very important benefit that there is _one definition_ to look at in order to see everything all of the Praos extensions _cumulatively_ do. The type-level DSL used to isolate extension components is simple and legible; see the `LeiosOnly` data family. --- .../Ouroboros/Consensus/Cardano/Block.hs | 42 +- .../Consensus/Cardano/CanHardFork.hs | 30 +- .../Ouroboros/Consensus/Cardano/Ledger.hs | 3 +- .../Ouroboros/Consensus/Cardano/Node.hs | 18 +- .../Ouroboros/Consensus/Shelley/HFEras.hs | 41 +- .../Consensus/Shelley/Ledger/Forge.hs | 12 +- .../Consensus/Shelley/Ledger/Mempool.hs | 4 +- .../Consensus/Shelley/Ledger/Protocol.hs | 3 +- .../Shelley/Ledger/SupportsProtocol.hs | 100 ++- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 42 +- .../Consensus/Shelley/Node/Serialisation.hs | 13 +- .../Consensus/Shelley/Protocol/Abstract.hs | 15 +- .../Consensus/Shelley/Protocol/Praos.hs | 269 ++++-- .../Consensus/Shelley/Protocol/TPraos.hs | 5 +- .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 13 + .../Test/Consensus/Cardano/MockCrypto.hs | 9 + .../Test/Consensus/Shelley/Examples.hs | 104 ++- .../Test/Consensus/Shelley/MockCrypto.hs | 3 + .../Test/Consensus/Cardano/Capacity.hs | 9 +- .../Test/Consensus/Cardano/Translation.hs | 5 +- .../Ouroboros/Consensus/Protocol/Praos.hs | 776 +++++++++++++----- .../Consensus/Protocol/Praos/Common.hs | 66 +- .../Consensus/Protocol/Praos/Orphans.hs | 17 + .../Consensus/Protocol/Praos/Views.hs | 98 ++- .../Ouroboros/Consensus/Protocol/Praos2.hs | 220 +++++ .../Ouroboros/Consensus/Protocol/TPraos.hs | 26 + .../Protocol/Serialisation/Generators.hs | 23 +- .../Consensus/Protocol/Praos/Header.hs | 2 +- ouroboros-consensus.cabal | 5 +- .../Ouroboros/Consensus/Config.hs | 9 + .../Ouroboros/Consensus/Leios/Types.hs | 34 + .../Ouroboros/Consensus/Protocol/Abstract.hs | 3 + 32 files changed, 1566 insertions(+), 453 deletions(-) create mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs create mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs index 222f6ace2f..dd989c825a 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs @@ -228,6 +228,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool ) import Ouroboros.Consensus.Protocol.Abstract (ChainDepState) import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) @@ -253,7 +254,7 @@ type CardanoShelleyEras c = , ShelleyBlock (TPraos c) AlonzoEra , ShelleyBlock (Praos c) BabbageEra , ShelleyBlock (Praos c) ConwayEra - , ShelleyBlock (Praos c) DijkstraEra + , ShelleyBlock (Praos2 c) DijkstraEra ] type ShelleyBasedLedgerEras :: Type -> [Type] @@ -281,7 +282,7 @@ pattern TagMary :: f (ShelleyBlock (TPraos c) MaryEra) -> NS f (CardanoEras c) pattern TagAlonzo :: f (ShelleyBlock (TPraos c) AlonzoEra) -> NS f (CardanoEras c) pattern TagBabbage :: f (ShelleyBlock (Praos c) BabbageEra) -> NS f (CardanoEras c) pattern TagConway :: f (ShelleyBlock (Praos c) ConwayEra) -> NS f (CardanoEras c) -pattern TagDijkstra :: f (ShelleyBlock (Praos c) DijkstraEra) -> NS f (CardanoEras c) +pattern TagDijkstra :: f (ShelleyBlock (Praos2 c) DijkstraEra) -> NS f (CardanoEras c) pattern TagByron x = Z x pattern TagShelley x = S (Z x) @@ -303,7 +304,8 @@ pattern EraMary :: K () (ShelleyBlock (TPraos c) MaryEra) -> EraIndex (CardanoEr pattern EraAlonzo :: K () (ShelleyBlock (TPraos c) AlonzoEra) -> EraIndex (CardanoEras c) pattern EraBabbage :: K () (ShelleyBlock (Praos c) BabbageEra) -> EraIndex (CardanoEras c) pattern EraConway :: K () (ShelleyBlock (Praos c) ConwayEra) -> EraIndex (CardanoEras c) -pattern EraDijkstra :: K () (ShelleyBlock (Praos c) DijkstraEra) -> EraIndex (CardanoEras c) +pattern EraDijkstra :: + K () (ShelleyBlock (Praos2 c) DijkstraEra) -> EraIndex (CardanoEras c) pattern EraByron x = EraIndex (TagByron x) pattern EraShelley x = EraIndex (TagShelley x) @@ -387,7 +389,7 @@ pattern TeleDijkstra :: g (ShelleyBlock (TPraos c) AlonzoEra) -> g (ShelleyBlock (Praos c) BabbageEra) -> g (ShelleyBlock (Praos c) ConwayEra) -> - f (ShelleyBlock (Praos c) DijkstraEra) -> + f (ShelleyBlock (Praos2 c) DijkstraEra) -> Telescope g f (CardanoEras c) -- Here we use layout and adjacency to make it obvious that we haven't @@ -448,7 +450,7 @@ pattern BlockBabbage b = HardForkBlock (OneEraBlock (TagBabbage (I b))) pattern BlockConway :: ShelleyBlock (Praos c) ConwayEra -> CardanoBlock c pattern BlockConway b = HardForkBlock (OneEraBlock (TagConway (I b))) -pattern BlockDijkstra :: ShelleyBlock (Praos c) DijkstraEra -> CardanoBlock c +pattern BlockDijkstra :: ShelleyBlock (Praos2 c) DijkstraEra -> CardanoBlock c pattern BlockDijkstra b = HardForkBlock (OneEraBlock (TagDijkstra (I b))) {-# COMPLETE @@ -503,7 +505,7 @@ pattern HeaderConway :: pattern HeaderConway h = HardForkHeader (OneEraHeader (TagConway h)) pattern HeaderDijkstra :: - Header (ShelleyBlock (Praos c) DijkstraEra) -> + Header (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoHeader c pattern HeaderDijkstra h = HardForkHeader (OneEraHeader (TagDijkstra h)) @@ -546,7 +548,7 @@ pattern GenTxBabbage tx = HardForkGenTx (OneEraGenTx (TagBabbage tx)) pattern GenTxConway :: GenTx (ShelleyBlock (Praos c) ConwayEra) -> CardanoGenTx c pattern GenTxConway tx = HardForkGenTx (OneEraGenTx (TagConway tx)) -pattern GenTxDijkstra :: GenTx (ShelleyBlock (Praos c) DijkstraEra) -> CardanoGenTx c +pattern GenTxDijkstra :: GenTx (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoGenTx c pattern GenTxDijkstra tx = HardForkGenTx (OneEraGenTx (TagDijkstra tx)) {-# COMPLETE @@ -604,7 +606,7 @@ pattern GenTxIdConway txid = HardForkGenTxId (OneEraGenTxId (TagConway (WrapGenTxId txid))) pattern GenTxIdDijkstra :: - GenTxId (ShelleyBlock (Praos c) DijkstraEra) -> + GenTxId (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoGenTxId c pattern GenTxIdDijkstra txid = HardForkGenTxId (OneEraGenTxId (TagDijkstra (WrapGenTxId txid))) @@ -678,7 +680,7 @@ pattern ApplyTxErrConway err = HardForkApplyTxErrFromEra (OneEraApplyTxErr (TagConway (WrapApplyTxErr err))) pattern ApplyTxErrDijkstra :: - ApplyTxErr (ShelleyBlock (Praos c) DijkstraEra) -> + ApplyTxErr (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoApplyTxErr c pattern ApplyTxErrDijkstra err = HardForkApplyTxErrFromEra (OneEraApplyTxErr (TagDijkstra (WrapApplyTxErr err))) @@ -767,7 +769,7 @@ pattern LedgerErrorConway err = (OneEraLedgerError (TagConway (WrapLedgerErr err))) pattern LedgerErrorDijkstra :: - LedgerError (ShelleyBlock (Praos c) DijkstraEra) -> + LedgerError (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoLedgerError c pattern LedgerErrorDijkstra err = HardForkLedgerErrorFromEra @@ -840,7 +842,7 @@ pattern OtherHeaderEnvelopeErrorConway err = HardForkEnvelopeErrFromEra (OneEraEnvelopeErr (TagConway (WrapEnvelopeErr err))) pattern OtherHeaderEnvelopeErrorDijkstra :: - OtherHeaderEnvelopeError (ShelleyBlock (Praos c) DijkstraEra) -> + OtherHeaderEnvelopeError (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoOtherHeaderEnvelopeError c pattern OtherHeaderEnvelopeErrorDijkstra err = HardForkEnvelopeErrFromEra (OneEraEnvelopeErr (TagDijkstra (WrapEnvelopeErr err))) @@ -904,7 +906,7 @@ pattern TipInfoConway :: pattern TipInfoConway ti = OneEraTipInfo (TagConway (WrapTipInfo ti)) pattern TipInfoDijkstra :: - TipInfo (ShelleyBlock (Praos c) DijkstraEra) -> + TipInfo (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoTipInfo c pattern TipInfoDijkstra ti = OneEraTipInfo (TagDijkstra (WrapTipInfo ti)) @@ -987,7 +989,7 @@ pattern QueryIfCurrentConway :: pattern QueryIfCurrentDijkstra :: () => CardanoQueryResult c result ~ a => - BlockQuery (ShelleyBlock (Praos c) DijkstraEra) fp result -> + BlockQuery (ShelleyBlock (Praos2 c) DijkstraEra) fp result -> CardanoQuery c fp a -- Here we use layout and adjacency to make it obvious that we haven't @@ -1151,7 +1153,7 @@ pattern CardanoCodecConfig :: CodecConfig (ShelleyBlock (TPraos c) AlonzoEra) -> CodecConfig (ShelleyBlock (Praos c) BabbageEra) -> CodecConfig (ShelleyBlock (Praos c) ConwayEra) -> - CodecConfig (ShelleyBlock (Praos c) DijkstraEra) -> + CodecConfig (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoCodecConfig c pattern CardanoCodecConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = HardForkCodecConfig @@ -1189,7 +1191,7 @@ pattern CardanoBlockConfig :: BlockConfig (ShelleyBlock (TPraos c) AlonzoEra) -> BlockConfig (ShelleyBlock (Praos c) BabbageEra) -> BlockConfig (ShelleyBlock (Praos c) ConwayEra) -> - BlockConfig (ShelleyBlock (Praos c) DijkstraEra) -> + BlockConfig (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoBlockConfig c pattern CardanoBlockConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = HardForkBlockConfig @@ -1227,7 +1229,7 @@ pattern CardanoStorageConfig :: StorageConfig (ShelleyBlock (TPraos c) AlonzoEra) -> StorageConfig (ShelleyBlock (Praos c) BabbageEra) -> StorageConfig (ShelleyBlock (Praos c) ConwayEra) -> - StorageConfig (ShelleyBlock (Praos c) DijkstraEra) -> + StorageConfig (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoStorageConfig c pattern CardanoStorageConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra = HardForkStorageConfig @@ -1268,7 +1270,7 @@ pattern CardanoConsensusConfig :: PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) AlonzoEra)) -> PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) BabbageEra)) -> PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) ConwayEra)) -> - PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) DijkstraEra)) -> + PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos2 c) DijkstraEra)) -> CardanoConsensusConfig c pattern CardanoConsensusConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra <- HardForkConsensusConfig @@ -1308,7 +1310,7 @@ pattern CardanoLedgerConfig :: PartialLedgerConfig (ShelleyBlock (TPraos c) AlonzoEra) -> PartialLedgerConfig (ShelleyBlock (Praos c) BabbageEra) -> PartialLedgerConfig (ShelleyBlock (Praos c) ConwayEra) -> - PartialLedgerConfig (ShelleyBlock (Praos c) DijkstraEra) -> + PartialLedgerConfig (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoLedgerConfig c pattern CardanoLedgerConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfgBabbage cfgConway cfgDijkstra <- HardForkLedgerConfig @@ -1404,7 +1406,7 @@ pattern LedgerStateConway st <- ) pattern LedgerStateDijkstra :: - LedgerState (ShelleyBlock (Praos c) DijkstraEra) mk -> + LedgerState (ShelleyBlock (Praos2 c) DijkstraEra) mk -> CardanoLedgerState c mk pattern LedgerStateDijkstra st <- HardForkLedgerState @@ -1485,7 +1487,7 @@ pattern ChainDepStateConway st <- (TeleConway _ _ _ _ _ _ (State.Current{currentState = WrapChainDepState st})) pattern ChainDepStateDijkstra :: - ChainDepState (BlockProtocol (ShelleyBlock (Praos c) DijkstraEra)) -> + ChainDepState (BlockProtocol (ShelleyBlock (Praos2 c) DijkstraEra)) -> CardanoChainDepState c pattern ChainDepStateDijkstra st <- State.HardForkState diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index 04ae3f946e..04608a0e72 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -95,6 +95,7 @@ import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos import Ouroboros.Consensus.Protocol.Praos.Common (PraosTiebreakerView) +import Ouroboros.Consensus.Protocol.Praos2 (LeiosCrypto, Praos2) import Ouroboros.Consensus.Protocol.TPraos import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.HFEras () @@ -112,13 +113,14 @@ import Ouroboros.Consensus.Util (coerceMapKeys) type CardanoHardForkConstraints c = ( TPraos.PraosCrypto c , Praos.PraosCrypto c + , LeiosCrypto c , LedgerSupportsProtocol (ShelleyBlock (TPraos c) ShelleyEra) , LedgerSupportsProtocol (ShelleyBlock (TPraos c) AllegraEra) , LedgerSupportsProtocol (ShelleyBlock (TPraos c) MaryEra) , LedgerSupportsProtocol (ShelleyBlock (TPraos c) AlonzoEra) , LedgerSupportsProtocol (ShelleyBlock (Praos c) BabbageEra) , LedgerSupportsProtocol (ShelleyBlock (Praos c) ConwayEra) - , LedgerSupportsProtocol (ShelleyBlock (Praos c) DijkstraEra) + , LedgerSupportsProtocol (ShelleyBlock (Praos2 c) DijkstraEra) ) -- | When performing era translations, two eras have special behaviours on the @@ -134,7 +136,7 @@ type CardanoHardForkConstraints c = instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where type HardForkTxMeasurePhase1 (CardanoEras c) = AlonzoMeasure type HardForkTxMeasurePhase2 (CardanoEras c) = RefScriptSize - type HardForkTxEbMeasure (CardanoEras c) = TxEbMeasure (ShelleyBlock (Praos c) DijkstraEra) + type HardForkTxEbMeasure (CardanoEras c) = TxEbMeasure (ShelleyBlock (Praos2 c) DijkstraEra) hardForkEraTranslation = EraTranslation @@ -273,10 +275,10 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where } hardForkTxEbMeasure _ p1 p2 = - txEbMeasure (Proxy @(ShelleyBlock (Praos c) DijkstraEra)) (TxMeasure p1 p2) + txEbMeasure (Proxy @(ShelleyBlock (Praos2 c) DijkstraEra)) (TxMeasure p1 p2) hardForkMempoolEbReservation _ eb = - let TxMeasure p1 p2 = mempoolEbReservation (Proxy @(ShelleyBlock (Praos c) DijkstraEra)) eb + let TxMeasure p1 p2 = mempoolEbReservation (Proxy @(ShelleyBlock (Praos2 c) DijkstraEra)) eb in (p1, p2) -- Both ids are ordered by their txid hash, ignoring the era. Equality reuses @@ -715,7 +717,7 @@ translateLedgerStateConwayToDijkstraWrapper :: WrapLedgerConfig TranslateLedgerState (ShelleyBlock (Praos c) ConwayEra) - (ShelleyBlock (Praos c) DijkstraEra) + (ShelleyBlock (Praos2 c) DijkstraEra) translateLedgerStateConwayToDijkstraWrapper = RequireBoth $ \_cfgConway cfgDijkstra -> TranslateLedgerState @@ -726,12 +728,26 @@ translateLedgerStateConwayToDijkstraWrapper = . SL.translateEra' (getDijkstraTranslationContext cfgDijkstra) . Comp . Flip + . transLeiosLS + } + where + -- Only the protocol index changes, so nothing in here is converted; the + -- rebuild is what retypes it. + transLeiosLS :: + LedgerState (ShelleyBlock (Praos c) ConwayEra) mk -> + LedgerState (ShelleyBlock (Praos2 c) ConwayEra) mk + transLeiosLS (ShelleyLedgerState wo nes st tb) = + ShelleyLedgerState + { shelleyLedgerTip = fmap castShelleyTip wo + , shelleyLedgerState = nes + , shelleyLedgerTransition = st + , shelleyLedgerTables = coerce tb } translateLedgerTablesConwayToDijkstraWrapper :: TranslateLedgerTables (ShelleyBlock (Praos c) ConwayEra) - (ShelleyBlock (Praos c) DijkstraEra) + (ShelleyBlock (Praos2 c) DijkstraEra) translateLedgerTablesConwayToDijkstraWrapper = TranslateLedgerTables { translateTxInWith = coerce @@ -739,7 +755,7 @@ translateLedgerTablesConwayToDijkstraWrapper = } getDijkstraTranslationContext :: - WrapLedgerConfig (ShelleyBlock (Praos c) DijkstraEra) -> + WrapLedgerConfig (ShelleyBlock (Praos2 c) DijkstraEra) -> SL.TranslationContext DijkstraEra getDijkstraTranslationContext = shelleyLedgerTranslationContext . unwrapLedgerConfig diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs index 6504e56fe1..f279a0488a 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs @@ -51,6 +51,7 @@ import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.Ledger.Tables import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger ( BigEndianTxIn @@ -107,7 +108,7 @@ data CardanoTxOut c | AlonzoTxOut !(TxOut (ShelleyBlock (TPraos c) AlonzoEra)) | BabbageTxOut !(TxOut (ShelleyBlock (Praos c) BabbageEra)) | ConwayTxOut !(TxOut (ShelleyBlock (Praos c) ConwayEra)) - | DijkstraTxOut !(TxOut (ShelleyBlock (Praos c) DijkstraEra)) + | DijkstraTxOut !(TxOut (ShelleyBlock (Praos2 c) DijkstraEra)) deriving stock (Show, Eq, Generic) deriving anyclass NoThunks diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index a06e55be69..10a2bdee7d 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -104,6 +104,7 @@ import Ouroboros.Consensus.Protocol.Praos.Common ( PraosCanBeLeader (..) , instantiatePraosCredentials ) +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..)) import qualified Ouroboros.Consensus.Protocol.TPraos as Shelley import Ouroboros.Consensus.Shelley.HFEras () @@ -423,7 +424,7 @@ pattern CardanoHardForkTriggers' :: CardanoHardForkTrigger (ShelleyBlock (TPraos c) AlonzoEra) -> CardanoHardForkTrigger (ShelleyBlock (Praos c) BabbageEra) -> CardanoHardForkTrigger (ShelleyBlock (Praos c) ConwayEra) -> - CardanoHardForkTrigger (ShelleyBlock (Praos c) DijkstraEra) -> + CardanoHardForkTrigger (ShelleyBlock (Praos2 c) DijkstraEra) -> CardanoHardForkTriggers pattern CardanoHardForkTriggers' { triggerHardForkShelley @@ -769,7 +770,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano -- Dijkstra - blockConfigDijkstra :: BlockConfig (ShelleyBlock (Praos c) DijkstraEra) + blockConfigDijkstra :: BlockConfig (ShelleyBlock (Praos2 c) DijkstraEra) blockConfigDijkstra = Shelley.mkShelleyBlockConfig cardanoProtocolVersion @@ -777,10 +778,10 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano (shelleyBlockIssuerVKey <$> credssShelleyBased) partialConsensusConfigDijkstra :: - PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) DijkstraEra)) + PartialConsensusConfig (BlockProtocol (ShelleyBlock (Praos2 c) DijkstraEra)) partialConsensusConfigDijkstra = praosParams - partialLedgerConfigDijkstra :: PartialLedgerConfig (ShelleyBlock (Praos c) DijkstraEra) + partialLedgerConfigDijkstra :: PartialLedgerConfig (ShelleyBlock (Praos2 c) DijkstraEra) partialLedgerConfigDijkstra = partialLedgerConfigForLastKnownEra transitionConfigDijkstra @@ -1039,6 +1040,13 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano praos = Praos.praosSharedBlockForging hotKey slotToPeriod credentials + let praos2 :: + forall era. + Shelley.ShelleyCompatible (Praos2 c) era => + BlockForging m (ShelleyBlock (Praos2 c) era) + praos2 = + Praos.praos2SharedBlockForging hotKey slotToPeriod credentials + pure $ OptSkip $ -- Byron OptNP.fromNonEmptyNP $ @@ -1048,7 +1056,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano :* tpraos :* praos :* praos - :* praos + :* praos2 :* Nil protocolClientInfoCardano :: diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index 8bf2c2ffb7..d67936f605 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -16,20 +16,10 @@ module Ouroboros.Consensus.Shelley.HFEras , StandardShelleyBlock ) where -import Cardano.Ledger.BaseTypes (ProtVer (..)) -import Cardano.Ledger.Binary (getVersion32, mkVersion32) -import Cardano.Ledger.Block - ( BlockHeaderVersionInfo (..) - , LeiosEraBlockHeader (..) - , PraosEraBlockHeader (..) - ) import Cardano.Protocol.Crypto -import Cardano.Protocol.Praos.BlockHeader (Header) -import Data.Maybe (fromMaybe) -import Data.Maybe.Strict (StrictMaybe (SNothing)) -import Lens.Micro (lens) import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos +import Ouroboros.Consensus.Protocol.Praos2 (LeiosCrypto, Praos2) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.Eras @@ -66,7 +56,7 @@ type StandardBabbageBlock = ShelleyBlock (Praos StandardCrypto) BabbageEra type StandardConwayBlock = ShelleyBlock (Praos StandardCrypto) ConwayEra -type StandardDijkstraBlock = ShelleyBlock (Praos StandardCrypto) DijkstraEra +type StandardDijkstraBlock = ShelleyBlock (Praos2 StandardCrypto) DijkstraEra {------------------------------------------------------------------------------- ShelleyCompatible @@ -92,29 +82,4 @@ instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) BabbageEra instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) ConwayEra -instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) DijkstraEra - --- | The ledger expects Dijkstra blocks to carry a Leios block header, but --- consensus still uses the Praos header for the Dijkstra era, so this instance --- adapts the Praos header to the Leios interface: --- --- * The version info is the header's protocol version, which has the same wire --- format: the major version is the highest supported major version and the --- minor version is the self-reported software tag. A major version that is --- not a valid 'Version' is clamped to 'maxBound' when set. --- --- * A Praos header never announces Endorser Block references, so the --- announcement always reads as 'SNothing' and setting it has no effect. --- --- * The previous nonce uses the class default ('NeutralNonce'), which the --- ledger itself describes as a stub until Peras is implemented. --- --- TODO @js: use the Leios block header from @cardano-protocol@ for the Dijkstra --- era and remove this instance. -instance Crypto c => LeiosEraBlockHeader (Header c) DijkstraEra where - versionInfoBlockHeaderL = - protVerBlockHeaderL - . lens - (\(ProtVer major minor) -> BlockHeaderVersionInfo (getVersion32 major) minor) - (\_ (BlockHeaderVersionInfo major tag) -> ProtVer (fromMaybe maxBound (mkVersion32 major)) tag) - ebReferencesAnnouncementBlockHeaderL = lens (const SNothing) const +instance LeiosCrypto c => ShelleyCompatible (Praos2 c) DijkstraEra 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 c9672c091a..2008ef8403 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -14,6 +15,7 @@ import qualified Cardano.Ledger.Core as SL import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractValidatedTx) import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Control.Exception +import Data.Maybe.Strict (StrictMaybe (SNothing)) import qualified Data.Sequence.Strict as Seq import Lens.Micro ((&), (.~)) import Ouroboros.Consensus.Block @@ -22,6 +24,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) +import Ouroboros.Consensus.Protocol.Praos.Common (LeiosOnly, pureLeiosOnly) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config ( shelleyProtocolVersion @@ -40,7 +43,10 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract forgeShelleyBlock :: forall m era proto. - (ShelleyCompatible proto era, Monad m) => + ( ShelleyCompatible proto era + , Applicative (LeiosOnly proto ()) + , Monad m + ) => HotKey (ProtoCrypto proto) m -> CanBeLeader proto -> ForgeBlockArgs (ShelleyBlock proto era) -> @@ -61,6 +67,7 @@ forgeShelleyBlock (SL.hashBlockBody @era body) actualBodySize protocolVersion + leiosFields let blk = mkShelleyBlock $ SL.Block hdr body return $ assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus fbConfig) blk) $ @@ -68,6 +75,9 @@ forgeShelleyBlock where protocolVersion = shelleyProtocolVersion $ configBlock fbConfig + -- TODO Forging does not yet certify or announce endorser blocks. + leiosFields = pureLeiosOnly @proto (False, SNothing) + body = SL.mkBasicBlockBody & SL.txSeqBlockBodyL 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 d92bce8208..eb6582775a 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 @@ -116,7 +116,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables.Utils import qualified Ouroboros.Consensus.Leios.Types as Leios -import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger @@ -810,7 +810,7 @@ instance TxRefScriptsSizeTooBig DijkstraEra where -- measures do not depend on the protocol, so 'txEbMeasureDijkstra' and -- 'mempoolEbReservation' rebuild the 'TxMeasure' for any protocol. data DijkstraEbMeasure = DijkstraEbMeasure - { ebClosureMeasure :: !(TxMeasure (ShelleyBlock (Praos StandardCrypto) DijkstraEra)) + { ebClosureMeasure :: !(TxMeasure (ShelleyBlock (Praos2 StandardCrypto) DijkstraEra)) , txReferencesSize :: !(IgnoringOverflow ByteSize32) -- ^ Size of transaction references _excluding_ any framing overhead: of one -- transaction's reference, or summed over whatever is measured (an endorser 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 7358637a11..2b5fab4c7e 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 @@ -15,8 +15,7 @@ import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config (BlockConfig (..)) import Ouroboros.Consensus.Shelley.Protocol.Abstract - ( ShelleyProtocolHeader - , pHeaderIssueNo + ( pHeaderIssueNo , pHeaderIssuer , pTieBreakVRFValue , protocolHeaderView diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index 00f15b7209..426642aa5e 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -13,11 +13,10 @@ -- instance for 'ShelleyBlock'. module Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () where -import qualified Cardano.Ledger.Core as LedgerCore +import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except (MonadError (throwError)) -import qualified Lens.Micro import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.History.Util @@ -28,6 +27,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos (PraosCrypto) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger @@ -83,45 +83,67 @@ instance ) => LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era) where - protocolLedgerView _cfg st = - let nes = tickedShelleyLedgerState st + protocolLedgerView = protocolLedgerViewPolyPraos + ledgerViewForecastAt = ledgerViewForecastAtPolyPraos - SL.NewEpochState{nesPd} = nes +-- | 'protocolLedgerView' for every Praos. +-- +-- Uses the same projection as 'ledgerViewForecastAtPolyPraos', so the two agree. +protocolLedgerViewPolyPraos :: + forall proto era mk. + ( Praos.ForecastsLeios proto era + , SL.EraForecast era + ) => + LedgerConfig (ShelleyBlock proto era) -> + Ticked LedgerState (ShelleyBlock proto era) mk -> + Praos.PolyPraosLedgerView proto +protocolLedgerViewPolyPraos _cfg = + Praos.forecastToPolyPraosLedgerView . SL.currentForecast . tickedShelleyLedgerState - pparam :: forall a. Lens.Micro.Lens' (LedgerCore.PParams era) a -> a - pparam lens = getPParams nes Lens.Micro.^. lens - in Praos.PraosLedgerView - { Praos.plvPoolDistr = nesPd - , Praos.plvMaxBodySize = pparam LedgerCore.ppMaxBBSizeL - , Praos.plvMaxHeaderSize = pparam LedgerCore.ppMaxBHSizeL - , Praos.plvProtocolVersion = pparam LedgerCore.ppProtocolVersionL - } +-- | 'ledgerViewForecastAt' for every Praos. +ledgerViewForecastAtPolyPraos :: + forall proto era mk. + ( ShelleyCompatible proto era + , Praos.ForecastsLeios proto era + ) => + LedgerConfig (ShelleyBlock proto era) -> + LedgerState (ShelleyBlock proto era) mk -> + Forecast (Praos.PolyPraosLedgerView proto) +ledgerViewForecastAtPolyPraos cfg ledgerState = Forecast at $ \for -> + if + | NotOrigin for == at -> + return $ + Praos.forecastToPolyPraosLedgerView (SL.currentForecast shelleyLedgerState) + | for < maxFor -> + return $ futureLedgerView for + | otherwise -> + throwError $ + OutsideForecastRange + { outsideForecastAt = at + , outsideForecastMaxFor = maxFor + , outsideForecastFor = for + } + where + ShelleyLedgerState{shelleyLedgerState} = ledgerState + globals = shelleyLedgerGlobals cfg + swindow = SL.stabilityWindow globals + at = ledgerTipSlot ledgerState - ledgerViewForecastAt cfg ledgerState = Forecast at $ \for -> - if - | NotOrigin for == at -> - return $ - Praos.forecastToPraosLedgerView (SL.currentForecast shelleyLedgerState) - | for < maxFor -> - return $ futureLedgerView for - | otherwise -> - throwError $ - OutsideForecastRange - { outsideForecastAt = at - , outsideForecastMaxFor = maxFor - , outsideForecastFor = for - } - where - ShelleyLedgerState{shelleyLedgerState} = ledgerState - globals = shelleyLedgerGlobals cfg - swindow = SL.stabilityWindow globals - at = ledgerTipSlot ledgerState + futureLedgerView :: SlotNo -> Praos.PolyPraosLedgerView proto + futureLedgerView for = + Praos.forecastToPolyPraosLedgerView $ + SL.futureForecast globals for shelleyLedgerState - futureLedgerView :: SlotNo -> Praos.PraosLedgerView - futureLedgerView for = - Praos.forecastToPraosLedgerView $ - SL.futureForecast globals for shelleyLedgerState + -- Exclusive upper bound + maxFor :: SlotNo + maxFor = addSlots swindow $ succWithOrigin at - -- Exclusive upper bound - maxFor :: SlotNo - maxFor = addSlots swindow $ succWithOrigin at +instance + ( ShelleyCompatible (Praos2 c) era + , Dijkstra.DijkstraEraForecast era + , SL.EraForecast era + ) => + LedgerSupportsProtocol (ShelleyBlock (Praos2 c) era) + where + protocolLedgerView = protocolLedgerViewPolyPraos + ledgerViewForecastAt = ledgerViewForecastAtPolyPraos diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index 622ac0710e..a02568c11f 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -3,12 +3,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Node.Praos ( -- * BlockForging praosBlockForging , praosSharedBlockForging + , praos2SharedBlockForging ) where import qualified Cardano.Ledger.Api.Era as L @@ -17,12 +19,16 @@ import qualified Cardano.Protocol.TPraos.OCert as SL import qualified Data.Text as T import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config (configConsensus) +import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader, ConsensusConfig) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos ( Praos + , PraosCannotForge , PraosParams (..) , praosCheckCanForge ) +import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader) +import Ouroboros.Consensus.Protocol.Praos2 (ConsensusConfig (..), LeiosOnly, Praos2) import Ouroboros.Consensus.Shelley.Ledger ( ShelleyBlock , ShelleyCompatible @@ -31,6 +37,7 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node.Common ( ShelleyLeaderCredentials (..) ) +import Ouroboros.Consensus.Shelley.Protocol.Abstract (CannotForgeError, ProtoCrypto) import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Util.IOLike (IOLike) @@ -70,7 +77,26 @@ praosSharedBlockForging :: (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> BlockForging m (ShelleyBlock (Praos c) era) -praosSharedBlockForging +praosSharedBlockForging = basePraosSharedBlockForging id + +-- | 'praosSharedBlockForging' for every Praos. +basePraosSharedBlockForging :: + forall m proto c era. + ( ShelleyCompatible proto era + , ProtoCrypto proto ~ c + , CanBeLeader proto ~ PraosCanBeLeader c + , CannotForgeError proto ~ PraosCannotForge c + , Applicative (LeiosOnly proto ()) + , IOLike m + ) => + -- | The Praos configuration within this protocol's + (ConsensusConfig proto -> ConsensusConfig (Praos c)) -> + HotKey.HotKey c m -> + (SlotNo -> Absolute.KESPeriod) -> + ShelleyLeaderCredentials c -> + BlockForging m (ShelleyBlock proto era) +basePraosSharedBlockForging + getPraosConfig hotKey slotToPeriod ShelleyLeaderCredentials @@ -85,8 +111,20 @@ praosSharedBlockForging <$> HotKey.evolve hotKey (slotToPeriod curSlot) , checkCanForge = \cfg curSlot _tickedChainDepState _isLeader -> praosCheckCanForge - (configConsensus cfg) + (getPraosConfig (configConsensus cfg)) curSlot , forgeBlock = forgeShelleyBlock hotKey canBeLeader , finalize = HotKey.finalize hotKey } + +-- | As 'praosSharedBlockForging', for 'Praos2'. +praos2SharedBlockForging :: + forall m c era. + ( ShelleyCompatible (Praos2 c) era + , IOLike m + ) => + HotKey.HotKey c m -> + (SlotNo -> Absolute.KESPeriod) -> + ShelleyLeaderCredentials c -> + BlockForging m (ShelleyBlock (Praos2 c) era) +praos2SharedBlockForging = basePraosSharedBlockForging leiosPraosConfig diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index 23a8ae893a..fe793f3ea2 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -41,7 +42,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables (EmptyMK) import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation -import Ouroboros.Consensus.Protocol.Praos (PraosState) +import Ouroboros.Consensus.Protocol.Praos (PolyPraosState, SerialisePraosState) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger @@ -104,11 +105,17 @@ instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) TPra instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) TPraosState where decodeDisk _ = decode -instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) PraosState where +instance + (ShelleyCompatible proto era, proto ~ proto', SerialisePraosState proto') => + EncodeDisk (ShelleyBlock proto era) (PolyPraosState proto') + where encodeDisk _ = encode -- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ -instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) PraosState where +instance + (ShelleyCompatible proto era, proto ~ proto', SerialisePraosState proto') => + DecodeDisk (ShelleyBlock proto era) (PolyPraosState proto') + where decodeDisk _ = decode instance 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 b603019dff..6ebdbb3068 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 @@ -26,7 +26,8 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR)) import qualified Cardano.Crypto.Hash as Hash import Cardano.Crypto.VRF (OutputVRF) -import Cardano.Ledger.BaseTypes (ProtVer) +import Cardano.Ledger.BaseTypes (ProtVer, StrictMaybe) +import Cardano.Ledger.Block (EbReferencesAnnouncement) import Cardano.Ledger.Hashes ( EraIndependentBlockBody , EraIndependentBlockHeader @@ -57,7 +58,11 @@ import Ouroboros.Consensus.Protocol.Abstract , ValidateView ) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) -import Ouroboros.Consensus.Protocol.Praos.Common (HasMaxMajorProtVer) +import Ouroboros.Consensus.Protocol.Praos.Common + ( HasMaxMajorProtVer + , LeiosOnly + , ShelleyProtocolHeader + ) import Ouroboros.Consensus.Protocol.Signed (SignedHeader) import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -93,9 +98,6 @@ instance Condense ShelleyHash where Header -------------------------------------------------------------------------------} --- | Shelley header, determined by the associated protocol. -type family ShelleyProtocolHeader proto = (sh :: Type) | sh -> proto - -- | Indicates that the header (determined by the protocol) supports " Envelope -- " functionality. Envelope functionality refers to the minimal functionality -- required to construct a chain. @@ -160,6 +162,9 @@ class ProtocolHeaderSupportsKES proto where Int -> -- | Protocol version ProtVer -> + -- | Optional fields for Leios: whether the body carries a certificate, and + -- this header's announcement, if any + LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement) -> m (ShelleyProtocolHeader proto) -- | ProtocolHeaderSupportsProtocol` provides support for the concrete diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 86fb9fccd6..7584f583c9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -1,30 +1,51 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Protocol.Praos () where +import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Crypto.KES as KES import Cardano.Crypto.VRF (certifiedOutput) -import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) +import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), StrictMaybe) +import Cardano.Ledger.Binary (getVersion32) +import Cardano.Ledger.Block (BlockHeaderVersionInfo (..), EbReferencesAnnouncement) import Cardano.Ledger.Chain (ChainChecksPParams (..)) +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.Hashes (EraIndependentBlockBody, HASH) import Cardano.Ledger.Slot (SlotNo (unSlotNo)) +import Cardano.Protocol.Crypto (Crypto, KES) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec import Cardano.Protocol.Praos.BlockHeader ( Header (..) , HeaderBody (..) , headerHash , headerSize ) +import Cardano.Protocol.TPraos.BlockHeader (PrevHash) import Cardano.Protocol.TPraos.OCert ( OCert (ocertKESPeriod, ocertVkHot) ) import qualified Cardano.Protocol.TPraos.OCert as SL +import Cardano.Slotting.Block (BlockNo) +import Control.Monad.Except (Except) import Data.Either (isRight) +import Data.Proxy (Proxy (Proxy)) +import Data.Word (Word32, Word64) +import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import Ouroboros.Consensus.Protocol.Praos import Ouroboros.Consensus.Protocol.Praos.Common ( MaxMajorProtVer (MaxMajorProtVer) + , PraosCanBeLeader ) import Ouroboros.Consensus.Protocol.Praos.Views +import Ouroboros.Consensus.Protocol.Praos2 + ( ConsensusConfig (..) + , LeiosCrypto + , LeiosOnly (..) + , Praos2 + ) import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto @@ -33,7 +54,6 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (ShelleyHash) , ShelleyProtocol - , ShelleyProtocolHeader ) import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ( EnvelopeError @@ -43,8 +63,6 @@ import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks type instance ProtoCrypto (Praos c) = c -type instance ShelleyProtocolHeader (Praos c) = Header c - instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where pHeaderHash hdr = ShelleyHash $ headerHash hdr pHeaderPrevHash (Header body _) = hbPrev body @@ -57,54 +75,100 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where type EnvelopeCheckError _ = EnvelopeError envelopeChecks cfg lv hdr = - envelopeCheck maxpv ccd $ - EnvelopeHeaderView - { ehvProtVer = m - , ehvHeaderSize = headerSize hdr - , ehvBodySize = hbBodySize body - } + envelopeChecksPolyPraos cfg lv (headerSize hdr) (hbBodySize body) where Header body _ = hdr - MaxMajorProtVer maxpv = praosMaxMajorPV (praosParams cfg) - ProtVer m _ = plvProtocolVersion lv - ccd = - ChainChecksPParams - { ccMaxBHSize = plvMaxHeaderSize lv - , ccMaxBBSize = plvMaxBodySize lv - , ccProtocolVersion = plvProtocolVersion lv - } + +-- | 'envelopeChecks' for every Praos. +envelopeChecksPolyPraos :: + ConsensusConfig (Praos c) -> + PolyPraosLedgerView proto -> + -- | Size of the header + Int -> + -- | Size of the block body + Word32 -> + Except EnvelopeError () +envelopeChecksPolyPraos cfg lv hdrSize bodySize = + envelopeCheck maxpv ccd $ + EnvelopeHeaderView + { ehvProtVer = m + , ehvHeaderSize = hdrSize + , ehvBodySize = bodySize + } + where + MaxMajorProtVer maxpv = praosMaxMajorPV (praosParams cfg) + ProtVer m _ = plvProtocolVersion lv + ccd = + ChainChecksPParams + { ccMaxBHSize = plvMaxHeaderSize lv + , ccMaxBBSize = plvMaxBodySize lv + , ccProtocolVersion = plvProtocolVersion lv + } instance PraosCrypto c => ProtocolHeaderSupportsKES (Praos c) where configSlotsPerKESPeriod cfg = praosSlotsPerKESPeriod $ praosParams cfg - verifyHeaderIntegrity slotsPerKESPeriod header = - isRight $ KES.verifySignedKES () ocertVkHot t headerBody headerSig - where - Header{headerBody, headerSig} = header - SL.OCert - { ocertVkHot - , ocertKESPeriod = SL.KESPeriod startOfKesPeriod - } = hbOCert headerBody - - currentKesPeriod = - fromIntegral $ - unSlotNo (hbSlotNo headerBody) `div` slotsPerKESPeriod - - t - | currentKesPeriod >= startOfKesPeriod = - currentKesPeriod - startOfKesPeriod - | otherwise = - 0 - mkHeader hk cbl il slotNo blockNo prevHash bbHash sz protVer = do - PraosFields{praosSignature, praosToSign} <- forgePraosFields hk cbl il mkBhBodyBytes - pure $ Header praosToSign praosSignature - where - mkBhBodyBytes - PraosToSign - { praosToSignIssuerVK - , praosToSignVrfVK - , praosToSignVrfRes - , praosToSignOCert - } = + verifyHeaderIntegrity slotsPerKESPeriod = + verifyHeaderIntegrityPolyPraos slotsPerKESPeriod . protocolHeaderView + mkHeader hk cbl il slotNo blockNo prevHash bbHash sz protVer (PraosLacksLeios ()) = + mkHeaderPolyPraos hk cbl il slotNo blockNo prevHash bbHash sz protVer id Header + +-- | 'verifyHeaderIntegrity' for every Praos. +verifyHeaderIntegrityPolyPraos :: + PolyPraosCrypto proto c => + Word64 -> + PolyPraosValidateView proto c -> + Bool +verifyHeaderIntegrityPolyPraos slotsPerKESPeriod hv = + isRight $ KES.verifySignedKES () ocertVkHot t (hvSigned hv) (hvSignature hv) + where + SL.OCert + { ocertVkHot + , ocertKESPeriod = SL.KESPeriod startOfKesPeriod + } = hvOCert hv + + currentKesPeriod = + fromIntegral $ + unSlotNo (hvSlotNo hv) `div` slotsPerKESPeriod + + t + | currentKesPeriod >= startOfKesPeriod = + currentKesPeriod - startOfKesPeriod + | otherwise = + 0 + +-- | 'mkHeader' for every Praos. +-- +-- The fields the protocols share are filled in here; the caller says how its own +-- header body extends that, since only it knows the extra fields, and how to +-- assemble the signed header. +mkHeaderPolyPraos :: + (Crypto c, KES.Signable (KES c) body, Monad m) => + HotKey c m -> + PraosCanBeLeader c -> + PraosIsLeader c -> + SlotNo -> + BlockNo -> + PrevHash -> + Hash.Hash HASH EraIndependentBlockBody -> + Int -> + ProtVer -> + -- | How this protocol's header body extends the shared one + (HeaderBody c -> body) -> + -- | How this protocol assembles the signed header + (body -> KES.SignedKES (KES c) body -> hdr) -> + m hdr +mkHeaderPolyPraos hk cbl il slotNo blockNo prevHash bbHash sz protVer extend mkHdr = do + PraosFields{praosSignature, praosToSign} <- forgePraosFields hk cbl il mkBhBodyBytes + pure $ mkHdr praosToSign praosSignature + where + mkBhBodyBytes + PraosToSign + { praosToSignIssuerVK + , praosToSignVrfVK + , praosToSignVrfRes + , praosToSignOCert + } = + extend $ HeaderBody { hbBlockNo = blockNo , hbSlotNo = slotNo @@ -128,6 +192,7 @@ instance PraosCrypto c => ProtocolHeaderSupportsProtocol (Praos c) where , hvVrfRes = hbVrfRes headerBody , hvOCert = hbOCert headerBody , hvSlotNo = hbSlotNo headerBody + , hvLeios = PraosLacksLeios () , hvSigned = headerBody , hvSignature = headerSig } @@ -141,8 +206,116 @@ instance PraosCrypto c => ProtocolHeaderSupportsProtocol (Praos c) where -- here instead. pTieBreakVRFValue = certifiedOutput . hbVrfRes . headerBody -type instance Signed (Header c) = HeaderBody c instance PraosCrypto c => SignedHeader (Header c) where headerSigned = headerBody instance PraosCrypto c => ShelleyProtocol (Praos c) + +{------------------------------------------------------------------------------- + Praos2 +-------------------------------------------------------------------------------} + +type instance ProtoCrypto (Praos2 c) = c + +instance LeiosCrypto c => ProtocolHeaderSupportsEnvelope (Praos2 c) where + pHeaderHash hdr = ShelleyHash $ LeiosCodec.headerHash hdr + pHeaderPrevHash = LeiosCodec.hbPrev . LeiosCodec.headerBody + pHeaderBodyHash = LeiosCodec.hbBodyHash . LeiosCodec.headerBody + pHeaderSlot = LeiosCodec.hbSlotNo . LeiosCodec.headerBody + pHeaderBlock = LeiosCodec.hbBlockNo . LeiosCodec.headerBody + pHeaderSize hdr = fromIntegral $ LeiosCodec.headerSize hdr + pHeaderBlockSize = fromIntegral . LeiosCodec.hbBodySize . LeiosCodec.headerBody + + type EnvelopeCheckError _ = EnvelopeError + + envelopeChecks cfg lv hdr = + envelopeChecksPolyPraos + (leiosPraosConfig cfg) + lv + (LeiosCodec.headerSize hdr) + (LeiosCodec.hbBodySize (LeiosCodec.headerBody hdr)) + +instance LeiosCrypto c => ProtocolHeaderSupportsKES (Praos2 c) where + configSlotsPerKESPeriod cfg = praosSlotsPerKESPeriod $ praosParams $ leiosPraosConfig cfg + verifyHeaderIntegrity slotsPerKESPeriod = + verifyHeaderIntegrityPolyPraos slotsPerKESPeriod . protocolHeaderView + mkHeader + hk + cbl + il + slotNo + blockNo + prevHash + bbHash + sz + protVer + (Praos2HasLeios (containsCert, mbAnn)) = + mkHeaderPolyPraos + hk + cbl + il + slotNo + blockNo + prevHash + bbHash + sz + protVer + (\pb -> extendHeaderBodyWithLeios pb containsCert mbAnn) + (LeiosCodec.mkHeader (Proxy @DijkstraEra)) + +-- | The Leios header body is the Praos one plus the Leios fields. +-- +-- The version info has the protocol version's wire format: the highest +-- supported major version, and the self-reported software tag. +extendHeaderBodyWithLeios :: + HeaderBody c -> + -- | Whether the block body carries a Leios certificate + Bool -> + StrictMaybe EbReferencesAnnouncement -> + LeiosCodec.HeaderBody c +extendHeaderBodyWithLeios pb containsCert ann = + LeiosCodec.HeaderBody + { LeiosCodec.hbBlockNo = hbBlockNo pb + , LeiosCodec.hbSlotNo = hbSlotNo pb + , LeiosCodec.hbPrev = hbPrev pb + , LeiosCodec.hbVk = hbVk pb + , LeiosCodec.hbVrfVk = hbVrfVk pb + , LeiosCodec.hbVrfRes = hbVrfRes pb + , LeiosCodec.hbBodySize = hbBodySize pb + , LeiosCodec.hbBodyHash = hbBodyHash pb + , LeiosCodec.hbOCert = hbOCert pb + , LeiosCodec.hbVersionInfo = BlockHeaderVersionInfo (getVersion32 major) minor + , LeiosCodec.hbBlockBodyContainsLeiosCert = containsCert + , LeiosCodec.hbEbReferencesAnnouncement = ann + } + where + ProtVer major minor = hbProtVer pb + +instance LeiosCrypto c => ProtocolHeaderSupportsProtocol (Praos2 c) where + type CannotForgeError (Praos2 c) = PraosCannotForge c + protocolHeaderView header = + HeaderView + { hvPrevHash = LeiosCodec.hbPrev body + , hvVK = LeiosCodec.hbVk body + , hvVrfVK = LeiosCodec.hbVrfVk body + , hvVrfRes = LeiosCodec.hbVrfRes body + , hvOCert = LeiosCodec.hbOCert body + , hvSlotNo = LeiosCodec.hbSlotNo body + , hvLeios = + Praos2HasLeios + ( LeiosCodec.hbBlockBodyContainsLeiosCert body + , LeiosCodec.hbEbReferencesAnnouncement body + ) + , hvSigned = body + , hvSignature = LeiosCodec.headerSig header + } + where + body = LeiosCodec.headerBody header + pHeaderIssuer = LeiosCodec.hbVk . LeiosCodec.headerBody + pHeaderIssueNo = SL.ocertN . LeiosCodec.hbOCert . LeiosCodec.headerBody + pTieBreakVRFValue = certifiedOutput . LeiosCodec.hbVrfRes . LeiosCodec.headerBody + +instance LeiosCrypto c => SignedHeader (LeiosCodec.Header c) where + headerSigned = LeiosCodec.headerBody + +instance LeiosCrypto c => ShelleyProtocol (Praos2 c) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs index 45c71bc3a5..f6d2db2c79 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs @@ -23,7 +23,8 @@ import Ouroboros.Consensus.Protocol.Signed , SignedHeader (headerSigned) ) import Ouroboros.Consensus.Protocol.TPraos - ( MaxMajorProtVer (MaxMajorProtVer) + ( LeiosOnly (TPraosLacksLeios) + , MaxMajorProtVer (MaxMajorProtVer) , TPraos , TPraosCannotForge , TPraosFields (..) @@ -96,7 +97,7 @@ instance PraosCrypto c => ProtocolHeaderSupportsKES (TPraos c) where currentKesPeriod - startOfKesPeriod | otherwise = 0 - mkHeader hotKey canBeLeader isLeader curSlot curNo prevHash bbHash actualBodySize protVer = do + mkHeader hotKey canBeLeader isLeader curSlot curNo prevHash bbHash actualBodySize protVer (TPraosLacksLeios ()) = do TPraosFields{tpraosSignature, tpraosToSign} <- forgeTPraosFields hotKey canBeLeader isLeader mkBhBody pure $ SL.BHeader tpraosToSign tpraosSignature 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 1493b4d4b1..dcd5c86b7b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -85,6 +85,11 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Protocol.Praos2 + ( ConsensusConfig (..) + , LeiosCrypto + , Praos2 + ) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger @@ -262,6 +267,14 @@ instance Ouroboros.Consensus.Protocol.Praos.PraosCrypto c => HasPartialConsensus toPartialConsensusConfig _ = praosParams +instance LeiosCrypto c => HasPartialConsensusConfig (Praos2 c) where + type PartialConsensusConfig (Praos2 c) = PraosParams + + completeConsensusConfig _ praosEpochInfo praosParams = + LeiosConfig PraosConfig{..} + + toPartialConsensusConfig _ = praosParams . leiosPraosConfig + instance SL.PraosCrypto c => HasPartialConsensusConfig (TPraos c) where type PartialConsensusConfig (TPraos c) = TPraosParams diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs index 36ace855ea..e9e4aab247 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/MockCrypto.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -8,6 +10,7 @@ import Cardano.Crypto.KES (MockKES) import Cardano.Crypto.VRF (MockVRF) import Cardano.Protocol.Crypto (Crypto (..)) import qualified Ouroboros.Consensus.Protocol.Praos as Praos +import qualified Ouroboros.Consensus.Protocol.Praos2 as Leios import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos -- | A replacement for 'Test.Consensus.Shelley.MockCrypto' that is compatible @@ -36,4 +39,10 @@ instance Crypto MockCryptoCompatByron where instance TPraos.PraosCrypto MockCryptoCompatByron +instance Praos.PolyPraosCrypto (Praos.Praos MockCryptoCompatByron) MockCryptoCompatByron + instance Praos.PraosCrypto MockCryptoCompatByron + +instance Praos.PolyPraosCrypto (Leios.Praos2 MockCryptoCompatByron) MockCryptoCompatByron + +instance Leios.LeiosCrypto MockCryptoCompatByron 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 94e77b953b..525de25b79 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 @@ -20,11 +20,14 @@ module Test.Consensus.Shelley.Examples , examplesShelley ) where +import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Block as SL import Cardano.Ledger.Core +import Cardano.Ledger.Hashes (unsafeMakeSafeHash) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (StandardCrypto) +import qualified Cardano.Protocol.Leios.BlockHeader as Leios import Cardano.Protocol.Praos.BlockHeader ( HeaderBody (HeaderBody) ) @@ -43,13 +46,15 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.Tables hiding (TxIn) import Ouroboros.Consensus.Ledger.Tables.Utils -import Ouroboros.Consensus.Protocol.Abstract (translateChainDepState) +import Ouroboros.Consensus.Protocol.Abstract (TranslateProto, translateChainDepState) import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.Praos.Common +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Protocol.TPraos ( TPraos , TPraosState (TPraosState) ) +import Ouroboros.Consensus.Shelley.Eras (DijkstraEra) import Ouroboros.Consensus.Shelley.HFEras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Protocol.TPraos () @@ -220,13 +225,24 @@ fromShelleyLedgerExamples ledgerConfig = exampleShelleyLedgerConfig leTranslationContext --- | TODO Factor this out into something nicer. fromShelleyLedgerExamplesPraos :: - forall era. ShelleyCompatible (Praos StandardCrypto) era => ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> Examples (ShelleyBlock (Praos StandardCrypto) era) -fromShelleyLedgerExamplesPraos +fromShelleyLedgerExamplesPraos = fromShelleyLedgerExamplesPolyPraos translatePraosHeader + +-- | TODO Factor this out into something nicer. +fromShelleyLedgerExamplesPolyPraos :: + forall proto era. + ( ShelleyCompatible proto era + , TranslateProto (TPraos StandardCrypto) proto + ) => + -- | Rebuild the example's TPraos header as this protocol's header + (SL.BHeader StandardCrypto -> ShelleyProtocolHeader proto) -> + ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> + Examples (ShelleyBlock proto era) +fromShelleyLedgerExamplesPolyPraos + translateHeader ProtocolLedgerExamples { pleLedgerExamples = Shelley.LedgerExamples{..} , .. @@ -256,24 +272,6 @@ fromShelleyLedgerExamplesPraos let SL.Block hdr1 bdy = pleBlock in SL.Block (translateHeader hdr1) bdy - translateHeader :: SL.BHeader StandardCrypto -> Praos.Header StandardCrypto - translateHeader (SL.BHeader bhBody bhSig) = - Praos.Header hBody hSig - where - hBody = - HeaderBody - { hbBlockNo = SL.bheaderBlockNo bhBody - , hbSlotNo = SL.bheaderSlotNo bhBody - , hbPrev = SL.bheaderPrev bhBody - , hbVk = SL.bheaderVk bhBody - , hbVrfVk = SL.bheaderVrfVk bhBody - , hbVrfRes = coerce $ SL.bheaderEta bhBody - , hbBodySize = SL.bsize bhBody - , hbBodyHash = SL.bhash bhBody - , hbOCert = SL.bheaderOCert bhBody - , hbProtVer = SL.bprotver bhBody - } - hSig = coerce bhSig hash = ShelleyHash $ SL.unHashHeader pleHashHeader serialisedBlock = Serialised "" tx = mkShelleyTx emptyTx @@ -367,7 +365,7 @@ fromShelleyLedgerExamplesPraos , shelleyLedgerTables = emptyLedgerTables } chainDepState = - translateChainDepState (Proxy @(TPraos StandardCrypto, Praos StandardCrypto)) $ + translateChainDepState (Proxy @(TPraos StandardCrypto, proto)) $ TPraosState (NotOrigin 1) pleChainDepState extLedgerState = let headerState = genesisHeaderState chainDepState @@ -380,6 +378,63 @@ fromShelleyLedgerExamplesPraos ledgerConfig = exampleShelleyLedgerConfig leTranslationContext +-- | Rebuild a TPraos example header as a Praos one. +translatePraosHeader :: SL.BHeader StandardCrypto -> Praos.Header StandardCrypto +translatePraosHeader (SL.BHeader bhBody bhSig) = + Praos.Header (praosHeaderBodyFromTPraos bhBody) (coerce bhSig) + +praosHeaderBodyFromTPraos :: SL.BHBody StandardCrypto -> HeaderBody StandardCrypto +praosHeaderBodyFromTPraos bhBody = + HeaderBody + { hbBlockNo = SL.bheaderBlockNo bhBody + , hbSlotNo = SL.bheaderSlotNo bhBody + , hbPrev = SL.bheaderPrev bhBody + , hbVk = SL.bheaderVk bhBody + , hbVrfVk = SL.bheaderVrfVk bhBody + , hbVrfRes = coerce $ SL.bheaderEta bhBody + , hbBodySize = SL.bsize bhBody + , hbBodyHash = SL.bhash bhBody + , hbOCert = SL.bheaderOCert bhBody + , hbProtVer = SL.bprotver bhBody + } + +fromShelleyLedgerExamplesPraos2 :: + ShelleyCompatible (Praos2 StandardCrypto) era => + ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> + Examples (ShelleyBlock (Praos2 StandardCrypto) era) +fromShelleyLedgerExamplesPraos2 = + fromShelleyLedgerExamplesPolyPraos translateLeiosHeader + +-- | As 'translatePraosHeader', with the Leios fields of an example block that +-- carries a certificate and announces an endorser block of its own. +translateLeiosHeader :: SL.BHeader StandardCrypto -> Leios.Header StandardCrypto +translateLeiosHeader (SL.BHeader bhBody bhSig) = + Leios.mkHeader (Proxy @DijkstraEra) hBody (coerce bhSig) + where + pb = praosHeaderBodyFromTPraos bhBody + SL.ProtVer major minor = Praos.hbProtVer pb + hBody = + Leios.HeaderBody + { Leios.hbBlockNo = Praos.hbBlockNo pb + , Leios.hbSlotNo = Praos.hbSlotNo pb + , Leios.hbPrev = Praos.hbPrev pb + , Leios.hbVk = Praos.hbVk pb + , Leios.hbVrfVk = Praos.hbVrfVk pb + , Leios.hbVrfRes = Praos.hbVrfRes pb + , Leios.hbBodySize = Praos.hbBodySize pb + , Leios.hbBodyHash = Praos.hbBodyHash pb + , Leios.hbOCert = Praos.hbOCert pb + , Leios.hbVersionInfo = SL.BlockHeaderVersionInfo (SL.getVersion32 major) minor + , Leios.hbBlockBodyContainsLeiosCert = True + , Leios.hbEbReferencesAnnouncement = + SL.SJust $ + SL.EbReferencesAnnouncement + { SL.ebReferencesAnnouncementHash = + unsafeMakeSafeHash $ Hash.castHash $ Praos.hbBodyHash pb + , SL.ebReferencesAnnouncementSize = 123 + } + } + examplesShelley :: Examples StandardShelleyBlock examplesShelley = fromShelleyLedgerExamples ledgerExamplesShelley @@ -399,7 +454,8 @@ examplesConway :: Examples StandardConwayBlock examplesConway = fromShelleyLedgerExamplesPraos (ledgerExamplesTPraos Conway.ledgerExamples) examplesDijkstra :: Examples StandardDijkstraBlock -examplesDijkstra = fromShelleyLedgerExamplesPraos (ledgerExamplesTPraos Dijkstra.ledgerExamples) +examplesDijkstra = + fromShelleyLedgerExamplesPraos2 (ledgerExamplesTPraos Dijkstra.ledgerExamples) exampleShelleyLedgerConfig :: TranslationContext era -> ShelleyLedgerConfig era exampleShelleyLedgerConfig translationContext = 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 32bf5fe343..f9eb675c1b 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 @@ -1,6 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -58,6 +60,7 @@ instance Crypto MockCrypto where type VRF MockCrypto = MockVRF instance SL.PraosCrypto MockCrypto +instance Praos.PolyPraosCrypto (Praos.Praos MockCrypto) MockCrypto instance Praos.PraosCrypto MockCrypto type Block = ShelleyBlock (TPraos MockCrypto) ShelleyEra diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Capacity.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Capacity.hs index 9b513a1d6b..f6e0fa9508 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Capacity.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Capacity.hs @@ -49,6 +49,7 @@ import Ouroboros.Consensus.Ledger.SupportsMempool ) import Ouroboros.Consensus.Ledger.Tables import Ouroboros.Consensus.Protocol.Praos (Praos) +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.HFEras () @@ -145,7 +146,7 @@ prop_shelleyBased genTranslationContext st = -- Few runs: setting the parameters forces the whole arbitrary ledger state, -- which is slow to generate, and the result depends only on the parameters. prop_dijkstra :: - LedgerState (ShelleyBlock (Praos Crypto) DijkstraEra) EmptyMK -> + LedgerState (ShelleyBlock (Praos2 Crypto) DijkstraEra) EmptyMK -> Property prop_dijkstra st = withNumTests 10 $ @@ -162,7 +163,7 @@ prop_dijkstra st = , txReferencesSize = IgnoringOverflow (ByteSize32 5000) } , counterexample "mempool reservation for an endorser block" $ - mempoolEbReservation (Proxy @(ShelleyBlock (Praos Crypto) DijkstraEra)) capacity + mempoolEbReservation (Proxy @(ShelleyBlock (Praos2 Crypto) DijkstraEra)) capacity === TxMeasure closureAlonzo closureRefScripts ] where @@ -192,7 +193,9 @@ prop_dijkstra st = -- reading the wrong field fails. test_dijkstraTxEbMeasure :: Assertion test_dijkstraTxEbMeasure = - txEbMeasure (Proxy @(ShelleyBlock (Praos Crypto) DijkstraEra)) (TxMeasure alonzo refScripts) + txEbMeasure + (Proxy @(ShelleyBlock (Praos2 Crypto) DijkstraEra)) + (TxMeasure alonzo refScripts) @?= DijkstraEbMeasure { ebClosureMeasure = TxMeasure alonzo refScripts , -- 34 bytes for the hash, 3 bytes for a size of 300 diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs index 4958594e5d..e0b0371eed 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs @@ -61,6 +61,7 @@ import Ouroboros.Consensus.Ledger.Tables hiding (TxIn) import Ouroboros.Consensus.Ledger.Tables.Diff (Diff) import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Protocol.Praos2 (Praos2) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.HFEras () @@ -191,7 +192,7 @@ conwayToDijkstraLedgerStateTranslation :: WrapLedgerConfig TranslateLedgerState (ShelleyBlock (Praos Crypto) ConwayEra) - (ShelleyBlock (Praos Crypto) DijkstraEra) + (ShelleyBlock (Praos2 Crypto) DijkstraEra) PCons byronToShelleyLedgerStateTranslation ( PCons @@ -434,7 +435,7 @@ instance Arbitrary ( TestSetup (ShelleyBlock (Praos Crypto) ConwayEra) - (ShelleyBlock (Praos Crypto) DijkstraEra) + (ShelleyBlock (Praos2 Crypto) DijkstraEra) ) where arbitrary = 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 01662682bc..c4d1d7ece3 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 @@ -1,30 +1,65 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns #-} +-- | Praos, and the pieces every protocol built on Praos shares. +-- +-- Each such protocol is its own @proto@ type with its own instances, so that +-- none of Praos's rules are reused by accident. The data types, however, are +-- shared: they carry a @proto@ parameter, so that there is one definition of +-- each Praos concept regardless of which extensions the protocol enables. The +-- functions suffixed @PolyPraos@ are the method implementations every such +-- protocol delegates to. +-- +-- @Poly@ means "many": a @PolyPraos@ type or function handles multiple +-- extensions of/overlays on Praos, the ones used for Cardano. And the +-- @PolyPraos@ functions are indeed /polymorphic/ in the @proto@ tyvar. module Ouroboros.Consensus.Protocol.Praos - ( ConsensusConfig (..) + ( AnnouncedBy (..) + , PolyPraosCrypto + , PolyPraosState (..) + , PolyPraosValidationErr (..) + , ConsensusConfig (..) + , LeiosOnly (..) , Praos , PraosCannotForge (..) , PraosCrypto , PraosFields (..) , PraosIsLeader (..) + , PraosLedgerView , PraosParams (..) - , PraosState (..) + , PraosState , PraosToSign (..) - , PraosValidationErr (..) + , PraosValidateView + , PraosValidationErr + , SerialisePraosState , Ticked (..) + , checkIsLeaderPolyPraos , forgePraosFields + , getOpCertCountersPolyPraos + , getPraosNoncesPolyPraos + , leiosContextFreeHeaderChecks , praosCheckCanForge + , reupdateChainDepStatePolyPraos + , updateChainDepStatePolyPraos + , tickChainDepStatePolyPraos + , validateKESSignature + , validateVRFSignature -- * For testing purposes , doValidateKESSignature @@ -36,11 +71,13 @@ import qualified Cardano.Crypto.DSIGN as DSIGN import qualified Cardano.Crypto.Hash as Hash import qualified Cardano.Crypto.KES as KES import qualified Cardano.Crypto.VRF as VRF -import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce, (â­’)) +import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce, StrictMaybe (..), (â­’)) import qualified Cardano.Ledger.BaseTypes as SL +import Cardano.Ledger.Block (EbReferencesAnnouncement (..)) +import Cardano.Ledger.Chain (ChainChecksPParams (..)) import qualified Cardano.Ledger.Chain as SL import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR) -import Cardano.Ledger.Hashes (HASH) +import Cardano.Ledger.Hashes (HASH, extractHash, unsafeMakeSafeHash) import Cardano.Ledger.Keys ( DSIGN , KeyHash @@ -50,10 +87,11 @@ import Cardano.Ledger.Keys ) import qualified Cardano.Ledger.Keys as SL import Cardano.Ledger.Shelley (ShelleyEra) +import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.Slot (Duration (Duration), (+*)) import qualified Cardano.Ledger.State as SL import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF) -import Cardano.Protocol.Praos.BlockHeader (HeaderBody) +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec import Cardano.Protocol.Praos.VRF ( InputVRF , mkInputVRF @@ -78,6 +116,7 @@ import Cardano.Slotting.EpochInfo ( EpochInfo , epochInfoEpoch , epochInfoFirst + , epochInfoSlotLength , hoistEpochInfo ) import Cardano.Slotting.Slot @@ -86,49 +125,92 @@ import Cardano.Slotting.Slot , WithOrigin , unSlotNo ) +import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (decode, encode)) import Control.Exception (throw) -import Control.Monad (unless) +import Control.Monad (unless, when) import Control.Monad.Except (Except, runExcept, throwError) import Data.Coerce (coerce) +import Data.Foldable (traverse_) import Data.Functor.Identity (runIdentity) +import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) -import Data.Word (Word64) +import Data.Typeable (Typeable) +import Data.Void (Void) +import Data.Word (Word32, Word64) import GHC.Generics (Generic) +import Lens.Micro ((^.)) import NoThunks.Class (NoThunks) import Numeric.Natural (Natural) import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) import qualified Ouroboros.Consensus.HardFork.History as History +import qualified Ouroboros.Consensus.Leios.Types as Leios import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) import Ouroboros.Consensus.Protocol.Praos.Common +import Ouroboros.Consensus.Protocol.Praos.Orphans () import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views +import Ouroboros.Consensus.Protocol.Signed (Signed) import Ouroboros.Consensus.Protocol.TPraos ( ConsensusConfig (TPraosConfig, tpraosEpochInfo, tpraosParams) , TPraos , TPraosState (tpraosStateChainDepState, tpraosStateLastSlot) ) import Ouroboros.Consensus.Ticked (Ticked) +import Ouroboros.Consensus.Util.CBOR (decodeStrictMaybe, encodeStrictMaybe) import Ouroboros.Consensus.Util.Versioned ( VersionDecoder (Decode) , decodeVersion , encodeVersion ) +-- | Praos with no extensions. +type Praos :: Type -> Type data Praos c +type instance ShelleyProtocolHeader (Praos c) = PraosCodec.Header c + +-- | Praos is not Leios, so it holds the left alternative. +newtype instance LeiosOnly (Praos c) a b = PraosLacksLeios a + deriving (Eq, Generic, Show) + +deriving anyclass instance NoThunks a => NoThunks (LeiosOnly (Praos c) a b) + +instance Functor (LeiosOnly (Praos c) a) where + fmap _ (PraosLacksLeios a) = PraosLacksLeios a + +instance () ~ a => Applicative (LeiosOnly (Praos c) a) where + pure _ = PraosLacksLeios () + PraosLacksLeios () <*> PraosLacksLeios () = PraosLacksLeios () + +instance Foldable (LeiosOnly (Praos c) a) where + foldMap _ (PraosLacksLeios _) = mempty + +instance Traversable (LeiosOnly (Praos c) a) where + traverse _ (PraosLacksLeios a) = pure (PraosLacksLeios a) + +instance TypeSwitch (LeiosOnly (Praos c)) where + typeSwitchL = PraosLacksLeios (PraosLacksLeios ()) + typeSwitchR = PraosLacksLeios () + +-- | What a protocol needs of its crypto: the Praos essentials, plus signing +-- whichever header body it is the protocol for. class ( Crypto c , DSIGN.Signable DSIGN (OCertSignable c) - , KES.Signable (KES c) (HeaderBody c) , VRF.Signable (VRF c) InputVRF + , KES.Signable (KES c) (Signed (ShelleyProtocolHeader proto)) ) => - PraosCrypto c + PolyPraosCrypto proto c + +instance PolyPraosCrypto (Praos StandardCrypto) StandardCrypto + +class (Crypto c, PolyPraosCrypto (Praos c) c) => PraosCrypto c instance PraosCrypto StandardCrypto @@ -143,11 +225,11 @@ data PraosFields c toSign = PraosFields deriving Generic deriving instance - (NoThunks toSign, PraosCrypto c) => + (NoThunks toSign, Crypto c) => NoThunks (PraosFields c toSign) deriving instance - (Show toSign, PraosCrypto c) => + (Show toSign, Crypto c) => Show (PraosFields c toSign) -- | Fields arising from praos execution which must be included in @@ -165,18 +247,18 @@ data PraosToSign c = PraosToSign } deriving Generic -instance PraosCrypto c => NoThunks (PraosToSign c) +instance Crypto c => NoThunks (PraosToSign c) -deriving instance PraosCrypto c => Show (PraosToSign c) +deriving instance Crypto c => Show (PraosToSign c) forgePraosFields :: - ( PraosCrypto c + ( Crypto c , KES.Signable (KES c) toSign , Monad m ) => HotKey c m -> - CanBeLeader (Praos c) -> - IsLeader (Praos c) -> + PraosCanBeLeader c -> + PraosIsLeader c -> (PraosToSign c -> toSign) -> m (PraosFields c toSign) forgePraosFields @@ -239,7 +321,7 @@ newtype PraosIsLeader c = PraosIsLeader } deriving Generic -instance PraosCrypto c => NoThunks (PraosIsLeader c) +instance Crypto c => NoThunks (PraosIsLeader c) -- | Static configuration data instance ConsensusConfig (Praos c) = PraosConfig @@ -251,9 +333,7 @@ data instance ConsensusConfig (Praos c) = PraosConfig } deriving Generic -instance PraosCrypto c => NoThunks (ConsensusConfig (Praos c)) - -type PraosValidateView c = Views.HeaderView c +instance Crypto c => NoThunks (ConsensusConfig (Praos c)) instance HasMaxMajorProtVer (Praos c) where protoMaxMajorPV = praosMaxMajorPV . praosParams @@ -267,7 +347,7 @@ instance HasMaxMajorProtVer (Praos c) where -- We track the last slot and the counters for operational certificates, as well -- as a series of nonces which get updated in different ways over the course of -- an epoch. -data PraosState = PraosState +data PolyPraosState proto = PraosState { praosStateLastSlot :: !(WithOrigin SlotNo) , praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64) -- ^ Operation Certificate counters @@ -284,18 +364,72 @@ data PraosState = PraosState , praosStateLastEpochBlockNonce :: !Nonce -- ^ Nonce corresponding to the LAB nonce of the last block of the previous -- epoch + , praosStateLeiosAnnouncement :: + !(LeiosOnly proto () (StrictMaybe AnnouncedBy)) + -- ^ The announcement carried by the most recently applied header, if any. + -- A header with no announcement clears it. + } + deriving Generic + +type PraosState c = PolyPraosState (Praos c) + +type PraosLedgerView c = Views.PolyPraosLedgerView (Praos c) + +type PraosValidateView c = Views.PolyPraosValidateView (Praos c) c + +deriving instance + Show (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Show (PolyPraosState proto) + +deriving instance + Eq (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Eq (PolyPraosState proto) + +instance + ( Typeable proto + , NoThunks (LeiosOnly proto () (StrictMaybe AnnouncedBy)) + ) => + NoThunks (PolyPraosState proto) + +-- | An endorser block announcement, and the issuer of the header that carried +-- it. +-- +-- With that header's slot ('praosStateLastSlot') the issuer identifies the +-- election. +data AnnouncedBy = MkAnnouncedBy + { announcedByIssuer :: !(KeyHash SL.BlockIssuer) + , announcedEb :: !EbReferencesAnnouncement } - deriving (Generic, Show, Eq) + deriving (Generic, Show, Eq, NoThunks) + +encodeAnnouncedBy :: AnnouncedBy -> CBOR.Encoding +encodeAnnouncedBy (MkAnnouncedBy issuer (EbReferencesAnnouncement h sz)) = + CBOR.encodeListLen 3 <> toCBOR issuer <> toCBOR (extractHash h) <> toCBOR sz -instance NoThunks PraosState +decodeAnnouncedBy :: CBOR.Decoder s AnnouncedBy +decodeAnnouncedBy = do + enforceSize "AnnouncedBy" 3 + MkAnnouncedBy + <$> fromCBOR + <*> (EbReferencesAnnouncement . unsafeMakeSafeHash <$> fromCBOR <*> fromCBOR) -instance ToCBOR PraosState where +instance SerialisePraosState proto => ToCBOR (PolyPraosState proto) where toCBOR = encode -instance FromCBOR PraosState where +instance SerialisePraosState proto => FromCBOR (PolyPraosState proto) where fromCBOR = decode -instance Serialise PraosState where +-- | What encoding 'PolyPraosState' needs of its protocol. +-- +-- 'LeiosOnly' decides which fields are written, and which format version is +-- written: 0 for 'Praos', 1 for 'Praos2'. The two protocols' versions are +-- separate namespaces: the HFC's era index precedes them, so the codec is +-- already chosen when the version is read. +type SerialisePraosState proto = + ( Typeable proto + , Applicative (LeiosOnly proto ()) + , Traversable (LeiosOnly proto ()) + ) + +instance SerialisePraosState proto => Serialise (PolyPraosState proto) where encode PraosState { praosStateLastSlot @@ -306,10 +440,11 @@ instance Serialise PraosState where , praosStatePreviousEpochNonce , praosStateLabNonce , praosStateLastEpochBlockNonce + , praosStateLeiosAnnouncement } = - encodeVersion 0 $ + encodeVersion version $ mconcat - [ CBOR.encodeListLen 8 + [ CBOR.encodeListLen (8 + nLeiosFields) , toCBOR praosStateLastSlot , toCBOR praosStateOCertCounters , toEraCBOR @ShelleyEra praosStateEvolvingNonce @@ -318,14 +453,22 @@ instance Serialise PraosState where , toEraCBOR @ShelleyEra praosStatePreviousEpochNonce , toEraCBOR @ShelleyEra praosStateLabNonce , toEraCBOR @ShelleyEra praosStateLastEpochBlockNonce + , foldMap (encodeStrictMaybe encodeAnnouncedBy) praosStateLeiosAnnouncement ] + where + nLeiosFields = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) + version = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) decode = decodeVersion - [(0, Decode decodePraosState)] + [(version, Decode decodePraosState)] where + version = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) + nLeiosFields = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) + + decodePraosState :: CBOR.Decoder s (PolyPraosState proto) decodePraosState = do - enforceSize "PraosState" 8 + enforceSize "PraosState" (8 + nLeiosFields) PraosState <$> fromCBOR <*> fromCBOR @@ -335,14 +478,17 @@ instance Serialise PraosState where <*> fromEraCBOR @ShelleyEra <*> fromEraCBOR @ShelleyEra <*> fromEraCBOR @ShelleyEra + <*> traverse + (\() -> decodeStrictMaybe decodeAnnouncedBy) + (pureLeiosOnly @proto ()) -data instance Ticked PraosState = TickedPraosState - { tickedPraosStateChainDepState :: PraosState - , tickedPraosStateLedgerView :: Views.PraosLedgerView +data instance Ticked (PolyPraosState proto) = TickedPraosState + { tickedPraosStateChainDepState :: PolyPraosState proto + , tickedPraosStateLedgerView :: Views.PolyPraosLedgerView proto } -- | Errors which we might encounter -data PraosValidationErr c +data PolyPraosValidationErr proto c = VRFKeyUnknown !(KeyHash SL.StakePool) -- unknown VRF keyhash (not registered) | VRFKeyWrongVRFKey @@ -380,168 +526,335 @@ data PraosValidationErr c !String -- error message given by Consensus Layer | NoCounterForKeyHashOCERT !(KeyHash SL.BlockIssuer) -- stake pool key hash + | -- | The header sets its cert bit, but its predecessor announced no endorser + -- block, so there is nothing for the certificate to certify. + LeiosCertWithoutAnnouncement + !(LeiosOnly proto Void ()) + | -- | The header sets its cert bit too soon after its predecessor's + -- announcement: the announcement, voting and diffusion periods have not all + -- elapsed. + LeiosCertTooYoung + !(LeiosOnly proto Void ()) + !SlotNo -- Slot of the announcing block + !SlotNo -- Slot of this header + !SlotNo -- Earliest slot in which this header could have certified + | -- | The header announces an endorser block larger than the protocol + -- parameters allow. + LeiosEbTooBig + !(LeiosOnly proto Void ()) + !Word32 -- Announced size + !Word32 -- Maximum size deriving Generic -deriving instance PraosCrypto c => Eq (PraosValidationErr c) +type PraosValidationErr c = PolyPraosValidationErr (Praos c) c -deriving instance PraosCrypto c => NoThunks (PraosValidationErr c) +deriving instance + (Crypto c, Eq (LeiosOnly proto Void ())) => + Eq (PolyPraosValidationErr proto c) + +deriving instance + (Typeable proto, Crypto c, NoThunks (LeiosOnly proto Void ())) => + NoThunks (PolyPraosValidationErr proto c) -deriving instance PraosCrypto c => Show (PraosValidationErr c) +deriving instance + (Crypto c, Show (LeiosOnly proto Void ())) => + Show (PolyPraosValidationErr proto c) -instance ChainDepStateSupportsPeras PraosState where +instance ChainDepStateSupportsPeras (PolyPraosState proto) where getEpochNonce = praosStateEpochNonce -instance ChainDepStateSupportsPeras (Ticked PraosState) where +instance ChainDepStateSupportsPeras (Ticked (PolyPraosState proto)) where getEpochNonce = praosStateEpochNonce . tickedPraosStateChainDepState instance PraosCrypto c => ConsensusProtocol (Praos c) where - type ChainDepState (Praos c) = PraosState + type ChainDepState (Praos c) = PolyPraosState (Praos c) type IsLeader (Praos c) = PraosIsLeader c type CanBeLeader (Praos c) = PraosCanBeLeader c type TiebreakerView (Praos c) = PraosTiebreakerView c - type LedgerView (Praos c) = Views.PraosLedgerView - type ValidationErr (Praos c) = PraosValidationErr c - type ValidateView (Praos c) = PraosValidateView c + type LedgerView (Praos c) = Views.PolyPraosLedgerView (Praos c) + type ValidationErr (Praos c) = PolyPraosValidationErr (Praos c) c + type ValidateView (Praos c) = Views.PolyPraosValidateView (Praos c) c protocolSecurityParam = praosSecurityParam . praosParams - checkIsLeader - cfg - PraosCanBeLeader - { praosCanBeLeaderSignKeyVRF - , praosCanBeLeaderColdVerKey + checkIsLeader = checkIsLeaderPolyPraos + + tickChainDepState = tickChainDepStatePolyPraos + + updateChainDepState = updateChainDepStatePolyPraos + + reupdateChainDepState = reupdateChainDepStatePolyPraos + +-- | 'checkIsLeader' for every Praos. +checkIsLeaderPolyPraos :: + forall proto c. + PolyPraosCrypto proto c => + ConsensusConfig (Praos c) -> + PraosCanBeLeader c -> + SlotNo -> + Ticked (PolyPraosState proto) -> + Maybe (PraosIsLeader c) +checkIsLeaderPolyPraos + cfg + PraosCanBeLeader + { praosCanBeLeaderSignKeyVRF + , praosCanBeLeaderColdVerKey + } + slot + cs = + if meetsLeaderThreshold cfg lv (SL.coerceKeyRole vkhCold) rho + then + Just + PraosIsLeader + { praosIsLeaderVrfRes = coerce rho + } + else Nothing + where + chainState = tickedPraosStateChainDepState cs + lv = tickedPraosStateLedgerView cs + eta0 = praosStateEpochNonce chainState + vkhCold = SL.hashKey praosCanBeLeaderColdVerKey + rho' = mkInputVRF slot eta0 + + rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF + +-- | 'tickChainDepState' for every Praos. +-- +-- Updating the chain dependent state for Praos. +-- +-- If we are not in a new epoch, then nothing happens. If we are in a new +-- epoch, we do three things: +-- - Store the existing current epoch nonce as the "previous epoch" nonce. +-- This is needed to validate Peras certificates when they appear in blocks. +-- - Update the epoch nonce to the combination of the candidate nonce and the +-- nonce derived from the last block of the previous epoch. +-- - Update the "last block of previous epoch" nonce to the nonce derived +-- from the last applied block. +tickChainDepStatePolyPraos :: + ConsensusConfig (Praos c) -> + Views.PolyPraosLedgerView proto -> + SlotNo -> + PolyPraosState proto -> + Ticked (PolyPraosState proto) +tickChainDepStatePolyPraos + PraosConfig{praosEpochInfo} + lv + slot + st = + TickedPraosState + { tickedPraosStateChainDepState = st' + , tickedPraosStateLedgerView = lv } - slot - cs = - if meetsLeaderThreshold cfg lv (SL.coerceKeyRole vkhCold) rho + where + newEpoch = + isNewEpoch + (History.toPureEpochInfo praosEpochInfo) + (praosStateLastSlot st) + slot + st' = + if newEpoch then - Just - PraosIsLeader - { praosIsLeaderVrfRes = coerce rho - } - else Nothing - where - chainState = tickedPraosStateChainDepState cs - lv = tickedPraosStateLedgerView cs - eta0 = praosStateEpochNonce chainState - vkhCold = SL.hashKey praosCanBeLeaderColdVerKey - rho' = mkInputVRF slot eta0 - - rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF - - -- Updating the chain dependent state for Praos. - -- - -- If we are not in a new epoch, then nothing happens. If we are in a new - -- epoch, we do three things: - -- - Store the existing current epoch nonce as the "previous epoch" nonce. - -- This is needed to validate Peras certificates when they appear in blocks. - -- - Update the epoch nonce to the combination of the candidate nonce and the - -- nonce derived from the last block of the previous epoch. - -- - Update the "last block of previous epoch" nonce to the nonce derived - -- from the last applied block. - tickChainDepState - PraosConfig{praosEpochInfo} - lv - slot - st = - TickedPraosState - { tickedPraosStateChainDepState = st' - , tickedPraosStateLedgerView = lv - } - where - newEpoch = - isNewEpoch - (History.toPureEpochInfo praosEpochInfo) - (praosStateLastSlot st) - slot - st' = - if newEpoch - then - st - { praosStateEpochNonce = - praosStateCandidateNonce st - â­’ praosStateLastEpochBlockNonce st - , praosStatePreviousEpochNonce = - praosStateEpochNonce st - , praosStateLastEpochBlockNonce = - praosStateLabNonce st - } - else st - - -- Validate and update the chain dependent state as a result of processing a - -- new header. - -- - -- This consists of: - -- - Validate the VRF checks - -- - Validate the KES checks - -- - Call 'reupdateChainDepState' - -- - updateChainDepState - cfg@( PraosConfig - PraosParams{praosLeaderF} - _ - ) - b - slot - tcs = do - -- First, we check the KES signature, which validates that the issuer is - -- in fact who they say they are. - validateKESSignature cfg lv (praosStateOCertCounters cs) b - -- Then we examing the VRF proof, which confirms that they have the - -- right to issue in this slot. - validateVRFSignature (praosStateEpochNonce cs) lv praosLeaderF b - -- Finally, we apply the changes from this header to the chain state. - pure $ reupdateChainDepState cfg b slot tcs - where - lv = tickedPraosStateLedgerView tcs - cs = tickedPraosStateChainDepState tcs - - -- Re-update the chain dependent state as a result of processing a header. - -- - -- This consists of: - -- - Update the last applied block hash. - -- - Update the evolving and (potentially) candidate nonces based on the - -- position in the epoch. - -- - Update the operational certificate counter. - reupdateChainDepState - _cfg@( PraosConfig - PraosParams{praosRandomnessStabilisationWindow} - ei - ) - b - slot - tcs = - cs - { praosStateLastSlot = NotOrigin slot - , praosStateLabNonce = prevHashToNonce (Views.hvPrevHash b) - , praosStateEvolvingNonce = newEvolvingNonce - , praosStateCandidateNonce = - if slot +* Duration praosRandomnessStabilisationWindow < firstSlotNextEpoch - then newEvolvingNonce - else praosStateCandidateNonce cs - , praosStateOCertCounters = - Map.insert hk n $ praosStateOCertCounters cs - } - where - epochInfoWithErr = - hoistEpochInfo - (either throw pure . runExcept) - ei - firstSlotNextEpoch = runIdentity $ do - EpochNo currentEpochNo <- epochInfoEpoch epochInfoWithErr slot - let nextEpoch = EpochNo $ currentEpochNo + 1 - epochInfoFirst epochInfoWithErr nextEpoch - cs = tickedPraosStateChainDepState tcs - eta = vrfNonceValue (Proxy @c) $ Views.hvVrfRes b - newEvolvingNonce = praosStateEvolvingNonce cs â­’ eta - OCert _ n _ _ = Views.hvOCert b - hk = hashKey $ Views.hvVK b + st + { praosStateEpochNonce = + praosStateCandidateNonce st + â­’ praosStateLastEpochBlockNonce st + , praosStatePreviousEpochNonce = + praosStateEpochNonce st + , praosStateLastEpochBlockNonce = + praosStateLabNonce st + } + else st + +-- | 'updateChainDepState' for every Praos. +-- +-- Validate and update the chain dependent state as a result of processing a +-- new header. +-- +-- This consists of: +-- - Validate the VRF checks +-- - Validate the KES checks +-- - Call 'reupdateChainDepState' +updateChainDepStatePolyPraos :: + ( PolyPraosCrypto proto c + , Applicative (LeiosOnly proto ()) + , Foldable (LeiosOnly proto ()) + , TypeSwitch (LeiosOnly proto) + ) => + ConsensusConfig (Praos c) -> + Views.PolyPraosValidateView proto c -> + SlotNo -> + Ticked (PolyPraosState proto) -> + Except (PolyPraosValidationErr proto c) (PolyPraosState proto) +updateChainDepStatePolyPraos + cfg@( PraosConfig + PraosParams{praosLeaderF} + _ + ) + b + slot + tcs = do + -- The Leios header checks are cheap, so they run first. + leiosHeaderChecks cfg lv b slot cs + -- First, we check the KES signature, which validates that the issuer is + -- in fact who they say they are. + validateKESSignature cfg lv (praosStateOCertCounters cs) b + -- Then we examing the VRF proof, which confirms that they have the + -- right to issue in this slot. + validateVRFSignature (praosStateEpochNonce cs) lv praosLeaderF b + -- Finally, we apply the changes from this header to the chain state. + pure $ reupdateChainDepStatePolyPraos cfg b slot tcs + where + lv = tickedPraosStateLedgerView tcs + cs = tickedPraosStateChainDepState tcs + +-- | 'reupdateChainDepState' for every Praos. +-- +-- Re-update the chain dependent state as a result of processing a header. +-- +-- This consists of: +-- - Update the last applied block hash. +-- - Update the evolving and (potentially) candidate nonces based on the +-- position in the epoch. +-- - Update the operational certificate counter. +-- - Record the header's announcement, if any, replacing the previous one. +reupdateChainDepStatePolyPraos :: + forall proto c. + Functor (LeiosOnly proto ()) => + ConsensusConfig (Praos c) -> + Views.PolyPraosValidateView proto c -> + SlotNo -> + Ticked (PolyPraosState proto) -> + PolyPraosState proto +reupdateChainDepStatePolyPraos + _cfg@( PraosConfig + PraosParams{praosRandomnessStabilisationWindow} + ei + ) + b + slot + tcs = + cs + { praosStateLastSlot = NotOrigin slot + , praosStateLabNonce = prevHashToNonce (Views.hvPrevHash b) + , praosStateEvolvingNonce = newEvolvingNonce + , praosStateCandidateNonce = + if slot +* Duration praosRandomnessStabilisationWindow < firstSlotNextEpoch + then newEvolvingNonce + else praosStateCandidateNonce cs + , praosStateOCertCounters = + Map.insert hk n $ praosStateOCertCounters cs + , praosStateLeiosAnnouncement = + fmap + (\(_containsCert, mbAnn) -> MkAnnouncedBy hk <$> mbAnn) + (Views.hvLeios b) + } + where + epochInfoWithErr = + hoistEpochInfo + (either throw pure . runExcept) + ei + firstSlotNextEpoch = runIdentity $ do + EpochNo currentEpochNo <- epochInfoEpoch epochInfoWithErr slot + let nextEpoch = EpochNo $ currentEpochNo + 1 + epochInfoFirst epochInfoWithErr nextEpoch + cs = tickedPraosStateChainDepState tcs + eta = vrfNonceValue (Proxy @c) $ Views.hvVrfRes b + newEvolvingNonce = praosStateEvolvingNonce cs â­’ eta + OCert _ n _ _ = Views.hvOCert b + hk = hashKey $ Views.hvVK b + +-- | The Leios header checks that read only the header and the ledger view. +-- +-- Sound out of context: the bound they check is forecast for the header's own +-- slot, so any path that validates the header reads the same value. +-- +-- They run only for protocols with Leios, which are the ones that fill +-- 'typeSwitchR'. +leiosContextFreeHeaderChecks :: + ( Applicative (LeiosOnly proto ()) + , Foldable (LeiosOnly proto ()) + , TypeSwitch (LeiosOnly proto) + ) => + Views.PolyPraosLedgerView proto -> + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () +leiosContextFreeHeaderChecks lv b = + traverse_ check $ + (,,) <$> typeSwitchR <*> Views.hvLeios b <*> Views.plvMaxEbBodySize lv + where + check (err, (_containsCert, mbAnn), maxEbBodySize) = + case mbAnn of + SNothing -> pure () + SJust ann -> do + let announced = ebReferencesAnnouncementSize ann + when (announced > maxEbBodySize) $ + throwError $ + LeiosEbTooBig err announced maxEbBodySize + +-- | The Leios-specific checks on a header, called by 'updateChainDepState'. +-- +-- 'leiosContextFreeHeaderChecks' plus the one check that needs the header's +-- immediate predecessor: a block may not certify an announcement younger than +-- the certification gap, and only the predecessor's state says which +-- announcement that is. +leiosHeaderChecks :: + ( Applicative (LeiosOnly proto ()) + , Foldable (LeiosOnly proto ()) + , TypeSwitch (LeiosOnly proto) + ) => + ConsensusConfig (Praos c) -> + Views.PolyPraosLedgerView proto -> + Views.PolyPraosValidateView proto c -> + SlotNo -> + PolyPraosState proto -> + Except (PolyPraosValidationErr proto c) () +leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = do + leiosContextFreeHeaderChecks lv b + traverse_ check $ + (,,,,,) + <$> typeSwitchR + <*> Views.hvLeios b + <*> Views.plvAnnouncementPeriodLength lv + <*> Views.plvVotePeriodLength lv + <*> Views.plvDiffusionPeriodLength lv + <*> praosStateLeiosAnnouncement cs + where + check + ( err + , (containsCert, _mbAnn) + , announcementPeriod + , votePeriod + , diffusionPeriod + , announcedByPredecessor + ) = + when containsCert $ + case (announcedByPredecessor, praosStateLastSlot cs) of + (SJust{}, NotOrigin announcingSlot) -> do + let earliestAllowed = + Leios.minCertificationSlot + ( runIdentity $ + epochInfoSlotLength + (History.toPureEpochInfo praosEpochInfo) + slot + ) + announcementPeriod + votePeriod + diffusionPeriod + announcingSlot + when (slot < earliestAllowed) $ + throwError $ + LeiosCertTooYoung err announcingSlot slot earliestAllowed + -- A state that announced an endorser block has necessarily applied a + -- header, so 'Origin' is the same situation as announcing nothing. + _ -> + throwError $ + LeiosCertWithoutAnnouncement err -- | Check whether this node meets the leader threshold to issue a block. meetsLeaderThreshold :: - forall c. + forall proto c. ConsensusConfig (Praos c) -> - LedgerView (Praos c) -> + Views.PolyPraosLedgerView proto -> SL.KeyHash SL.StakePool -> VRF.CertifiedVRF (VRF c) InputVRF -> Bool @@ -561,26 +874,26 @@ meetsLeaderThreshold Map.lookup keyHash poolDistr validateVRFSignature :: - forall c. - PraosCrypto c => + forall proto c. + PolyPraosCrypto proto c => Nonce -> - Views.PraosLedgerView -> + Views.PolyPraosLedgerView proto -> ActiveSlotCoeff -> - Views.HeaderView c -> - Except (PraosValidationErr c) () + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = doValidateVRFSignature eta0 pd -- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need -- to construct a 'PraosConfig' nor 'LedgerView' to test it. doValidateVRFSignature :: - forall c. - PraosCrypto c => + forall proto c. + PolyPraosCrypto proto c => Nonce -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> ActiveSlotCoeff -> - Views.HeaderView c -> - Except (PraosValidationErr c) () + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () doValidateVRFSignature eta0 pd f b = do case Map.lookup hk pd of Nothing -> throwError $ VRFKeyUnknown hk @@ -606,12 +919,12 @@ doValidateVRFSignature eta0 pd f b = do slot = Views.hvSlotNo b validateKESSignature :: - PraosCrypto c => + PolyPraosCrypto proto c => ConsensusConfig (Praos c) -> - LedgerView (Praos c) -> + Views.PolyPraosLedgerView proto -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.HeaderView c -> - Except (PraosValidationErr c) () + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () validateKESSignature _cfg@( PraosConfig PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} @@ -624,13 +937,13 @@ validateKESSignature -- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to -- construct a 'PraosConfig' nor 'LedgerView' to test it. doValidateKESSignature :: - PraosCrypto c => + PolyPraosCrypto proto c => Word64 -> Word64 -> Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> Map (KeyHash SL.BlockIssuer) Word64 -> - Views.HeaderView c -> - Except (PraosValidationErr c) () + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = do c0 <= kp ?! KESBeforeStartOCERT c0 kp @@ -692,7 +1005,7 @@ data PraosCannotForge c !OCert.KESPeriod deriving Generic -deriving instance PraosCrypto c => Show (PraosCannotForge c) +deriving instance Crypto c => Show (PraosCannotForge c) praosCheckCanForge :: ConsensusConfig (Praos c) -> @@ -723,29 +1036,38 @@ praosCheckCanForge instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where type PraosProtocolSupportsNodeCrypto (Praos c) = c - getPraosNonces _prx cdst = - PraosNonces - { candidateNonce = praosStateCandidateNonce - , epochNonce = praosStateEpochNonce - , evolvingNonce = praosStateEvolvingNonce - , labNonce = praosStateLabNonce - , previousLabNonce = praosStateLastEpochBlockNonce - } - where - PraosState - { praosStateCandidateNonce - , praosStateEpochNonce - , praosStateEvolvingNonce - , praosStateLabNonce - , praosStateLastEpochBlockNonce - } = cdst + getPraosNonces _prx = getPraosNoncesPolyPraos - getOpCertCounters _prx cdst = - praosStateOCertCounters - where - PraosState - { praosStateOCertCounters - } = cdst + getOpCertCounters _prx = getOpCertCountersPolyPraos + +-- | 'getPraosNonces' for every Praos. +getPraosNoncesPolyPraos :: PolyPraosState proto -> PraosNonces +getPraosNoncesPolyPraos cdst = + PraosNonces + { candidateNonce = praosStateCandidateNonce + , epochNonce = praosStateEpochNonce + , evolvingNonce = praosStateEvolvingNonce + , labNonce = praosStateLabNonce + , previousLabNonce = praosStateLastEpochBlockNonce + } + where + PraosState + { praosStateCandidateNonce + , praosStateEpochNonce + , praosStateEvolvingNonce + , praosStateLabNonce + , praosStateLastEpochBlockNonce + } = cdst + +-- | 'getOpCertCounters' for every Praos. +getOpCertCountersPolyPraos :: + PolyPraosState proto -> Map (KeyHash SL.BlockIssuer) Word64 +getOpCertCountersPolyPraos cdst = + praosStateOCertCounters + where + PraosState + { praosStateOCertCounters + } = cdst {------------------------------------------------------------------------------- Translation from transitional Praos @@ -764,6 +1086,13 @@ instance TranslateProto (TPraos c) (Praos c) where , Views.plvMaxHeaderSize = SL.ccMaxBHSize tplvChainChecks , Views.plvMaxBodySize = SL.ccMaxBBSize tplvChainChecks , Views.plvProtocolVersion = SL.ccProtocolVersion tplvChainChecks + , Views.plvCommittee = PraosLacksLeios () + , Views.plvQuorumStakeThreshold = PraosLacksLeios () + , Views.plvAnnouncementPeriodLength = PraosLacksLeios () + , Views.plvVotePeriodLength = PraosLacksLeios () + , Views.plvDiffusionPeriodLength = PraosLacksLeios () + , Views.plvMaxEbBodySize = PraosLacksLeios () + , Views.plvMaxEbTxsSize = PraosLacksLeios () } translateChainDepState _ tpState = @@ -776,6 +1105,7 @@ instance TranslateProto (TPraos c) (Praos c) where , praosStatePreviousEpochNonce = epochNonce -- same as current epoch nonce , praosStateLabNonce = csLabNonce , praosStateLastEpochBlockNonce = SL.ticknStatePrevHashNonce csTickn + , praosStateLeiosAnnouncement = PraosLacksLeios () } where SL.ChainDepState{SL.csProtocol, SL.csTickn, SL.csLabNonce} = @@ -799,3 +1129,21 @@ infix 1 ?! (Left e1) ?!: f = throwError $ f e1 infix 1 ?!: + +instance Views.ForecastsLeios (Praos c) era where + forecastToPolyPraosLedgerView (f :: SL.Forecast t era) = + Views.PraosLedgerView + { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t + , Views.plvMaxHeaderSize = ccMaxBHSize cc + , Views.plvMaxBodySize = ccMaxBBSize cc + , Views.plvProtocolVersion = ccProtocolVersion cc + , Views.plvCommittee = PraosLacksLeios () + , Views.plvQuorumStakeThreshold = PraosLacksLeios () + , Views.plvAnnouncementPeriodLength = PraosLacksLeios () + , Views.plvVotePeriodLength = PraosLacksLeios () + , Views.plvDiffusionPeriodLength = PraosLacksLeios () + , Views.plvMaxEbBodySize = PraosLacksLeios () + , Views.plvMaxEbTxsSize = PraosLacksLeios () + } + where + cc = SL.forecastChainChecks @t @era f 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 ea0095124e..8031494965 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 @@ -6,13 +6,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Various things common to iterations of the Praos protocol. module Ouroboros.Consensus.Protocol.Praos.Common - ( MaxMajorProtVer (..) + ( LeiosOnly + , pureLeiosOnly + , TypeSwitch (..) + , ShelleyProtocolHeader + , MaxMajorProtVer (..) , HasMaxMajorProtVer (..) , PraosCanBeLeader (..) , PraosTiebreakerView (..) @@ -40,8 +45,10 @@ import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Slot (SlotNo) import qualified Control.Tracer as Tracer import Data.Function (on) +import Data.Kind (Constraint, Type) import Data.Map.Strict (Map) import Data.Ord (Down (..)) +import Data.Void (Void) import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class @@ -353,3 +360,58 @@ class ConsensusProtocol p => PraosProtocolSupportsNode p where getPraosNonces :: proxy p -> ChainDepState p -> PraosNonces getOpCertCounters :: proxy p -> ChainDepState p -> Map (KeyHash BlockIssuer) Word64 + +----- + +-- | The header a protocol validates, determined by the protocol. +-- +-- TODO two things to fix here, both deferred because each touches every use in +-- ouroboros-consensus-cardano. The name is not Shelley's --- this is whichever +-- header the protocol signs, which is why 'HeaderView' and the instances for +-- 'Praos', 'Praos2' and 'TPraos' all need it from the protocol package. +-- And 'Shelley.Protocol.Abstract' currently re-exports this, which the importers +-- there should stop relying on: they should name this module. +type family ShelleyProtocolHeader proto = (sh :: Type) | sh -> proto + +-- | @a@ for the protocols without Leios, and @b@ for the ones with it. +-- +-- One such family per extension, which is what keeps every type that mentions +-- one indexed by @proto@ alone. Its two intended uses: +-- +-- * @LeiosOnly proto Void ()@ gates a constructor, since the protocols +-- without Leios cannot build it. +-- +-- * @LeiosOnly proto () a@ gates a field, which those protocols have but +-- cannot put anything in. +type LeiosOnly :: Type -> Type -> Type -> Type +data family LeiosOnly proto a :: Type -> Type + +-- | 'pure' for the field form of 'LeiosOnly', with @proto@ first so callers +-- can fix it with a type application. +pureLeiosOnly :: + forall proto b. Applicative (LeiosOnly proto ()) => b -> LeiosOnly proto () b +pureLeiosOnly = pure + +-- | Allow for any type on the side of a type-level switch that wasn't chosen +-- +-- For our types like 'LeiosOnly', there is only one instance that type checks. +-- See 'Ouroboros.Consensus.Protocol.Praos.leiosContextFreeHeaderChecks' for an +-- example use. +-- +-- Example: +-- +-- > newtype L a b = L a +-- > +-- > instance TypeSwitch L where +-- > typeSwitchL = L (L ()) +-- > typeSwitchR = L () +-- +-- The usefulness is that the inner layer of L (L ()) is parametrically +-- polymorphic in @a@. +-- +-- Another way to think about it: these @ff@ are types like 'Either' except the +-- choice between 'Left' and 'Right' is made statically rather than dynamically. +type TypeSwitch :: (Type -> Type -> Type) -> Constraint +class TypeSwitch ff where + typeSwitchL :: ff (ff () Void) () + typeSwitchR :: ff () (ff Void ()) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs new file mode 100644 index 0000000000..9b86a77901 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Orphans.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Which part of each Praos header is the signed one. +-- +-- Orphans by necessity: 'Signed' is declared in @ouroboros-consensus@ and the +-- header types in @cardano-protocol@, so no module owning either can host +-- these. They are alone here so that the pragma covers nothing else. +module Ouroboros.Consensus.Protocol.Praos.Orphans () where + +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec +import Ouroboros.Consensus.Protocol.Signed (Signed) + +type instance Signed (PraosCodec.Header c) = PraosCodec.HeaderBody c + +type instance Signed (LeiosCodec.Header c) = LeiosCodec.HeaderBody c 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 590f31a1d5..af3fa0b1ba 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 @@ -1,30 +1,45 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Protocol.Praos.Views - ( HeaderView (..) - , PraosLedgerView (..) - , forecastToPraosLedgerView + ( PolyPraosLedgerView (..) + , PolyPraosValidateView (..) + , ForecastsLeios (..) ) where import Cardano.Crypto.KES (SignedKES) import Cardano.Crypto.VRF (CertifiedVRF, VRFAlgorithm (VerKeyVRF)) -import Cardano.Ledger.BaseTypes (ProtVer) -import Cardano.Ledger.Chain (ChainChecksPParams (..)) +import Cardano.Ledger.BaseTypes + ( Milliseconds32 + , ProtVer + , StrictMaybe + , UnitInterval + ) +import Cardano.Ledger.Block (EbReferencesAnnouncement) import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import qualified Cardano.Ledger.Shelley.API as SL +import Cardano.Ledger.State (LeiosCommittee) import Cardano.Protocol.Crypto (KES, VRF) -import Cardano.Protocol.Praos.BlockHeader (HeaderBody) import Cardano.Protocol.Praos.VRF (InputVRF) import Cardano.Protocol.TPraos.BlockHeader (PrevHash) import Cardano.Protocol.TPraos.OCert (OCert) import Cardano.Slotting.Slot (SlotNo) +import Data.Kind (Constraint, Type) import Data.Word (Word16, Word32) -import Lens.Micro ((^.)) +import Ouroboros.Consensus.Protocol.Praos.Common (LeiosOnly, ShelleyProtocolHeader) +import Ouroboros.Consensus.Protocol.Signed (Signed) + +{------------------------------------------------------------------------------- + Header view +-------------------------------------------------------------------------------} -- | View of the block header required by the Praos protocol. -data HeaderView crypto = HeaderView +type PolyPraosValidateView :: Type -> Type -> Type +data PolyPraosValidateView proto crypto = HeaderView { hvPrevHash :: !PrevHash -- ^ Hash of the previous block , hvVK :: !(VKey BlockIssuer) @@ -37,13 +52,22 @@ data HeaderView crypto = HeaderView -- ^ operational certificate , hvSlotNo :: !SlotNo -- ^ Slot - , hvSigned :: !(HeaderBody crypto) + , hvLeios :: !(LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)) + -- ^ Whether this block's body carries a Leios certificate, and the endorser + -- block this header announces + , hvSigned :: !(Signed (ShelleyProtocolHeader proto)) -- ^ Header which must be signed - , hvSignature :: !(SignedKES (KES crypto) (HeaderBody crypto)) + , hvSignature :: !(SignedKES (KES crypto) (Signed (ShelleyProtocolHeader proto))) -- ^ KES Signature of the header } -data PraosLedgerView = PraosLedgerView +{------------------------------------------------------------------------------- + Ledger view +-------------------------------------------------------------------------------} + +-- | View of the ledger required by the Praos protocol. +type PolyPraosLedgerView :: Type -> Type +data PolyPraosLedgerView proto = PraosLedgerView { plvPoolDistr :: SL.PoolDistr -- ^ Stake distribution , plvMaxHeaderSize :: !Word16 @@ -52,21 +76,37 @@ data PraosLedgerView = PraosLedgerView -- ^ Maximum block body size , plvProtocolVersion :: !ProtVer -- ^ Current protocol version + , plvCommittee :: !(LeiosOnly proto () LeiosCommittee) + -- ^ Who may vote this epoch, and with what weight + , plvQuorumStakeThreshold :: !(LeiosOnly proto () UnitInterval) + -- ^ Weight a certificate must accumulate + , plvAnnouncementPeriodLength :: !(LeiosOnly proto () Milliseconds32) + , plvVotePeriodLength :: !(LeiosOnly proto () Milliseconds32) + , plvDiffusionPeriodLength :: !(LeiosOnly proto () Milliseconds32) + -- ^ The three periods that determine how long after its announcement an + -- endorser block may be certified. Kept as durations, since converting to a + -- count of slots needs the slot length, which only the consensus config has. + , plvMaxEbBodySize :: !(LeiosOnly proto () Word32) + -- ^ Maximum size of an endorser block itself, not its closure + , plvMaxEbTxsSize :: !(LeiosOnly proto () Word32) + -- ^ Maximum total size of the transactions an endorser block references } - deriving Show --- | Build a 'PraosLedgerView' from a ledger 'EraForecast' -forecastToPraosLedgerView :: - forall t era. - SL.EraForecast era => - SL.Forecast t era -> - PraosLedgerView -forecastToPraosLedgerView f = - PraosLedgerView - { plvPoolDistr = f ^. SL.poolDistrForecastL @era @t - , plvMaxHeaderSize = ccMaxBHSize cc - , plvMaxBodySize = ccMaxBBSize cc - , plvProtocolVersion = ccProtocolVersion cc - } - where - cc = SL.forecastChainChecks @t @era f +deriving instance + ( Show (LeiosOnly proto () LeiosCommittee) + , Show (LeiosOnly proto () UnitInterval) + , Show (LeiosOnly proto () Milliseconds32) + , Show (LeiosOnly proto () Word32) + ) => + Show (PolyPraosLedgerView proto) + +type ForecastsLeios :: Type -> Type -> Constraint + +-- | How a protocol reads an era's forecast. +-- +-- A method rather than one shared function because only the protocols with +-- Leios may demand more of their era than 'SL.EraForecast', and knowing +-- @proto@ alone cannot supply that @era@ dictionary. +class ForecastsLeios proto era where + forecastToPolyPraosLedgerView :: + SL.EraForecast era => SL.Forecast t era -> PolyPraosLedgerView proto diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs new file mode 100644 index 0000000000..4f9e8f1a11 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | Praos with the Leios overlay. +module Ouroboros.Consensus.Protocol.Praos2 + ( LeiosOnly (..) + , LeiosCrypto + , Praos2 + , ConsensusConfig (..) + ) where + +import Cardano.Ledger.BaseTypes (Milliseconds32 (..), StrictMaybe (..)) +import Cardano.Ledger.Chain (ChainChecksPParams (..)) +import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra +import qualified Cardano.Ledger.Shelley.API as SL +import Cardano.Ledger.State (emptyLeiosCommittee) +import Cardano.Protocol.Crypto (Crypto, StandardCrypto) +import qualified Cardano.Protocol.Leios.BlockHeader as LeiosCodec +import Data.Kind (Type) +import Data.Proxy (Proxy (Proxy)) +import GHC.Generics (Generic) +import Lens.Micro ((^.)) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.Praos +import Ouroboros.Consensus.Protocol.Praos.Common + ( HasMaxMajorProtVer (..) + , PraosCanBeLeader + , PraosProtocolSupportsNode (..) + , PraosTiebreakerView + , ShelleyProtocolHeader + , TypeSwitch (..) + ) +import Ouroboros.Consensus.Protocol.Praos.Orphans () +import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views +import Ouroboros.Consensus.Protocol.TPraos (TPraos) + +{------------------------------------------------------------------------------- + The protocol +-------------------------------------------------------------------------------} + +type Praos2 :: Type -> Type +data Praos2 c + +type instance ShelleyProtocolHeader (Praos2 c) = LeiosCodec.Header c + +instance PolyPraosCrypto (Praos2 StandardCrypto) StandardCrypto + +class (Crypto c, PolyPraosCrypto (Praos2 c) c) => LeiosCrypto c + +instance LeiosCrypto StandardCrypto + +{------------------------------------------------------------------------------- + The fields only this protocol has +-------------------------------------------------------------------------------} + +-- | This protocol is Leios, so it holds the right alternative. +newtype instance LeiosOnly (Praos2 c) a b = Praos2HasLeios b + deriving (Eq, Generic, Show) + +deriving anyclass instance + NoThunks b => NoThunks (LeiosOnly (Praos2 c) a b) + +instance Functor (LeiosOnly (Praos2 c) a) where + fmap f (Praos2HasLeios b) = Praos2HasLeios (f b) + +instance Applicative (LeiosOnly (Praos2 c) a) where + pure = Praos2HasLeios + Praos2HasLeios f <*> Praos2HasLeios b = Praos2HasLeios (f b) + +instance Foldable (LeiosOnly (Praos2 c) a) where + foldMap f (Praos2HasLeios b) = f b + +instance Traversable (LeiosOnly (Praos2 c) a) where + traverse f (Praos2HasLeios b) = Praos2HasLeios <$> f b + +instance TypeSwitch (LeiosOnly (Praos2 c)) where + typeSwitchL = Praos2HasLeios () + typeSwitchR = Praos2HasLeios (Praos2HasLeios ()) + +{------------------------------------------------------------------------------- + Configuration +-------------------------------------------------------------------------------} + +-- | Praos's configuration, wrapped only because 'ConsensusConfig' is a data +-- family. +-- +-- Leios adds nothing to it: the periods, the committee, the quorum and the size +-- bounds all reach the protocol through the ledger view instead. +newtype instance ConsensusConfig (Praos2 c) = LeiosConfig + { leiosPraosConfig :: ConsensusConfig (Praos c) + } + deriving Generic + +deriving newtype instance Crypto c => NoThunks (ConsensusConfig (Praos2 c)) + +instance HasMaxMajorProtVer (Praos2 c) where + protoMaxMajorPV = praosMaxMajorPV . praosParams . leiosPraosConfig + +{------------------------------------------------------------------------------- + ConsensusProtocol +-------------------------------------------------------------------------------} + +instance LeiosCrypto c => ConsensusProtocol (Praos2 c) where + type ChainDepState (Praos2 c) = PolyPraosState (Praos2 c) + type IsLeader (Praos2 c) = PraosIsLeader c + type CanBeLeader (Praos2 c) = PraosCanBeLeader c + type TiebreakerView (Praos2 c) = PraosTiebreakerView c + type LedgerView (Praos2 c) = Views.PolyPraosLedgerView (Praos2 c) + type ValidationErr (Praos2 c) = PolyPraosValidationErr (Praos2 c) c + type ValidateView (Praos2 c) = Views.PolyPraosValidateView (Praos2 c) c + + protocolSecurityParam = praosSecurityParam . praosParams . leiosPraosConfig + + checkIsLeader = checkIsLeaderPolyPraos . leiosPraosConfig + + tickChainDepState = tickChainDepStatePolyPraos . leiosPraosConfig + + -- The Leios header checks are cheap, so they run before the signature checks. + updateChainDepState = updateChainDepStatePolyPraos . leiosPraosConfig + + reupdateChainDepState = reupdateChainDepStatePolyPraos . leiosPraosConfig + +instance Dijkstra.DijkstraEraForecast era => Views.ForecastsLeios (Praos2 c) era where + forecastToPolyPraosLedgerView (f :: SL.Forecast t era) = + Views.PraosLedgerView + { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t + , Views.plvMaxHeaderSize = ccMaxBHSize cc + , Views.plvMaxBodySize = ccMaxBBSize cc + , Views.plvProtocolVersion = ccProtocolVersion cc + , Views.plvCommittee = + Praos2HasLeios $ f ^. Dijkstra.leiosCommitteeForecastL @era @t + , Views.plvQuorumStakeThreshold = + Praos2HasLeios $ f ^. Dijkstra.leiosQuorumStakeThresholdForecastL @era @t + , Views.plvAnnouncementPeriodLength = + Praos2HasLeios $ f ^. Dijkstra.leiosAnnouncementPeriodLengthForecastL @era @t + , Views.plvVotePeriodLength = + Praos2HasLeios $ f ^. Dijkstra.leiosVotePeriodLengthForecastL @era @t + , Views.plvDiffusionPeriodLength = + Praos2HasLeios $ f ^. Dijkstra.leiosDiffusionPeriodLengthForecastL @era @t + , Views.plvMaxEbBodySize = + Praos2HasLeios $ f ^. Dijkstra.maxEndorserBlockReferencesSizeForecastL @era @t + , Views.plvMaxEbTxsSize = + Praos2HasLeios $ f ^. Dijkstra.maxEndorserBlockTxsSizeForecastL @era @t + } + where + cc = SL.forecastChainChecks @t @era f + +{------------------------------------------------------------------------------- + Translation from the protocol without Leios +-------------------------------------------------------------------------------} + +-- | Crossing from Praos into Praos with Leios. +-- +-- Everything carries over unchanged; the Leios fields merely have to be +-- introduced. The announcement starts empty, since no header of the protocol +-- being left could have carried one. The ledger view seats no committee, so +-- nothing can be certified against it: the committee is empty and the quorum is +-- the entire weight. That is the truth, not a placeholder, until a snapshot +-- seated by the new era's rules rotates in, so the other values do not matter. +instance TranslateProto (Praos c) (Praos2 c) where + translateLedgerView _ lv = + Views.PraosLedgerView + { Views.plvPoolDistr = Views.plvPoolDistr lv + , Views.plvMaxHeaderSize = Views.plvMaxHeaderSize lv + , Views.plvMaxBodySize = Views.plvMaxBodySize lv + , Views.plvProtocolVersion = Views.plvProtocolVersion lv + , Views.plvCommittee = Praos2HasLeios emptyLeiosCommittee + , Views.plvQuorumStakeThreshold = Praos2HasLeios maxBound + , Views.plvAnnouncementPeriodLength = Praos2HasLeios (Milliseconds32 0) + , Views.plvVotePeriodLength = Praos2HasLeios (Milliseconds32 0) + , Views.plvDiffusionPeriodLength = Praos2HasLeios (Milliseconds32 1000000000) + , Views.plvMaxEbBodySize = Praos2HasLeios 0 + , Views.plvMaxEbTxsSize = Praos2HasLeios 0 + } + + translateChainDepState _ st = + PraosState + { praosStateLastSlot = praosStateLastSlot st + , praosStateOCertCounters = praosStateOCertCounters st + , praosStateEvolvingNonce = praosStateEvolvingNonce st + , praosStateCandidateNonce = praosStateCandidateNonce st + , praosStateEpochNonce = praosStateEpochNonce st + , praosStatePreviousEpochNonce = praosStatePreviousEpochNonce st + , praosStateLabNonce = praosStateLabNonce st + , praosStateLastEpochBlockNonce = praosStateLastEpochBlockNonce st + , praosStateLeiosAnnouncement = Praos2HasLeios SNothing + } + +instance forall c. TranslateProto (TPraos c) (Praos2 c) where + translateLedgerView _ = + translateLedgerView (Proxy @(Praos c, Praos2 c)) + . translateLedgerView (Proxy @(TPraos c, Praos c)) + + translateChainDepState _ = + translateChainDepState (Proxy @(Praos c, Praos2 c)) + . translateChainDepState (Proxy @(TPraos c, Praos c)) + +{------------------------------------------------------------------------------- + PraosProtocolSupportsNode +-------------------------------------------------------------------------------} + +instance LeiosCrypto c => PraosProtocolSupportsNode (Praos2 c) where + type PraosProtocolSupportsNodeCrypto (Praos2 c) = c + + getPraosNonces _prx = getPraosNoncesPolyPraos + + getOpCertCounters _prx = getOpCertCountersPolyPraos 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 3790b35d64..ec00de0f14 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 @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | Transitional Praos. -- @@ -15,6 +17,7 @@ module Ouroboros.Consensus.Protocol.TPraos ( MaxMajorProtVer (..) , TPraos + , LeiosOnly (..) , TPraosFields (..) , TPraosIsLeader (..) , TPraosParams (..) @@ -168,6 +171,29 @@ type TPraosValidateView c = SL.BHeader c data TPraos c +-- | TPraos has no Leios fields. +newtype instance LeiosOnly (TPraos c) a b = TPraosLacksLeios a + deriving (Eq, Generic, Show) + +deriving anyclass instance NoThunks a => NoThunks (LeiosOnly (TPraos c) a b) + +instance Functor (LeiosOnly (TPraos c) a) where + fmap _ (TPraosLacksLeios a) = TPraosLacksLeios a + +instance () ~ a => Applicative (LeiosOnly (TPraos c) a) where + pure _ = TPraosLacksLeios () + TPraosLacksLeios () <*> TPraosLacksLeios () = TPraosLacksLeios () + +instance Foldable (LeiosOnly (TPraos c) a) where + foldMap _ (TPraosLacksLeios _) = mempty + +instance Traversable (LeiosOnly (TPraos c) a) where + traverse _ (TPraosLacksLeios a) = pure (TPraosLacksLeios a) + +instance TypeSwitch (LeiosOnly (TPraos c)) where + typeSwitchL = TPraosLacksLeios (TPraosLacksLeios ()) + typeSwitchR = TPraosLacksLeios () + -- | TPraos parameters that are node independent data TPraosParams = TPraosParams { tpraosSlotsPerKESPeriod :: !Word64 diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index 6715ca42c4..f147f73a23 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Generators suitable for serialisation. Note that these are not guaranteed @@ -6,6 +8,7 @@ module Test.Consensus.Protocol.Serialisation.Generators () where import Cardano.Crypto.KES (unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) +import Cardano.Ledger.Block (EbReferencesAnnouncement (..)) import Cardano.Protocol.Praos.BlockHeader ( Header (Header) , HeaderBody (HeaderBody) @@ -21,8 +24,12 @@ import Cardano.Slotting.Slot ( SlotNo (SlotNo) , WithOrigin (At, Origin) ) -import Ouroboros.Consensus.Protocol.Praos (PraosState (PraosState)) +import Ouroboros.Consensus.Protocol.Praos + ( AnnouncedBy (MkAnnouncedBy) + , PolyPraosState (PraosState) + ) import qualified Ouroboros.Consensus.Protocol.Praos as Praos +import Ouroboros.Consensus.Protocol.Praos.Common (pureLeiosOnly) import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () import Test.Crypto.KES () import Test.QuickCheck (Arbitrary (..), Gen, choose, oneof) @@ -66,7 +73,18 @@ instance Praos.PraosCrypto c => Arbitrary (Header c) where let hSig = unsoundPureSignedKES () period hBody sKey pure $ Header hBody hSig -instance Arbitrary PraosState where +instance Arbitrary AnnouncedBy where + arbitrary = + MkAnnouncedBy + <$> arbitrary + <*> (EbReferencesAnnouncement <$> arbitrary <*> arbitrary) + +instance + ( Applicative (Praos.LeiosOnly proto ()) + , Traversable (Praos.LeiosOnly proto ()) + ) => + Arbitrary (PolyPraosState proto) + where arbitrary = PraosState <$> oneof @@ -80,3 +98,4 @@ instance Arbitrary PraosState where <*> arbitrary <*> arbitrary <*> arbitrary + <*> traverse (\() -> arbitrary) (pureLeiosOnly ()) diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index db186a28f3..936bcc9509 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -107,7 +107,7 @@ import Data.Ratio ((%)) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word64) import GHC.Generics (Generic) -import Ouroboros.Consensus.Protocol.Praos (PraosValidationErr (..)) +import Ouroboros.Consensus.Protocol.Praos (PolyPraosValidationErr (..), PraosValidationErr) import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) import Test.QuickCheck ( Gen diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 369daee973..9a5003669a 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1178,7 +1178,9 @@ library protocol Ouroboros.Consensus.Protocol.Praos Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common + Ouroboros.Consensus.Protocol.Praos.Orphans Ouroboros.Consensus.Protocol.Praos.Views + Ouroboros.Consensus.Protocol.Praos2 Ouroboros.Consensus.Protocol.TPraos build-depends: @@ -1187,6 +1189,7 @@ library protocol cardano-crypto-class:cardano-crypto-class, cardano-ledger-binary, cardano-ledger-core, + cardano-ledger-dijkstra ^>=0.5, cardano-ledger-shelley ^>=1.20, cardano-protocol ^>=0.2, cardano-protocol-tpraos ^>=1.6, @@ -1607,7 +1610,7 @@ library cardano cardano-ledger-byron ^>=1.3, cardano-ledger-conway ^>=1.24, cardano-ledger-core, - cardano-ledger-dijkstra ^>=0.4, + cardano-ledger-dijkstra ^>=0.5, cardano-ledger-mary ^>=1.11, cardano-ledger-shelley, cardano-prelude, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs index 4f004158fa..c92508de68 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config.hs @@ -47,6 +47,15 @@ import Ouroboros.Consensus.Protocol.Abstract -- | The top-level node configuration data TopLevelConfig blk = TopLevelConfig { topLevelConfigProtocol :: !(ConsensusConfig (BlockProtocol blk)) + -- ^ TODO both @topLevelConfigProtocol@ and @ConsensusConfig@ are misnomers, + -- which isn't too surprising considering they couldn't even agree :/ + -- + -- I think "header" be the best non-exotic classifier for this. It's still + -- somewhat confusing, since "chains of blocks" /inherit/ semantics of the + -- "chains of headers" that this config /directly/ affects. So any effect + -- some value within @topLevelConfigHeader/HeaderConfig@ might have on the + -- treatment of blocks could cause confusion. But that's seems preferable to + -- the current, extremely nebulous classifers "protocol" and "consensus". , topLevelConfigLedger :: !(LedgerConfig blk) , topLevelConfigBlock :: !(BlockConfig blk) , topLevelConfigCodec :: !(CodecConfig blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Leios/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Leios/Types.hs index a224ff3e27..7c543bd0ea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Leios/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Leios/Types.hs @@ -36,10 +36,15 @@ module Ouroboros.Consensus.Leios.Types , encodeLeiosEbMaxFramingSize , encodeLeiosEbSize , leiosReferencesCapacity + + -- * Header checks + , minCertificationSlot ) where import Cardano.Crypto.Util (SignableRepresentation (..)) +import Cardano.Ledger.BaseTypes (Milliseconds32 (..)) import Cardano.Slotting.Slot (SlotNo (..)) +import Cardano.Slotting.Time (SlotLength, slotLengthToMillisec) import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) @@ -226,3 +231,32 @@ cborIntBytesSize n | n < 0x100 = 2 | n < 0x10000 = 3 | otherwise = 5 + +-- * Header checks + +-- | The earliest slot at which a block may certify an endorser block announced +-- in the given slot. +-- +-- The announcement, voting and diffusion periods must all have elapsed. They +-- are wall-clock durations, so the gap rounds up to whole slots: a block is +-- forged at its slot's onset, so the answer is the first slot whose onset is far +-- enough after the announcement. +minCertificationSlot :: + SlotLength -> + -- | Announcement period length + Milliseconds32 -> + -- | Vote period length + Milliseconds32 -> + -- | Diffusion period length + Milliseconds32 -> + -- | Slot of the announcing block + SlotNo -> + SlotNo +minCertificationSlot slotLength announcement vote diffusion announcingSlot = + announcingSlot + SlotNo (fromIntegral ((totalMs + slotMs - 1) `div` slotMs)) + where + totalMs = 3 * ms announcement + ms vote + ms diffusion + ms = toInteger . unMilliseconds32 + slotMs = case slotLengthToMillisec slotLength of + 0 -> error "minCertificationSlot: zero slot length" + n -> n diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs index ba196314bd..084df300b5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs @@ -62,6 +62,9 @@ import Ouroboros.Consensus.Ticked -- Defined out of the class so that protocols can define this type without -- having to define the entire protocol at the same time (or indeed in the same -- module). +-- +-- TODO See the TODO about this misnomer at +-- 'Ouroboros.Consensus.Config.topLevelConfigProtocol'. data family ConsensusConfig p :: Type -- | The (open) universe of Ouroboros protocols From 0dbbf6897c43bf68f84c2161c2a140b335597cd1 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 01:22:59 -0400 Subject: [PATCH 02/19] PolyPraos: don't take ConsensusConfig (Praos c) directly This prepares for the PolyPraos definitions to be defined before Praos. --- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 12 ++-- .../Ouroboros/Consensus/Protocol/Praos.hs | 65 +++++++++---------- .../Ouroboros/Consensus/Protocol/Praos2.hs | 8 +-- 3 files changed, 41 insertions(+), 44 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index a02568c11f..b786d829a7 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -77,7 +77,7 @@ praosSharedBlockForging :: (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> BlockForging m (ShelleyBlock (Praos c) era) -praosSharedBlockForging = basePraosSharedBlockForging id +praosSharedBlockForging = basePraosSharedBlockForging praosParams -- | 'praosSharedBlockForging' for every Praos. basePraosSharedBlockForging :: @@ -89,14 +89,14 @@ basePraosSharedBlockForging :: , Applicative (LeiosOnly proto ()) , IOLike m ) => - -- | The Praos configuration within this protocol's - (ConsensusConfig proto -> ConsensusConfig (Praos c)) -> + -- | The Praos parameters within this protocol's configuration + (ConsensusConfig proto -> PraosParams) -> HotKey.HotKey c m -> (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> BlockForging m (ShelleyBlock proto era) basePraosSharedBlockForging - getPraosConfig + getPraosParams hotKey slotToPeriod ShelleyLeaderCredentials @@ -111,7 +111,7 @@ basePraosSharedBlockForging <$> HotKey.evolve hotKey (slotToPeriod curSlot) , checkCanForge = \cfg curSlot _tickedChainDepState _isLeader -> praosCheckCanForge - (getPraosConfig (configConsensus cfg)) + (getPraosParams (configConsensus cfg)) curSlot , forgeBlock = forgeShelleyBlock hotKey canBeLeader , finalize = HotKey.finalize hotKey @@ -127,4 +127,4 @@ praos2SharedBlockForging :: (SlotNo -> Absolute.KESPeriod) -> ShelleyLeaderCredentials c -> BlockForging m (ShelleyBlock (Praos2 c) era) -praos2SharedBlockForging = basePraosSharedBlockForging leiosPraosConfig +praos2SharedBlockForging = basePraosSharedBlockForging (praosParams . leiosPraosConfig) 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 c4d1d7ece3..e686ca4050 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 @@ -577,32 +577,32 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where protocolSecurityParam = praosSecurityParam . praosParams - checkIsLeader = checkIsLeaderPolyPraos + checkIsLeader = checkIsLeaderPolyPraos . praosParams - tickChainDepState = tickChainDepStatePolyPraos + tickChainDepState = tickChainDepStatePolyPraos . praosEpochInfo - updateChainDepState = updateChainDepStatePolyPraos + updateChainDepState (PraosConfig prms ei) = updateChainDepStatePolyPraos prms ei - reupdateChainDepState = reupdateChainDepStatePolyPraos + reupdateChainDepState (PraosConfig prms ei) = reupdateChainDepStatePolyPraos prms ei -- | 'checkIsLeader' for every Praos. checkIsLeaderPolyPraos :: forall proto c. PolyPraosCrypto proto c => - ConsensusConfig (Praos c) -> + PraosParams -> PraosCanBeLeader c -> SlotNo -> Ticked (PolyPraosState proto) -> Maybe (PraosIsLeader c) checkIsLeaderPolyPraos - cfg + prms PraosCanBeLeader { praosCanBeLeaderSignKeyVRF , praosCanBeLeaderColdVerKey } slot cs = - if meetsLeaderThreshold cfg lv (SL.coerceKeyRole vkhCold) rho + if meetsLeaderThreshold (Proxy @c) prms lv (SL.coerceKeyRole vkhCold) rho then Just PraosIsLeader @@ -631,13 +631,13 @@ checkIsLeaderPolyPraos -- - Update the "last block of previous epoch" nonce to the nonce derived -- from the last applied block. tickChainDepStatePolyPraos :: - ConsensusConfig (Praos c) -> + EpochInfo (Except History.PastHorizonException) -> Views.PolyPraosLedgerView proto -> SlotNo -> PolyPraosState proto -> Ticked (PolyPraosState proto) tickChainDepStatePolyPraos - PraosConfig{praosEpochInfo} + praosEpochInfo lv slot st = @@ -680,29 +680,28 @@ updateChainDepStatePolyPraos :: , Foldable (LeiosOnly proto ()) , TypeSwitch (LeiosOnly proto) ) => - ConsensusConfig (Praos c) -> + PraosParams -> + EpochInfo (Except History.PastHorizonException) -> Views.PolyPraosValidateView proto c -> SlotNo -> Ticked (PolyPraosState proto) -> Except (PolyPraosValidationErr proto c) (PolyPraosState proto) updateChainDepStatePolyPraos - cfg@( PraosConfig - PraosParams{praosLeaderF} - _ - ) + prms@PraosParams{praosLeaderF} + ei b slot tcs = do -- The Leios header checks are cheap, so they run first. - leiosHeaderChecks cfg lv b slot cs + leiosHeaderChecks ei lv b slot cs -- First, we check the KES signature, which validates that the issuer is -- in fact who they say they are. - validateKESSignature cfg lv (praosStateOCertCounters cs) b + validateKESSignature prms lv (praosStateOCertCounters cs) b -- Then we examing the VRF proof, which confirms that they have the -- right to issue in this slot. validateVRFSignature (praosStateEpochNonce cs) lv praosLeaderF b -- Finally, we apply the changes from this header to the chain state. - pure $ reupdateChainDepStatePolyPraos cfg b slot tcs + pure $ reupdateChainDepStatePolyPraos prms ei b slot tcs where lv = tickedPraosStateLedgerView tcs cs = tickedPraosStateChainDepState tcs @@ -720,16 +719,15 @@ updateChainDepStatePolyPraos reupdateChainDepStatePolyPraos :: forall proto c. Functor (LeiosOnly proto ()) => - ConsensusConfig (Praos c) -> + PraosParams -> + EpochInfo (Except History.PastHorizonException) -> Views.PolyPraosValidateView proto c -> SlotNo -> Ticked (PolyPraosState proto) -> PolyPraosState proto reupdateChainDepStatePolyPraos - _cfg@( PraosConfig - PraosParams{praosRandomnessStabilisationWindow} - ei - ) + PraosParams{praosRandomnessStabilisationWindow} + ei b slot tcs = @@ -802,13 +800,13 @@ leiosHeaderChecks :: , Foldable (LeiosOnly proto ()) , TypeSwitch (LeiosOnly proto) ) => - ConsensusConfig (Praos c) -> + EpochInfo (Except History.PastHorizonException) -> Views.PolyPraosLedgerView proto -> Views.PolyPraosValidateView proto c -> SlotNo -> PolyPraosState proto -> Except (PolyPraosValidationErr proto c) () -leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = do +leiosHeaderChecks praosEpochInfo lv b slot cs = do leiosContextFreeHeaderChecks lv b traverse_ check $ (,,,,,) @@ -852,14 +850,16 @@ leiosHeaderChecks PraosConfig{praosEpochInfo} lv b slot cs = do -- | Check whether this node meets the leader threshold to issue a block. meetsLeaderThreshold :: - forall proto c. - ConsensusConfig (Praos c) -> + forall proxy proto c. + proxy c -> + PraosParams -> Views.PolyPraosLedgerView proto -> SL.KeyHash SL.StakePool -> VRF.CertifiedVRF (VRF c) InputVRF -> Bool meetsLeaderThreshold - PraosConfig{praosParams} + _prx + praosParams Views.PraosLedgerView{Views.plvPoolDistr} keyHash rho = @@ -920,16 +920,13 @@ doValidateVRFSignature eta0 pd f b = do validateKESSignature :: PolyPraosCrypto proto c => - ConsensusConfig (Praos c) -> + PraosParams -> Views.PolyPraosLedgerView proto -> Map (KeyHash SL.BlockIssuer) Word64 -> Views.PolyPraosValidateView proto c -> Except (PolyPraosValidationErr proto c) () validateKESSignature - _cfg@( PraosConfig - PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} - _ei - ) + PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} Views.PraosLedgerView{Views.plvPoolDistr = SL.PoolDistr plvPoolDistr _totalActiveStake} ocertCounters = doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod plvPoolDistr ocertCounters @@ -1008,12 +1005,12 @@ data PraosCannotForge c deriving instance Crypto c => Show (PraosCannotForge c) praosCheckCanForge :: - ConsensusConfig (Praos c) -> + PraosParams -> SlotNo -> HotKey.KESInfo -> Either (PraosCannotForge c) () praosCheckCanForge - PraosConfig{praosParams} + praosParams curSlot kesInfo | let startPeriod = HotKey.kesStartPeriod kesInfo diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs index 4f9e8f1a11..3115772eb4 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs @@ -124,14 +124,14 @@ instance LeiosCrypto c => ConsensusProtocol (Praos2 c) where protocolSecurityParam = praosSecurityParam . praosParams . leiosPraosConfig - checkIsLeader = checkIsLeaderPolyPraos . leiosPraosConfig + checkIsLeader = checkIsLeaderPolyPraos . praosParams . leiosPraosConfig - tickChainDepState = tickChainDepStatePolyPraos . leiosPraosConfig + tickChainDepState = tickChainDepStatePolyPraos . praosEpochInfo . leiosPraosConfig -- The Leios header checks are cheap, so they run before the signature checks. - updateChainDepState = updateChainDepStatePolyPraos . leiosPraosConfig + updateChainDepState (LeiosConfig (PraosConfig prms ei)) = updateChainDepStatePolyPraos prms ei - reupdateChainDepState = reupdateChainDepStatePolyPraos . leiosPraosConfig + reupdateChainDepState (LeiosConfig (PraosConfig prms ei)) = reupdateChainDepStatePolyPraos prms ei instance Dijkstra.DijkstraEraForecast era => Views.ForecastsLeios (Praos2 c) era where forecastToPolyPraosLedgerView (f :: SL.Forecast t era) = From 3c617adffa87be655e0ff1c3c1ecfa163afe8d12 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 01:53:09 -0400 Subject: [PATCH 03/19] PolyPraos: isolate it in its own module This commit is merely reorg. --- .../Ouroboros/Consensus/Protocol/PolyPraos.hs | 984 ++++++++++++++++ .../Ouroboros/Consensus/Protocol/Praos.hs | 1021 ++--------------- ouroboros-consensus.cabal | 1 + 3 files changed, 1050 insertions(+), 956 deletions(-) create mode 100644 ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs new file mode 100644 index 0000000000..956d896414 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs @@ -0,0 +1,984 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Praos, and the pieces every protocol built on Praos shares. +-- +-- Each such protocol is its own @proto@ type with its own instances, so that +-- none of Praos's rules are reused by accident. The data types, however, are +-- shared: they carry a @proto@ parameter, so that there is one definition of +-- each Praos concept regardless of which extensions the protocol enables. The +-- functions suffixed @PolyPraos@ are the method implementations every such +-- protocol delegates to. +-- +-- @Poly@ means "many": a @PolyPraos@ type or function handles multiple +-- extensions of/overlays on Praos, the ones used for Cardano. And the +-- @PolyPraos@ functions are indeed /polymorphic/ in the @proto@ tyvar. +-- +-- This is not a fully modular design: subsequent additional extensions will +-- also need to add to these same definitions (eg adding fields for Ouroboros +-- Phalanx). That is intentional. This code does not need to be classically +-- extensible, since there is, unfortunately, no such thing as an extensible +-- security proof. Our protocol changes are well studied before implemented, and +-- have never happened concurrently. +-- +-- In other words: it's a very important benefit that there is /one definition/ +-- to look at in order to see everything all of the Praos extensions +-- /cumulatively/ do. The type-level DSL used to isolate extension components is +-- simple and legible; see the 'LeiosOnly' data family, for example. +module Ouroboros.Consensus.Protocol.PolyPraos + ( AnnouncedBy (..) + , PolyPraosCrypto + , PolyPraosState (..) + , PolyPraosValidationErr (..) + , PraosCannotForge (..) + , PraosFields (..) + , PraosIsLeader (..) + , PraosParams (..) + , PraosToSign (..) + , SerialisePraosState + , Ticked (..) + , checkIsLeaderPolyPraos + , forgePraosFields + , getOpCertCountersPolyPraos + , getPraosNoncesPolyPraos + , leiosContextFreeHeaderChecks + , praosCheckCanForge + , reupdateChainDepStatePolyPraos + , updateChainDepStatePolyPraos + , tickChainDepStatePolyPraos + , validateKESSignature + , validateVRFSignature + + -- * For testing purposes + , doValidateKESSignature + , doValidateVRFSignature + ) where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize) +import qualified Cardano.Crypto.DSIGN as DSIGN +import qualified Cardano.Crypto.Hash as Hash +import qualified Cardano.Crypto.KES as KES +import qualified Cardano.Crypto.VRF as VRF +import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce, StrictMaybe (..), (â­’)) +import qualified Cardano.Ledger.BaseTypes as SL +import Cardano.Ledger.Block (EbReferencesAnnouncement (..)) +import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR) +import Cardano.Ledger.Hashes (HASH, extractHash, unsafeMakeSafeHash) +import Cardano.Ledger.Keys + ( DSIGN + , KeyHash + , VKey (VKey) + , coerceKeyRole + , hashKey + ) +import qualified Cardano.Ledger.Keys as SL +import Cardano.Ledger.Shelley (ShelleyEra) +import qualified Cardano.Ledger.Shelley.API as SL +import Cardano.Ledger.Slot (Duration (Duration), (+*)) +import qualified Cardano.Ledger.State as SL +import Cardano.Protocol.Crypto (Crypto, KES, VRF) +import Cardano.Protocol.Praos.VRF + ( InputVRF + , mkInputVRF + , vrfLeaderValue + , vrfNonceValue + ) +import Cardano.Protocol.TPraos.BlockHeader + ( BoundedNatural (bvValue) + , checkLeaderNatValue + , prevHashToNonce + ) +import Cardano.Protocol.TPraos.OCert + ( KESPeriod (KESPeriod) + , OCert (OCert) + , OCertSignable + ) +import qualified Cardano.Protocol.TPraos.OCert as OCert +import Cardano.Slotting.EpochInfo + ( EpochInfo + , epochInfoEpoch + , epochInfoFirst + , epochInfoSlotLength + , hoistEpochInfo + ) +import Cardano.Slotting.Slot + ( EpochNo (EpochNo) + , SlotNo (SlotNo) + , WithOrigin + , unSlotNo + ) +import qualified Codec.CBOR.Decoding as CBOR +import qualified Codec.CBOR.Encoding as CBOR +import Codec.Serialise (Serialise (decode, encode)) +import Control.Exception (throw) +import Control.Monad (unless, when) +import Control.Monad.Except (Except, runExcept, throwError) +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import Data.Functor.Identity (runIdentity) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (Proxy)) +import Data.Typeable (Typeable) +import Data.Void (Void) +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Numeric.Natural (Natural) +import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) +import qualified Ouroboros.Consensus.HardFork.History as History +import qualified Ouroboros.Consensus.Leios.Types as Leios +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) +import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) +import Ouroboros.Consensus.Protocol.Praos.Common +import Ouroboros.Consensus.Protocol.Praos.Orphans () +import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views +import Ouroboros.Consensus.Protocol.Signed (Signed) +import Ouroboros.Consensus.Ticked (Ticked) +import Ouroboros.Consensus.Util.CBOR (decodeStrictMaybe, encodeStrictMaybe) +import Ouroboros.Consensus.Util.Versioned + ( VersionDecoder (Decode) + , decodeVersion + , encodeVersion + ) + +-- | What a protocol needs of its crypto: the Praos essentials, plus signing +-- whichever header body it is the protocol for. +class + ( Crypto c + , DSIGN.Signable DSIGN (OCertSignable c) + , VRF.Signable (VRF c) InputVRF + , KES.Signable (KES c) (Signed (ShelleyProtocolHeader proto)) + ) => + PolyPraosCrypto proto c + +{------------------------------------------------------------------------------- + Fields required by Praos in the header +-------------------------------------------------------------------------------} + +data PraosFields c toSign = PraosFields + { praosSignature :: KES.SignedKES (KES c) toSign + , praosToSign :: toSign + } + deriving Generic + +deriving instance + (NoThunks toSign, Crypto c) => + NoThunks (PraosFields c toSign) + +deriving instance + (Show toSign, Crypto c) => + Show (PraosFields c toSign) + +-- | Fields arising from praos execution which must be included in +-- the block signature. +data PraosToSign c = PraosToSign + { praosToSignIssuerVK :: SL.VKey SL.BlockIssuer + -- ^ Verification key for the issuer of this block. + , praosToSignVrfVK :: VRF.VerKeyVRF (VRF c) + , praosToSignVrfRes :: VRF.CertifiedVRF (VRF c) InputVRF + -- ^ Verifiable random value. This is used both to prove the issuer is + -- eligible to issue a block, and to contribute to the evolving nonce. + , praosToSignOCert :: OCert.OCert c + -- ^ Lightweight delegation certificate mapping the cold (DSIGN) key to + -- the online KES key. + } + deriving Generic + +instance Crypto c => NoThunks (PraosToSign c) + +deriving instance Crypto c => Show (PraosToSign c) + +forgePraosFields :: + ( Crypto c + , KES.Signable (KES c) toSign + , Monad m + ) => + HotKey c m -> + PraosCanBeLeader c -> + PraosIsLeader c -> + (PraosToSign c -> toSign) -> + m (PraosFields c toSign) +forgePraosFields + hotKey + PraosCanBeLeader + { praosCanBeLeaderColdVerKey + , praosCanBeLeaderSignKeyVRF + } + PraosIsLeader{praosIsLeaderVrfRes} + mkToSign = do + ocert <- HotKey.getOCert hotKey + let signedFields = + PraosToSign + { praosToSignIssuerVK = praosCanBeLeaderColdVerKey + , praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF + , praosToSignVrfRes = praosIsLeaderVrfRes + , praosToSignOCert = ocert + } + toSign = mkToSign signedFields + signature <- HotKey.sign hotKey toSign + return + PraosFields + { praosSignature = signature + , praosToSign = toSign + } + +{------------------------------------------------------------------------------- + Protocol proper +-------------------------------------------------------------------------------} + +-- | Praos parameters that are node independent +data PraosParams = PraosParams + { praosSlotsPerKESPeriod :: !Word64 + -- ^ See 'Globals.slotsPerKESPeriod'. + , praosLeaderF :: !SL.ActiveSlotCoeff + -- ^ Active slots coefficient. This parameter represents the proportion + -- of slots in which blocks should be issued. This can be interpreted as + -- the probability that a party holding all the stake will be elected as + -- leader for a given slot. + , praosSecurityParam :: !SecurityParam + -- ^ See 'Globals.securityParameter'. + , praosMaxKESEvo :: !Word64 + -- ^ Maximum number of KES iterations, see 'Globals.maxKESEvo'. + , praosMaxMajorPV :: !MaxMajorProtVer + -- ^ All blocks invalid after this protocol version, see + -- 'Globals.maxMajorPV'. + , praosRandomnessStabilisationWindow :: !Word64 + -- ^ The number of slots before the start of an epoch where the + -- corresponding epoch nonce is snapshotted. This has to be at least one + -- stability window such that the nonce is stable at the beginning of the + -- epoch. Ouroboros Genesis requires this to be even larger, see + -- 'SL.computeRandomnessStabilisationWindow'. + } + deriving (Generic, NoThunks) + +-- | Assembled proof that the issuer has the right to issue a block in the +-- selected slot. +newtype PraosIsLeader c = PraosIsLeader + { praosIsLeaderVrfRes :: VRF.CertifiedVRF (VRF c) InputVRF + } + deriving Generic + +instance Crypto c => NoThunks (PraosIsLeader c) + +{------------------------------------------------------------------------------- + ConsensusProtocol +-------------------------------------------------------------------------------} + +-- | Praos consensus state. +-- +-- We track the last slot and the counters for operational certificates, as well +-- as a series of nonces which get updated in different ways over the course of +-- an epoch. +data PolyPraosState proto = PraosState + { praosStateLastSlot :: !(WithOrigin SlotNo) + , praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64) + -- ^ Operation Certificate counters + , praosStateEvolvingNonce :: !Nonce + -- ^ Evolving nonce + , praosStateCandidateNonce :: !Nonce + -- ^ Candidate nonce + , praosStateEpochNonce :: !Nonce + -- ^ Epoch nonce + , praosStatePreviousEpochNonce :: !Nonce + -- ^ Previous epoch nonce + , praosStateLabNonce :: !Nonce + -- ^ Nonce constructed from the hash of the previous block + , praosStateLastEpochBlockNonce :: !Nonce + -- ^ Nonce corresponding to the LAB nonce of the last block of the previous + -- epoch + , praosStateLeiosAnnouncement :: + !(LeiosOnly proto () (StrictMaybe AnnouncedBy)) + -- ^ The announcement carried by the most recently applied header, if any. + -- A header with no announcement clears it. + } + deriving Generic + +deriving instance + Show (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Show (PolyPraosState proto) + +deriving instance + Eq (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Eq (PolyPraosState proto) + +instance + ( Typeable proto + , NoThunks (LeiosOnly proto () (StrictMaybe AnnouncedBy)) + ) => + NoThunks (PolyPraosState proto) + +-- | An endorser block announcement, and the issuer of the header that carried +-- it. +-- +-- With that header's slot ('praosStateLastSlot') the issuer identifies the +-- election. +data AnnouncedBy = MkAnnouncedBy + { announcedByIssuer :: !(KeyHash SL.BlockIssuer) + , announcedEb :: !EbReferencesAnnouncement + } + deriving (Generic, Show, Eq, NoThunks) + +encodeAnnouncedBy :: AnnouncedBy -> CBOR.Encoding +encodeAnnouncedBy (MkAnnouncedBy issuer (EbReferencesAnnouncement h sz)) = + CBOR.encodeListLen 3 <> toCBOR issuer <> toCBOR (extractHash h) <> toCBOR sz + +decodeAnnouncedBy :: CBOR.Decoder s AnnouncedBy +decodeAnnouncedBy = do + enforceSize "AnnouncedBy" 3 + MkAnnouncedBy + <$> fromCBOR + <*> (EbReferencesAnnouncement . unsafeMakeSafeHash <$> fromCBOR <*> fromCBOR) + +instance SerialisePraosState proto => ToCBOR (PolyPraosState proto) where + toCBOR = encode + +instance SerialisePraosState proto => FromCBOR (PolyPraosState proto) where + fromCBOR = decode + +-- | What encoding 'PolyPraosState' needs of its protocol. +-- +-- 'LeiosOnly' decides which fields are written, and which format version is +-- written: 0 for 'Praos', 1 for 'Praos2'. The two protocols' versions are +-- separate namespaces: the HFC's era index precedes them, so the codec is +-- already chosen when the version is read. +type SerialisePraosState proto = + ( Typeable proto + , Applicative (LeiosOnly proto ()) + , Traversable (LeiosOnly proto ()) + ) + +instance SerialisePraosState proto => Serialise (PolyPraosState proto) where + encode + PraosState + { praosStateLastSlot + , praosStateOCertCounters + , praosStateEvolvingNonce + , praosStateCandidateNonce + , praosStateEpochNonce + , praosStatePreviousEpochNonce + , praosStateLabNonce + , praosStateLastEpochBlockNonce + , praosStateLeiosAnnouncement + } = + encodeVersion version $ + mconcat + [ CBOR.encodeListLen (8 + nLeiosFields) + , toCBOR praosStateLastSlot + , toCBOR praosStateOCertCounters + , toEraCBOR @ShelleyEra praosStateEvolvingNonce + , toEraCBOR @ShelleyEra praosStateCandidateNonce + , toEraCBOR @ShelleyEra praosStateEpochNonce + , toEraCBOR @ShelleyEra praosStatePreviousEpochNonce + , toEraCBOR @ShelleyEra praosStateLabNonce + , toEraCBOR @ShelleyEra praosStateLastEpochBlockNonce + , foldMap (encodeStrictMaybe encodeAnnouncedBy) praosStateLeiosAnnouncement + ] + where + nLeiosFields = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) + version = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) + + decode = + decodeVersion + [(version, Decode decodePraosState)] + where + version = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) + nLeiosFields = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) + + decodePraosState :: CBOR.Decoder s (PolyPraosState proto) + decodePraosState = do + enforceSize "PraosState" (8 + nLeiosFields) + PraosState + <$> fromCBOR + <*> fromCBOR + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> traverse + (\() -> decodeStrictMaybe decodeAnnouncedBy) + (pureLeiosOnly @proto ()) + +data instance Ticked (PolyPraosState proto) = TickedPraosState + { tickedPraosStateChainDepState :: PolyPraosState proto + , tickedPraosStateLedgerView :: Views.PolyPraosLedgerView proto + } + +-- | Errors which we might encounter +data PolyPraosValidationErr proto c + = VRFKeyUnknown + !(KeyHash SL.StakePool) -- unknown VRF keyhash (not registered) + | VRFKeyWrongVRFKey + !(KeyHash SL.StakePool) -- KeyHash of block issuer + !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c))) -- VRF KeyHash registered with stake pool + !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c))) -- VRF KeyHash from Header + | VRFKeyBadProof + !SlotNo -- Slot used for VRF calculation + !Nonce -- Epoch nonce used for VRF calculation + !(VRF.CertifiedVRF (VRF c) InputVRF) -- VRF calculated nonce value + | VRFLeaderValueTooBig Natural Rational ActiveSlotCoeff + | KESBeforeStartOCERT + !KESPeriod -- OCert Start KES Period + !KESPeriod -- Current KES Period + | KESAfterEndOCERT + !KESPeriod -- Current KES Period + !KESPeriod -- OCert Start KES Period + !Word64 -- Max KES Key Evolutions + | CounterTooSmallOCERT + !Word64 -- last KES counter used + !Word64 -- current KES counter + | -- | The KES counter has been incremented by more than 1 + CounterOverIncrementedOCERT + !Word64 -- last KES counter used + !Word64 -- current KES counter + | InvalidSignatureOCERT + !Word64 -- OCert counter + !KESPeriod -- OCert KES period + !String -- DSIGN error message + | InvalidKesSignatureOCERT + !Word -- current KES Period + !Word -- KES start period + !Word -- expected KES evolutions + !Word64 -- max KES evolutions + !String -- error message given by Consensus Layer + | NoCounterForKeyHashOCERT + !(KeyHash SL.BlockIssuer) -- stake pool key hash + | -- | The header sets its cert bit, but its predecessor announced no endorser + -- block, so there is nothing for the certificate to certify. + LeiosCertWithoutAnnouncement + !(LeiosOnly proto Void ()) + | -- | The header sets its cert bit too soon after its predecessor's + -- announcement: the announcement, voting and diffusion periods have not all + -- elapsed. + LeiosCertTooYoung + !(LeiosOnly proto Void ()) + !SlotNo -- Slot of the announcing block + !SlotNo -- Slot of this header + !SlotNo -- Earliest slot in which this header could have certified + | -- | The header announces an endorser block larger than the protocol + -- parameters allow. + LeiosEbTooBig + !(LeiosOnly proto Void ()) + !Word32 -- Announced size + !Word32 -- Maximum size + deriving Generic + +deriving instance + (Crypto c, Eq (LeiosOnly proto Void ())) => + Eq (PolyPraosValidationErr proto c) + +deriving instance + (Typeable proto, Crypto c, NoThunks (LeiosOnly proto Void ())) => + NoThunks (PolyPraosValidationErr proto c) + +deriving instance + (Crypto c, Show (LeiosOnly proto Void ())) => + Show (PolyPraosValidationErr proto c) + +instance ChainDepStateSupportsPeras (PolyPraosState proto) where + getEpochNonce = praosStateEpochNonce + +instance ChainDepStateSupportsPeras (Ticked (PolyPraosState proto)) where + getEpochNonce = praosStateEpochNonce . tickedPraosStateChainDepState + +-- | 'checkIsLeader' for every Praos. +checkIsLeaderPolyPraos :: + forall proto c. + PolyPraosCrypto proto c => + PraosParams -> + PraosCanBeLeader c -> + SlotNo -> + Ticked (PolyPraosState proto) -> + Maybe (PraosIsLeader c) +checkIsLeaderPolyPraos + prms + PraosCanBeLeader + { praosCanBeLeaderSignKeyVRF + , praosCanBeLeaderColdVerKey + } + slot + cs = + if meetsLeaderThreshold (Proxy @c) prms lv (SL.coerceKeyRole vkhCold) rho + then + Just + PraosIsLeader + { praosIsLeaderVrfRes = coerce rho + } + else Nothing + where + chainState = tickedPraosStateChainDepState cs + lv = tickedPraosStateLedgerView cs + eta0 = praosStateEpochNonce chainState + vkhCold = SL.hashKey praosCanBeLeaderColdVerKey + rho' = mkInputVRF slot eta0 + + rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF + +-- | 'tickChainDepState' for every Praos. +-- +-- Updating the chain dependent state for Praos. +-- +-- If we are not in a new epoch, then nothing happens. If we are in a new +-- epoch, we do three things: +-- - Store the existing current epoch nonce as the "previous epoch" nonce. +-- This is needed to validate Peras certificates when they appear in blocks. +-- - Update the epoch nonce to the combination of the candidate nonce and the +-- nonce derived from the last block of the previous epoch. +-- - Update the "last block of previous epoch" nonce to the nonce derived +-- from the last applied block. +tickChainDepStatePolyPraos :: + EpochInfo (Except History.PastHorizonException) -> + Views.PolyPraosLedgerView proto -> + SlotNo -> + PolyPraosState proto -> + Ticked (PolyPraosState proto) +tickChainDepStatePolyPraos + praosEpochInfo + lv + slot + st = + TickedPraosState + { tickedPraosStateChainDepState = st' + , tickedPraosStateLedgerView = lv + } + where + newEpoch = + isNewEpoch + (History.toPureEpochInfo praosEpochInfo) + (praosStateLastSlot st) + slot + st' = + if newEpoch + then + st + { praosStateEpochNonce = + praosStateCandidateNonce st + â­’ praosStateLastEpochBlockNonce st + , praosStatePreviousEpochNonce = + praosStateEpochNonce st + , praosStateLastEpochBlockNonce = + praosStateLabNonce st + } + else st + +-- | 'updateChainDepState' for every Praos. +-- +-- Validate and update the chain dependent state as a result of processing a +-- new header. +-- +-- This consists of: +-- - Validate the VRF checks +-- - Validate the KES checks +-- - Call 'reupdateChainDepState' +updateChainDepStatePolyPraos :: + ( PolyPraosCrypto proto c + , Applicative (LeiosOnly proto ()) + , Foldable (LeiosOnly proto ()) + , TypeSwitch (LeiosOnly proto) + ) => + PraosParams -> + EpochInfo (Except History.PastHorizonException) -> + Views.PolyPraosValidateView proto c -> + SlotNo -> + Ticked (PolyPraosState proto) -> + Except (PolyPraosValidationErr proto c) (PolyPraosState proto) +updateChainDepStatePolyPraos + prms@PraosParams{praosLeaderF} + ei + b + slot + tcs = do + -- The Leios header checks are cheap, so they run first. + leiosHeaderChecks ei lv b slot cs + -- First, we check the KES signature, which validates that the issuer is + -- in fact who they say they are. + validateKESSignature prms lv (praosStateOCertCounters cs) b + -- Then we examing the VRF proof, which confirms that they have the + -- right to issue in this slot. + validateVRFSignature (praosStateEpochNonce cs) lv praosLeaderF b + -- Finally, we apply the changes from this header to the chain state. + pure $ reupdateChainDepStatePolyPraos prms ei b slot tcs + where + lv = tickedPraosStateLedgerView tcs + cs = tickedPraosStateChainDepState tcs + +-- | 'reupdateChainDepState' for every Praos. +-- +-- Re-update the chain dependent state as a result of processing a header. +-- +-- This consists of: +-- - Update the last applied block hash. +-- - Update the evolving and (potentially) candidate nonces based on the +-- position in the epoch. +-- - Update the operational certificate counter. +-- - Record the header's announcement, if any, replacing the previous one. +reupdateChainDepStatePolyPraos :: + forall proto c. + Functor (LeiosOnly proto ()) => + PraosParams -> + EpochInfo (Except History.PastHorizonException) -> + Views.PolyPraosValidateView proto c -> + SlotNo -> + Ticked (PolyPraosState proto) -> + PolyPraosState proto +reupdateChainDepStatePolyPraos + PraosParams{praosRandomnessStabilisationWindow} + ei + b + slot + tcs = + cs + { praosStateLastSlot = NotOrigin slot + , praosStateLabNonce = prevHashToNonce (Views.hvPrevHash b) + , praosStateEvolvingNonce = newEvolvingNonce + , praosStateCandidateNonce = + if slot +* Duration praosRandomnessStabilisationWindow < firstSlotNextEpoch + then newEvolvingNonce + else praosStateCandidateNonce cs + , praosStateOCertCounters = + Map.insert hk n $ praosStateOCertCounters cs + , praosStateLeiosAnnouncement = + fmap + (\(_containsCert, mbAnn) -> MkAnnouncedBy hk <$> mbAnn) + (Views.hvLeios b) + } + where + epochInfoWithErr = + hoistEpochInfo + (either throw pure . runExcept) + ei + firstSlotNextEpoch = runIdentity $ do + EpochNo currentEpochNo <- epochInfoEpoch epochInfoWithErr slot + let nextEpoch = EpochNo $ currentEpochNo + 1 + epochInfoFirst epochInfoWithErr nextEpoch + cs = tickedPraosStateChainDepState tcs + eta = vrfNonceValue (Proxy @c) $ Views.hvVrfRes b + newEvolvingNonce = praosStateEvolvingNonce cs â­’ eta + OCert _ n _ _ = Views.hvOCert b + hk = hashKey $ Views.hvVK b + +-- | The Leios header checks that read only the header and the ledger view. +-- +-- Sound out of context: the bound they check is forecast for the header's own +-- slot, so any path that validates the header reads the same value. +-- +-- They run only for protocols with Leios, which are the ones that fill +-- 'typeSwitchR'. +leiosContextFreeHeaderChecks :: + ( Applicative (LeiosOnly proto ()) + , Foldable (LeiosOnly proto ()) + , TypeSwitch (LeiosOnly proto) + ) => + Views.PolyPraosLedgerView proto -> + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () +leiosContextFreeHeaderChecks lv b = + traverse_ check $ + (,,) <$> typeSwitchR <*> Views.hvLeios b <*> Views.plvMaxEbBodySize lv + where + check (err, (_containsCert, mbAnn), maxEbBodySize) = + case mbAnn of + SNothing -> pure () + SJust ann -> do + let announced = ebReferencesAnnouncementSize ann + when (announced > maxEbBodySize) $ + throwError $ + LeiosEbTooBig err announced maxEbBodySize + +-- | The Leios-specific checks on a header, called by 'updateChainDepState'. +-- +-- 'leiosContextFreeHeaderChecks' plus the one check that needs the header's +-- immediate predecessor: a block may not certify an announcement younger than +-- the certification gap, and only the predecessor's state says which +-- announcement that is. +leiosHeaderChecks :: + ( Applicative (LeiosOnly proto ()) + , Foldable (LeiosOnly proto ()) + , TypeSwitch (LeiosOnly proto) + ) => + EpochInfo (Except History.PastHorizonException) -> + Views.PolyPraosLedgerView proto -> + Views.PolyPraosValidateView proto c -> + SlotNo -> + PolyPraosState proto -> + Except (PolyPraosValidationErr proto c) () +leiosHeaderChecks praosEpochInfo lv b slot cs = do + leiosContextFreeHeaderChecks lv b + traverse_ check $ + (,,,,,) + <$> typeSwitchR + <*> Views.hvLeios b + <*> Views.plvAnnouncementPeriodLength lv + <*> Views.plvVotePeriodLength lv + <*> Views.plvDiffusionPeriodLength lv + <*> praosStateLeiosAnnouncement cs + where + check + ( err + , (containsCert, _mbAnn) + , announcementPeriod + , votePeriod + , diffusionPeriod + , announcedByPredecessor + ) = + when containsCert $ + case (announcedByPredecessor, praosStateLastSlot cs) of + (SJust{}, NotOrigin announcingSlot) -> do + let earliestAllowed = + Leios.minCertificationSlot + ( runIdentity $ + epochInfoSlotLength + (History.toPureEpochInfo praosEpochInfo) + slot + ) + announcementPeriod + votePeriod + diffusionPeriod + announcingSlot + when (slot < earliestAllowed) $ + throwError $ + LeiosCertTooYoung err announcingSlot slot earliestAllowed + -- A state that announced an endorser block has necessarily applied a + -- header, so 'Origin' is the same situation as announcing nothing. + _ -> + throwError $ + LeiosCertWithoutAnnouncement err + +-- | Check whether this node meets the leader threshold to issue a block. +meetsLeaderThreshold :: + forall proxy proto c. + proxy c -> + PraosParams -> + Views.PolyPraosLedgerView proto -> + SL.KeyHash SL.StakePool -> + VRF.CertifiedVRF (VRF c) InputVRF -> + Bool +meetsLeaderThreshold + _prx + praosParams + Views.PraosLedgerView{Views.plvPoolDistr} + keyHash + rho = + checkLeaderNatValue + (vrfLeaderValue (Proxy @c) rho) + r + (praosLeaderF praosParams) + where + SL.PoolDistr poolDistr _totalActiveStake = plvPoolDistr + r = + maybe 0 SL.individualPoolStake $ + Map.lookup keyHash poolDistr + +validateVRFSignature :: + forall proto c. + PolyPraosCrypto proto c => + Nonce -> + Views.PolyPraosLedgerView proto -> + ActiveSlotCoeff -> + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () +validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = + doValidateVRFSignature eta0 pd + +-- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need +-- to construct a 'PraosConfig' nor 'LedgerView' to test it. +doValidateVRFSignature :: + forall proto c. + PolyPraosCrypto proto c => + Nonce -> + Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> + ActiveSlotCoeff -> + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () +doValidateVRFSignature eta0 pd f b = do + case Map.lookup hk pd of + Nothing -> throwError $ VRFKeyUnknown hk + Just (SL.IndividualPoolStake{SL.individualPoolStake = sigma, SL.individualPoolStakeVrf = vrfHK}) -> do + let vrfHKStake = SL.fromVRFVerKeyHash vrfHK + vrfHKBlock = VRF.hashVerKeyVRF vrfK + vrfHKStake + == vrfHKBlock + ?! VRFKeyWrongVRFKey hk vrfHKStake vrfHKBlock + VRF.verifyCertified + () + vrfK + (mkInputVRF slot eta0) + vrfCert + ?! VRFKeyBadProof slot eta0 vrfCert + checkLeaderNatValue vrfLeaderVal sigma f + ?! VRFLeaderValueTooBig (bvValue vrfLeaderVal) sigma f + where + hk = coerceKeyRole . hashKey . Views.hvVK $ b + vrfK = Views.hvVrfVK b + vrfCert = Views.hvVrfRes b + vrfLeaderVal = vrfLeaderValue (Proxy @c) vrfCert + slot = Views.hvSlotNo b + +validateKESSignature :: + PolyPraosCrypto proto c => + PraosParams -> + Views.PolyPraosLedgerView proto -> + Map (KeyHash SL.BlockIssuer) Word64 -> + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () +validateKESSignature + PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} + Views.PraosLedgerView{Views.plvPoolDistr = SL.PoolDistr plvPoolDistr _totalActiveStake} + ocertCounters = + doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod plvPoolDistr ocertCounters + +-- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to +-- construct a 'PraosConfig' nor 'LedgerView' to test it. +doValidateKESSignature :: + PolyPraosCrypto proto c => + Word64 -> + Word64 -> + Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> + Map (KeyHash SL.BlockIssuer) Word64 -> + Views.PolyPraosValidateView proto c -> + Except (PolyPraosValidationErr proto c) () +doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = + do + c0 <= kp ?! KESBeforeStartOCERT c0 kp + kp_ < c0_ + fromIntegral praosMaxKESEvo ?! KESAfterEndOCERT kp c0 praosMaxKESEvo + + let t = if kp_ >= c0_ then kp_ - c0_ else 0 + -- this is required to prevent an arithmetic underflow, in the case of kp_ < + -- c0_ we get the above `KESBeforeStartOCERT` failure in the transition. + + DSIGN.verifySignedDSIGN () vkcold (OCert.ocertToSignable oc) tau + ?!: InvalidSignatureOCERT n c0 + KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) + ?!: InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo + + case currentIssueNo of + Nothing -> do + throwError $ NoCounterForKeyHashOCERT hk + Just m -> do + m <= n ?! CounterTooSmallOCERT m n + n <= m + 1 ?! CounterOverIncrementedOCERT m n + where + oc@(OCert vk_hot n c0@(KESPeriod c0_) tau) = Views.hvOCert b + (VKey vkcold) = Views.hvVK b + SlotNo s = Views.hvSlotNo b + hk = hashKey $ Views.hvVK b + kp@(KESPeriod kp_) = + if praosSlotsPerKESPeriod == 0 + then error "kesPeriod: slots per KES period was set to zero" + else KESPeriod . fromIntegral $ s `div` praosSlotsPerKESPeriod + + currentIssueNo :: Maybe Word64 + currentIssueNo + | r@Just{} <- Map.lookup hk ocertCounters = + r + | Map.member (coerceKeyRole hk) stakeDistribution = + Just 0 + | otherwise = + Nothing + +{------------------------------------------------------------------------------- + CannotForge +-------------------------------------------------------------------------------} + +-- | Expresses that, whilst we believe ourselves to be a leader for this slot, +-- we are nonetheless unable to forge a block. +data PraosCannotForge c + = -- | The KES key in our operational certificate can't be used because the + -- current (wall clock) period is before the start period of the key. + -- current KES period. + -- + -- Note: the opposite case, i.e., the wall clock period being after the + -- end period of the key, is caught when trying to update the key in + -- 'updateForgeState'. + PraosCannotForgeKeyNotUsableYet + -- | Current KES period according to the wallclock slot, i.e., the KES + -- period in which we want to use the key. + !OCert.KESPeriod + -- | Start KES period of the KES key. + !OCert.KESPeriod + deriving Generic + +deriving instance Crypto c => Show (PraosCannotForge c) + +praosCheckCanForge :: + PraosParams -> + SlotNo -> + HotKey.KESInfo -> + Either (PraosCannotForge c) () +praosCheckCanForge + praosParams + curSlot + kesInfo + | let startPeriod = HotKey.kesStartPeriod kesInfo + , startPeriod > wallclockPeriod = + throwError $ PraosCannotForgeKeyNotUsableYet wallclockPeriod startPeriod + | otherwise = + return () + where + -- The current wallclock KES period + wallclockPeriod :: OCert.KESPeriod + wallclockPeriod = + OCert.KESPeriod $ + fromIntegral $ + unSlotNo curSlot `div` praosSlotsPerKESPeriod praosParams + +-- | 'getPraosNonces' for every Praos. +getPraosNoncesPolyPraos :: PolyPraosState proto -> PraosNonces +getPraosNoncesPolyPraos cdst = + PraosNonces + { candidateNonce = praosStateCandidateNonce + , epochNonce = praosStateEpochNonce + , evolvingNonce = praosStateEvolvingNonce + , labNonce = praosStateLabNonce + , previousLabNonce = praosStateLastEpochBlockNonce + } + where + PraosState + { praosStateCandidateNonce + , praosStateEpochNonce + , praosStateEvolvingNonce + , praosStateLabNonce + , praosStateLastEpochBlockNonce + } = cdst + +-- | 'getOpCertCounters' for every Praos. +getOpCertCountersPolyPraos :: + PolyPraosState proto -> Map (KeyHash SL.BlockIssuer) Word64 +getOpCertCountersPolyPraos cdst = + praosStateOCertCounters + where + PraosState + { praosStateOCertCounters + } = cdst + +{------------------------------------------------------------------------------- + Util +-------------------------------------------------------------------------------} + +-- | Check value and raise error if it is false. +(?!) :: Bool -> e -> Except e () +a ?! b = unless a $ throwError b + +infix 1 ?! + +(?!:) :: Either e1 a -> (e1 -> e2) -> Except e2 () +(Right _) ?!: _ = pure () +(Left e1) ?!: f = throwError $ f e1 + +infix 1 ?!: 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 e686ca4050..eefba69266 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 @@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} @@ -15,38 +14,33 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE ViewPatterns #-} --- | Praos, and the pieces every protocol built on Praos shares. --- --- Each such protocol is its own @proto@ type with its own instances, so that --- none of Praos's rules are reused by accident. The data types, however, are --- shared: they carry a @proto@ parameter, so that there is one definition of --- each Praos concept regardless of which extensions the protocol enables. The --- functions suffixed @PolyPraos@ are the method implementations every such --- protocol delegates to. --- --- @Poly@ means "many": a @PolyPraos@ type or function handles multiple --- extensions of/overlays on Praos, the ones used for Cardano. And the --- @PolyPraos@ functions are indeed /polymorphic/ in the @proto@ tyvar. +-- | Praos with no extensions. module Ouroboros.Consensus.Protocol.Praos - ( AnnouncedBy (..) + ( ConsensusConfig (..) + , LeiosOnly (..) + , Praos + , PraosCrypto + , PraosLedgerView + , PraosState + , PraosValidateView + , PraosValidationErr + + -- * Re-exports + + -- | These were defined in this module before + -- "Ouroboros.Consensus.Protocol.PolyPraos" existed. They are re-exported only + -- for that historical reason, so that the modules importing them here did not + -- need to change. + , AnnouncedBy (..) , PolyPraosCrypto , PolyPraosState (..) , PolyPraosValidationErr (..) - , ConsensusConfig (..) - , LeiosOnly (..) - , Praos , PraosCannotForge (..) - , PraosCrypto , PraosFields (..) , PraosIsLeader (..) - , PraosLedgerView , PraosParams (..) - , PraosState , PraosToSign (..) - , PraosValidateView - , PraosValidationErr , SerialisePraosState , Ticked (..) , checkIsLeaderPolyPraos @@ -61,120 +55,66 @@ module Ouroboros.Consensus.Protocol.Praos , validateKESSignature , validateVRFSignature - -- * For testing purposes + -- ** For testing purposes , doValidateKESSignature , doValidateVRFSignature ) where -import Cardano.Binary (FromCBOR (..), ToCBOR (..), enforceSize) -import qualified Cardano.Crypto.DSIGN as DSIGN -import qualified Cardano.Crypto.Hash as Hash -import qualified Cardano.Crypto.KES as KES -import qualified Cardano.Crypto.VRF as VRF -import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce, StrictMaybe (..), (â­’)) -import qualified Cardano.Ledger.BaseTypes as SL -import Cardano.Ledger.Block (EbReferencesAnnouncement (..)) import Cardano.Ledger.Chain (ChainChecksPParams (..)) import qualified Cardano.Ledger.Chain as SL -import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR) -import Cardano.Ledger.Hashes (HASH, extractHash, unsafeMakeSafeHash) -import Cardano.Ledger.Keys - ( DSIGN - , KeyHash - , VKey (VKey) - , coerceKeyRole - , hashKey - ) -import qualified Cardano.Ledger.Keys as SL -import Cardano.Ledger.Shelley (ShelleyEra) import qualified Cardano.Ledger.Shelley.API as SL -import Cardano.Ledger.Slot (Duration (Duration), (+*)) -import qualified Cardano.Ledger.State as SL -import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF) +import Cardano.Protocol.Crypto (Crypto, StandardCrypto) import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec -import Cardano.Protocol.Praos.VRF - ( InputVRF - , mkInputVRF - , vrfLeaderValue - , vrfNonceValue - ) import qualified Cardano.Protocol.TPraos.API as SL -import Cardano.Protocol.TPraos.BlockHeader - ( BoundedNatural (bvValue) - , checkLeaderNatValue - , prevHashToNonce - ) -import Cardano.Protocol.TPraos.OCert - ( KESPeriod (KESPeriod) - , OCert (OCert) - , OCertSignable - ) -import qualified Cardano.Protocol.TPraos.OCert as OCert import qualified Cardano.Protocol.TPraos.Rules.Prtcl as SL import qualified Cardano.Protocol.TPraos.Rules.Tickn as SL -import Cardano.Slotting.EpochInfo - ( EpochInfo - , epochInfoEpoch - , epochInfoFirst - , epochInfoSlotLength - , hoistEpochInfo - ) -import Cardano.Slotting.Slot - ( EpochNo (EpochNo) - , SlotNo (SlotNo) - , WithOrigin - , unSlotNo - ) -import qualified Codec.CBOR.Decoding as CBOR -import qualified Codec.CBOR.Encoding as CBOR -import Codec.Serialise (Serialise (decode, encode)) -import Control.Exception (throw) -import Control.Monad (unless, when) -import Control.Monad.Except (Except, runExcept, throwError) +import Cardano.Slotting.EpochInfo (EpochInfo) +import Control.Monad.Except (Except) import Data.Coerce (coerce) -import Data.Foldable (traverse_) -import Data.Functor.Identity (runIdentity) import Data.Kind (Type) -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Proxy (Proxy (Proxy)) -import Data.Typeable (Typeable) -import Data.Void (Void) -import Data.Word (Word32, Word64) import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks) -import Numeric.Natural (Natural) -import Ouroboros.Consensus.Block (WithOrigin (NotOrigin)) import qualified Ouroboros.Consensus.HardFork.History as History -import qualified Ouroboros.Consensus.Leios.Types as Leios import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) -import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey -import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) +import Ouroboros.Consensus.Protocol.PolyPraos import Ouroboros.Consensus.Protocol.Praos.Common import Ouroboros.Consensus.Protocol.Praos.Orphans () import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views -import Ouroboros.Consensus.Protocol.Signed (Signed) import Ouroboros.Consensus.Protocol.TPraos ( ConsensusConfig (TPraosConfig, tpraosEpochInfo, tpraosParams) , TPraos , TPraosState (tpraosStateChainDepState, tpraosStateLastSlot) ) -import Ouroboros.Consensus.Ticked (Ticked) -import Ouroboros.Consensus.Util.CBOR (decodeStrictMaybe, encodeStrictMaybe) -import Ouroboros.Consensus.Util.Versioned - ( VersionDecoder (Decode) - , decodeVersion - , encodeVersion - ) --- | Praos with no extensions. +{------------------------------------------------------------------------------- + The protocol +-------------------------------------------------------------------------------} + type Praos :: Type -> Type data Praos c type instance ShelleyProtocolHeader (Praos c) = PraosCodec.Header c +instance PolyPraosCrypto (Praos StandardCrypto) StandardCrypto + +class (Crypto c, PolyPraosCrypto (Praos c) c) => PraosCrypto c + +instance PraosCrypto StandardCrypto + +type PraosState c = PolyPraosState (Praos c) + +type PraosLedgerView c = Views.PolyPraosLedgerView (Praos c) + +type PraosValidateView c = Views.PolyPraosValidateView (Praos c) c + +type PraosValidationErr c = PolyPraosValidationErr (Praos c) c + +{------------------------------------------------------------------------------- + The fields only this protocol has +-------------------------------------------------------------------------------} + -- | Praos is not Leios, so it holds the left alternative. newtype instance LeiosOnly (Praos c) a b = PraosLacksLeios a deriving (Eq, Generic, Show) @@ -198,131 +138,10 @@ instance TypeSwitch (LeiosOnly (Praos c)) where typeSwitchL = PraosLacksLeios (PraosLacksLeios ()) typeSwitchR = PraosLacksLeios () --- | What a protocol needs of its crypto: the Praos essentials, plus signing --- whichever header body it is the protocol for. -class - ( Crypto c - , DSIGN.Signable DSIGN (OCertSignable c) - , VRF.Signable (VRF c) InputVRF - , KES.Signable (KES c) (Signed (ShelleyProtocolHeader proto)) - ) => - PolyPraosCrypto proto c - -instance PolyPraosCrypto (Praos StandardCrypto) StandardCrypto - -class (Crypto c, PolyPraosCrypto (Praos c) c) => PraosCrypto c - -instance PraosCrypto StandardCrypto - {------------------------------------------------------------------------------- - Fields required by Praos in the header + Configuration -------------------------------------------------------------------------------} -data PraosFields c toSign = PraosFields - { praosSignature :: KES.SignedKES (KES c) toSign - , praosToSign :: toSign - } - deriving Generic - -deriving instance - (NoThunks toSign, Crypto c) => - NoThunks (PraosFields c toSign) - -deriving instance - (Show toSign, Crypto c) => - Show (PraosFields c toSign) - --- | Fields arising from praos execution which must be included in --- the block signature. -data PraosToSign c = PraosToSign - { praosToSignIssuerVK :: SL.VKey SL.BlockIssuer - -- ^ Verification key for the issuer of this block. - , praosToSignVrfVK :: VRF.VerKeyVRF (VRF c) - , praosToSignVrfRes :: VRF.CertifiedVRF (VRF c) InputVRF - -- ^ Verifiable random value. This is used both to prove the issuer is - -- eligible to issue a block, and to contribute to the evolving nonce. - , praosToSignOCert :: OCert.OCert c - -- ^ Lightweight delegation certificate mapping the cold (DSIGN) key to - -- the online KES key. - } - deriving Generic - -instance Crypto c => NoThunks (PraosToSign c) - -deriving instance Crypto c => Show (PraosToSign c) - -forgePraosFields :: - ( Crypto c - , KES.Signable (KES c) toSign - , Monad m - ) => - HotKey c m -> - PraosCanBeLeader c -> - PraosIsLeader c -> - (PraosToSign c -> toSign) -> - m (PraosFields c toSign) -forgePraosFields - hotKey - PraosCanBeLeader - { praosCanBeLeaderColdVerKey - , praosCanBeLeaderSignKeyVRF - } - PraosIsLeader{praosIsLeaderVrfRes} - mkToSign = do - ocert <- HotKey.getOCert hotKey - let signedFields = - PraosToSign - { praosToSignIssuerVK = praosCanBeLeaderColdVerKey - , praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF - , praosToSignVrfRes = praosIsLeaderVrfRes - , praosToSignOCert = ocert - } - toSign = mkToSign signedFields - signature <- HotKey.sign hotKey toSign - return - PraosFields - { praosSignature = signature - , praosToSign = toSign - } - -{------------------------------------------------------------------------------- - Protocol proper --------------------------------------------------------------------------------} - --- | Praos parameters that are node independent -data PraosParams = PraosParams - { praosSlotsPerKESPeriod :: !Word64 - -- ^ See 'Globals.slotsPerKESPeriod'. - , praosLeaderF :: !SL.ActiveSlotCoeff - -- ^ Active slots coefficient. This parameter represents the proportion - -- of slots in which blocks should be issued. This can be interpreted as - -- the probability that a party holding all the stake will be elected as - -- leader for a given slot. - , praosSecurityParam :: !SecurityParam - -- ^ See 'Globals.securityParameter'. - , praosMaxKESEvo :: !Word64 - -- ^ Maximum number of KES iterations, see 'Globals.maxKESEvo'. - , praosMaxMajorPV :: !MaxMajorProtVer - -- ^ All blocks invalid after this protocol version, see - -- 'Globals.maxMajorPV'. - , praosRandomnessStabilisationWindow :: !Word64 - -- ^ The number of slots before the start of an epoch where the - -- corresponding epoch nonce is snapshotted. This has to be at least one - -- stability window such that the nonce is stable at the beginning of the - -- epoch. Ouroboros Genesis requires this to be even larger, see - -- 'SL.computeRandomnessStabilisationWindow'. - } - deriving (Generic, NoThunks) - --- | Assembled proof that the issuer has the right to issue a block in the --- selected slot. -newtype PraosIsLeader c = PraosIsLeader - { praosIsLeaderVrfRes :: VRF.CertifiedVRF (VRF c) InputVRF - } - deriving Generic - -instance Crypto c => NoThunks (PraosIsLeader c) - -- | Static configuration data instance ConsensusConfig (Praos c) = PraosConfig { praosParams :: !PraosParams @@ -342,230 +161,6 @@ instance HasMaxMajorProtVer (Praos c) where ConsensusProtocol -------------------------------------------------------------------------------} --- | Praos consensus state. --- --- We track the last slot and the counters for operational certificates, as well --- as a series of nonces which get updated in different ways over the course of --- an epoch. -data PolyPraosState proto = PraosState - { praosStateLastSlot :: !(WithOrigin SlotNo) - , praosStateOCertCounters :: !(Map (KeyHash SL.BlockIssuer) Word64) - -- ^ Operation Certificate counters - , praosStateEvolvingNonce :: !Nonce - -- ^ Evolving nonce - , praosStateCandidateNonce :: !Nonce - -- ^ Candidate nonce - , praosStateEpochNonce :: !Nonce - -- ^ Epoch nonce - , praosStatePreviousEpochNonce :: !Nonce - -- ^ Previous epoch nonce - , praosStateLabNonce :: !Nonce - -- ^ Nonce constructed from the hash of the previous block - , praosStateLastEpochBlockNonce :: !Nonce - -- ^ Nonce corresponding to the LAB nonce of the last block of the previous - -- epoch - , praosStateLeiosAnnouncement :: - !(LeiosOnly proto () (StrictMaybe AnnouncedBy)) - -- ^ The announcement carried by the most recently applied header, if any. - -- A header with no announcement clears it. - } - deriving Generic - -type PraosState c = PolyPraosState (Praos c) - -type PraosLedgerView c = Views.PolyPraosLedgerView (Praos c) - -type PraosValidateView c = Views.PolyPraosValidateView (Praos c) c - -deriving instance - Show (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Show (PolyPraosState proto) - -deriving instance - Eq (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Eq (PolyPraosState proto) - -instance - ( Typeable proto - , NoThunks (LeiosOnly proto () (StrictMaybe AnnouncedBy)) - ) => - NoThunks (PolyPraosState proto) - --- | An endorser block announcement, and the issuer of the header that carried --- it. --- --- With that header's slot ('praosStateLastSlot') the issuer identifies the --- election. -data AnnouncedBy = MkAnnouncedBy - { announcedByIssuer :: !(KeyHash SL.BlockIssuer) - , announcedEb :: !EbReferencesAnnouncement - } - deriving (Generic, Show, Eq, NoThunks) - -encodeAnnouncedBy :: AnnouncedBy -> CBOR.Encoding -encodeAnnouncedBy (MkAnnouncedBy issuer (EbReferencesAnnouncement h sz)) = - CBOR.encodeListLen 3 <> toCBOR issuer <> toCBOR (extractHash h) <> toCBOR sz - -decodeAnnouncedBy :: CBOR.Decoder s AnnouncedBy -decodeAnnouncedBy = do - enforceSize "AnnouncedBy" 3 - MkAnnouncedBy - <$> fromCBOR - <*> (EbReferencesAnnouncement . unsafeMakeSafeHash <$> fromCBOR <*> fromCBOR) - -instance SerialisePraosState proto => ToCBOR (PolyPraosState proto) where - toCBOR = encode - -instance SerialisePraosState proto => FromCBOR (PolyPraosState proto) where - fromCBOR = decode - --- | What encoding 'PolyPraosState' needs of its protocol. --- --- 'LeiosOnly' decides which fields are written, and which format version is --- written: 0 for 'Praos', 1 for 'Praos2'. The two protocols' versions are --- separate namespaces: the HFC's era index precedes them, so the codec is --- already chosen when the version is read. -type SerialisePraosState proto = - ( Typeable proto - , Applicative (LeiosOnly proto ()) - , Traversable (LeiosOnly proto ()) - ) - -instance SerialisePraosState proto => Serialise (PolyPraosState proto) where - encode - PraosState - { praosStateLastSlot - , praosStateOCertCounters - , praosStateEvolvingNonce - , praosStateCandidateNonce - , praosStateEpochNonce - , praosStatePreviousEpochNonce - , praosStateLabNonce - , praosStateLastEpochBlockNonce - , praosStateLeiosAnnouncement - } = - encodeVersion version $ - mconcat - [ CBOR.encodeListLen (8 + nLeiosFields) - , toCBOR praosStateLastSlot - , toCBOR praosStateOCertCounters - , toEraCBOR @ShelleyEra praosStateEvolvingNonce - , toEraCBOR @ShelleyEra praosStateCandidateNonce - , toEraCBOR @ShelleyEra praosStateEpochNonce - , toEraCBOR @ShelleyEra praosStatePreviousEpochNonce - , toEraCBOR @ShelleyEra praosStateLabNonce - , toEraCBOR @ShelleyEra praosStateLastEpochBlockNonce - , foldMap (encodeStrictMaybe encodeAnnouncedBy) praosStateLeiosAnnouncement - ] - where - nLeiosFields = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) - version = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) - - decode = - decodeVersion - [(version, Decode decodePraosState)] - where - version = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) - nLeiosFields = foldr (\() _ -> 1) 0 (pureLeiosOnly @proto ()) - - decodePraosState :: CBOR.Decoder s (PolyPraosState proto) - decodePraosState = do - enforceSize "PraosState" (8 + nLeiosFields) - PraosState - <$> fromCBOR - <*> fromCBOR - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> traverse - (\() -> decodeStrictMaybe decodeAnnouncedBy) - (pureLeiosOnly @proto ()) - -data instance Ticked (PolyPraosState proto) = TickedPraosState - { tickedPraosStateChainDepState :: PolyPraosState proto - , tickedPraosStateLedgerView :: Views.PolyPraosLedgerView proto - } - --- | Errors which we might encounter -data PolyPraosValidationErr proto c - = VRFKeyUnknown - !(KeyHash SL.StakePool) -- unknown VRF keyhash (not registered) - | VRFKeyWrongVRFKey - !(KeyHash SL.StakePool) -- KeyHash of block issuer - !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c))) -- VRF KeyHash registered with stake pool - !(Hash.Hash HASH (VRF.VerKeyVRF (VRF c))) -- VRF KeyHash from Header - | VRFKeyBadProof - !SlotNo -- Slot used for VRF calculation - !Nonce -- Epoch nonce used for VRF calculation - !(VRF.CertifiedVRF (VRF c) InputVRF) -- VRF calculated nonce value - | VRFLeaderValueTooBig Natural Rational ActiveSlotCoeff - | KESBeforeStartOCERT - !KESPeriod -- OCert Start KES Period - !KESPeriod -- Current KES Period - | KESAfterEndOCERT - !KESPeriod -- Current KES Period - !KESPeriod -- OCert Start KES Period - !Word64 -- Max KES Key Evolutions - | CounterTooSmallOCERT - !Word64 -- last KES counter used - !Word64 -- current KES counter - | -- | The KES counter has been incremented by more than 1 - CounterOverIncrementedOCERT - !Word64 -- last KES counter used - !Word64 -- current KES counter - | InvalidSignatureOCERT - !Word64 -- OCert counter - !KESPeriod -- OCert KES period - !String -- DSIGN error message - | InvalidKesSignatureOCERT - !Word -- current KES Period - !Word -- KES start period - !Word -- expected KES evolutions - !Word64 -- max KES evolutions - !String -- error message given by Consensus Layer - | NoCounterForKeyHashOCERT - !(KeyHash SL.BlockIssuer) -- stake pool key hash - | -- | The header sets its cert bit, but its predecessor announced no endorser - -- block, so there is nothing for the certificate to certify. - LeiosCertWithoutAnnouncement - !(LeiosOnly proto Void ()) - | -- | The header sets its cert bit too soon after its predecessor's - -- announcement: the announcement, voting and diffusion periods have not all - -- elapsed. - LeiosCertTooYoung - !(LeiosOnly proto Void ()) - !SlotNo -- Slot of the announcing block - !SlotNo -- Slot of this header - !SlotNo -- Earliest slot in which this header could have certified - | -- | The header announces an endorser block larger than the protocol - -- parameters allow. - LeiosEbTooBig - !(LeiosOnly proto Void ()) - !Word32 -- Announced size - !Word32 -- Maximum size - deriving Generic - -type PraosValidationErr c = PolyPraosValidationErr (Praos c) c - -deriving instance - (Crypto c, Eq (LeiosOnly proto Void ())) => - Eq (PolyPraosValidationErr proto c) - -deriving instance - (Typeable proto, Crypto c, NoThunks (LeiosOnly proto Void ())) => - NoThunks (PolyPraosValidationErr proto c) - -deriving instance - (Crypto c, Show (LeiosOnly proto Void ())) => - Show (PolyPraosValidationErr proto c) - -instance ChainDepStateSupportsPeras (PolyPraosState proto) where - getEpochNonce = praosStateEpochNonce - -instance ChainDepStateSupportsPeras (Ticked (PolyPraosState proto)) where - getEpochNonce = praosStateEpochNonce . tickedPraosStateChainDepState - instance PraosCrypto c => ConsensusProtocol (Praos c) where type ChainDepState (Praos c) = PolyPraosState (Praos c) type IsLeader (Praos c) = PraosIsLeader c @@ -585,486 +180,23 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where reupdateChainDepState (PraosConfig prms ei) = reupdateChainDepStatePolyPraos prms ei --- | 'checkIsLeader' for every Praos. -checkIsLeaderPolyPraos :: - forall proto c. - PolyPraosCrypto proto c => - PraosParams -> - PraosCanBeLeader c -> - SlotNo -> - Ticked (PolyPraosState proto) -> - Maybe (PraosIsLeader c) -checkIsLeaderPolyPraos - prms - PraosCanBeLeader - { praosCanBeLeaderSignKeyVRF - , praosCanBeLeaderColdVerKey - } - slot - cs = - if meetsLeaderThreshold (Proxy @c) prms lv (SL.coerceKeyRole vkhCold) rho - then - Just - PraosIsLeader - { praosIsLeaderVrfRes = coerce rho - } - else Nothing - where - chainState = tickedPraosStateChainDepState cs - lv = tickedPraosStateLedgerView cs - eta0 = praosStateEpochNonce chainState - vkhCold = SL.hashKey praosCanBeLeaderColdVerKey - rho' = mkInputVRF slot eta0 - - rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF - --- | 'tickChainDepState' for every Praos. --- --- Updating the chain dependent state for Praos. --- --- If we are not in a new epoch, then nothing happens. If we are in a new --- epoch, we do three things: --- - Store the existing current epoch nonce as the "previous epoch" nonce. --- This is needed to validate Peras certificates when they appear in blocks. --- - Update the epoch nonce to the combination of the candidate nonce and the --- nonce derived from the last block of the previous epoch. --- - Update the "last block of previous epoch" nonce to the nonce derived --- from the last applied block. -tickChainDepStatePolyPraos :: - EpochInfo (Except History.PastHorizonException) -> - Views.PolyPraosLedgerView proto -> - SlotNo -> - PolyPraosState proto -> - Ticked (PolyPraosState proto) -tickChainDepStatePolyPraos - praosEpochInfo - lv - slot - st = - TickedPraosState - { tickedPraosStateChainDepState = st' - , tickedPraosStateLedgerView = lv - } - where - newEpoch = - isNewEpoch - (History.toPureEpochInfo praosEpochInfo) - (praosStateLastSlot st) - slot - st' = - if newEpoch - then - st - { praosStateEpochNonce = - praosStateCandidateNonce st - â­’ praosStateLastEpochBlockNonce st - , praosStatePreviousEpochNonce = - praosStateEpochNonce st - , praosStateLastEpochBlockNonce = - praosStateLabNonce st - } - else st - --- | 'updateChainDepState' for every Praos. --- --- Validate and update the chain dependent state as a result of processing a --- new header. --- --- This consists of: --- - Validate the VRF checks --- - Validate the KES checks --- - Call 'reupdateChainDepState' -updateChainDepStatePolyPraos :: - ( PolyPraosCrypto proto c - , Applicative (LeiosOnly proto ()) - , Foldable (LeiosOnly proto ()) - , TypeSwitch (LeiosOnly proto) - ) => - PraosParams -> - EpochInfo (Except History.PastHorizonException) -> - Views.PolyPraosValidateView proto c -> - SlotNo -> - Ticked (PolyPraosState proto) -> - Except (PolyPraosValidationErr proto c) (PolyPraosState proto) -updateChainDepStatePolyPraos - prms@PraosParams{praosLeaderF} - ei - b - slot - tcs = do - -- The Leios header checks are cheap, so they run first. - leiosHeaderChecks ei lv b slot cs - -- First, we check the KES signature, which validates that the issuer is - -- in fact who they say they are. - validateKESSignature prms lv (praosStateOCertCounters cs) b - -- Then we examing the VRF proof, which confirms that they have the - -- right to issue in this slot. - validateVRFSignature (praosStateEpochNonce cs) lv praosLeaderF b - -- Finally, we apply the changes from this header to the chain state. - pure $ reupdateChainDepStatePolyPraos prms ei b slot tcs - where - lv = tickedPraosStateLedgerView tcs - cs = tickedPraosStateChainDepState tcs - --- | 'reupdateChainDepState' for every Praos. --- --- Re-update the chain dependent state as a result of processing a header. --- --- This consists of: --- - Update the last applied block hash. --- - Update the evolving and (potentially) candidate nonces based on the --- position in the epoch. --- - Update the operational certificate counter. --- - Record the header's announcement, if any, replacing the previous one. -reupdateChainDepStatePolyPraos :: - forall proto c. - Functor (LeiosOnly proto ()) => - PraosParams -> - EpochInfo (Except History.PastHorizonException) -> - Views.PolyPraosValidateView proto c -> - SlotNo -> - Ticked (PolyPraosState proto) -> - PolyPraosState proto -reupdateChainDepStatePolyPraos - PraosParams{praosRandomnessStabilisationWindow} - ei - b - slot - tcs = - cs - { praosStateLastSlot = NotOrigin slot - , praosStateLabNonce = prevHashToNonce (Views.hvPrevHash b) - , praosStateEvolvingNonce = newEvolvingNonce - , praosStateCandidateNonce = - if slot +* Duration praosRandomnessStabilisationWindow < firstSlotNextEpoch - then newEvolvingNonce - else praosStateCandidateNonce cs - , praosStateOCertCounters = - Map.insert hk n $ praosStateOCertCounters cs - , praosStateLeiosAnnouncement = - fmap - (\(_containsCert, mbAnn) -> MkAnnouncedBy hk <$> mbAnn) - (Views.hvLeios b) +instance Views.ForecastsLeios (Praos c) era where + forecastToPolyPraosLedgerView (f :: SL.Forecast t era) = + Views.PraosLedgerView + { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t + , Views.plvMaxHeaderSize = ccMaxBHSize cc + , Views.plvMaxBodySize = ccMaxBBSize cc + , Views.plvProtocolVersion = ccProtocolVersion cc + , Views.plvCommittee = PraosLacksLeios () + , Views.plvQuorumStakeThreshold = PraosLacksLeios () + , Views.plvAnnouncementPeriodLength = PraosLacksLeios () + , Views.plvVotePeriodLength = PraosLacksLeios () + , Views.plvDiffusionPeriodLength = PraosLacksLeios () + , Views.plvMaxEbBodySize = PraosLacksLeios () + , Views.plvMaxEbTxsSize = PraosLacksLeios () } where - epochInfoWithErr = - hoistEpochInfo - (either throw pure . runExcept) - ei - firstSlotNextEpoch = runIdentity $ do - EpochNo currentEpochNo <- epochInfoEpoch epochInfoWithErr slot - let nextEpoch = EpochNo $ currentEpochNo + 1 - epochInfoFirst epochInfoWithErr nextEpoch - cs = tickedPraosStateChainDepState tcs - eta = vrfNonceValue (Proxy @c) $ Views.hvVrfRes b - newEvolvingNonce = praosStateEvolvingNonce cs â­’ eta - OCert _ n _ _ = Views.hvOCert b - hk = hashKey $ Views.hvVK b - --- | The Leios header checks that read only the header and the ledger view. --- --- Sound out of context: the bound they check is forecast for the header's own --- slot, so any path that validates the header reads the same value. --- --- They run only for protocols with Leios, which are the ones that fill --- 'typeSwitchR'. -leiosContextFreeHeaderChecks :: - ( Applicative (LeiosOnly proto ()) - , Foldable (LeiosOnly proto ()) - , TypeSwitch (LeiosOnly proto) - ) => - Views.PolyPraosLedgerView proto -> - Views.PolyPraosValidateView proto c -> - Except (PolyPraosValidationErr proto c) () -leiosContextFreeHeaderChecks lv b = - traverse_ check $ - (,,) <$> typeSwitchR <*> Views.hvLeios b <*> Views.plvMaxEbBodySize lv - where - check (err, (_containsCert, mbAnn), maxEbBodySize) = - case mbAnn of - SNothing -> pure () - SJust ann -> do - let announced = ebReferencesAnnouncementSize ann - when (announced > maxEbBodySize) $ - throwError $ - LeiosEbTooBig err announced maxEbBodySize - --- | The Leios-specific checks on a header, called by 'updateChainDepState'. --- --- 'leiosContextFreeHeaderChecks' plus the one check that needs the header's --- immediate predecessor: a block may not certify an announcement younger than --- the certification gap, and only the predecessor's state says which --- announcement that is. -leiosHeaderChecks :: - ( Applicative (LeiosOnly proto ()) - , Foldable (LeiosOnly proto ()) - , TypeSwitch (LeiosOnly proto) - ) => - EpochInfo (Except History.PastHorizonException) -> - Views.PolyPraosLedgerView proto -> - Views.PolyPraosValidateView proto c -> - SlotNo -> - PolyPraosState proto -> - Except (PolyPraosValidationErr proto c) () -leiosHeaderChecks praosEpochInfo lv b slot cs = do - leiosContextFreeHeaderChecks lv b - traverse_ check $ - (,,,,,) - <$> typeSwitchR - <*> Views.hvLeios b - <*> Views.plvAnnouncementPeriodLength lv - <*> Views.plvVotePeriodLength lv - <*> Views.plvDiffusionPeriodLength lv - <*> praosStateLeiosAnnouncement cs - where - check - ( err - , (containsCert, _mbAnn) - , announcementPeriod - , votePeriod - , diffusionPeriod - , announcedByPredecessor - ) = - when containsCert $ - case (announcedByPredecessor, praosStateLastSlot cs) of - (SJust{}, NotOrigin announcingSlot) -> do - let earliestAllowed = - Leios.minCertificationSlot - ( runIdentity $ - epochInfoSlotLength - (History.toPureEpochInfo praosEpochInfo) - slot - ) - announcementPeriod - votePeriod - diffusionPeriod - announcingSlot - when (slot < earliestAllowed) $ - throwError $ - LeiosCertTooYoung err announcingSlot slot earliestAllowed - -- A state that announced an endorser block has necessarily applied a - -- header, so 'Origin' is the same situation as announcing nothing. - _ -> - throwError $ - LeiosCertWithoutAnnouncement err - --- | Check whether this node meets the leader threshold to issue a block. -meetsLeaderThreshold :: - forall proxy proto c. - proxy c -> - PraosParams -> - Views.PolyPraosLedgerView proto -> - SL.KeyHash SL.StakePool -> - VRF.CertifiedVRF (VRF c) InputVRF -> - Bool -meetsLeaderThreshold - _prx - praosParams - Views.PraosLedgerView{Views.plvPoolDistr} - keyHash - rho = - checkLeaderNatValue - (vrfLeaderValue (Proxy @c) rho) - r - (praosLeaderF praosParams) - where - SL.PoolDistr poolDistr _totalActiveStake = plvPoolDistr - r = - maybe 0 SL.individualPoolStake $ - Map.lookup keyHash poolDistr - -validateVRFSignature :: - forall proto c. - PolyPraosCrypto proto c => - Nonce -> - Views.PolyPraosLedgerView proto -> - ActiveSlotCoeff -> - Views.PolyPraosValidateView proto c -> - Except (PolyPraosValidationErr proto c) () -validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = - doValidateVRFSignature eta0 pd - --- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need --- to construct a 'PraosConfig' nor 'LedgerView' to test it. -doValidateVRFSignature :: - forall proto c. - PolyPraosCrypto proto c => - Nonce -> - Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> - ActiveSlotCoeff -> - Views.PolyPraosValidateView proto c -> - Except (PolyPraosValidationErr proto c) () -doValidateVRFSignature eta0 pd f b = do - case Map.lookup hk pd of - Nothing -> throwError $ VRFKeyUnknown hk - Just (SL.IndividualPoolStake{SL.individualPoolStake = sigma, SL.individualPoolStakeVrf = vrfHK}) -> do - let vrfHKStake = SL.fromVRFVerKeyHash vrfHK - vrfHKBlock = VRF.hashVerKeyVRF vrfK - vrfHKStake - == vrfHKBlock - ?! VRFKeyWrongVRFKey hk vrfHKStake vrfHKBlock - VRF.verifyCertified - () - vrfK - (mkInputVRF slot eta0) - vrfCert - ?! VRFKeyBadProof slot eta0 vrfCert - checkLeaderNatValue vrfLeaderVal sigma f - ?! VRFLeaderValueTooBig (bvValue vrfLeaderVal) sigma f - where - hk = coerceKeyRole . hashKey . Views.hvVK $ b - vrfK = Views.hvVrfVK b - vrfCert = Views.hvVrfRes b - vrfLeaderVal = vrfLeaderValue (Proxy @c) vrfCert - slot = Views.hvSlotNo b - -validateKESSignature :: - PolyPraosCrypto proto c => - PraosParams -> - Views.PolyPraosLedgerView proto -> - Map (KeyHash SL.BlockIssuer) Word64 -> - Views.PolyPraosValidateView proto c -> - Except (PolyPraosValidationErr proto c) () -validateKESSignature - PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} - Views.PraosLedgerView{Views.plvPoolDistr = SL.PoolDistr plvPoolDistr _totalActiveStake} - ocertCounters = - doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod plvPoolDistr ocertCounters - --- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to --- construct a 'PraosConfig' nor 'LedgerView' to test it. -doValidateKESSignature :: - PolyPraosCrypto proto c => - Word64 -> - Word64 -> - Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> - Map (KeyHash SL.BlockIssuer) Word64 -> - Views.PolyPraosValidateView proto c -> - Except (PolyPraosValidationErr proto c) () -doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod stakeDistribution ocertCounters b = - do - c0 <= kp ?! KESBeforeStartOCERT c0 kp - kp_ < c0_ + fromIntegral praosMaxKESEvo ?! KESAfterEndOCERT kp c0 praosMaxKESEvo - - let t = if kp_ >= c0_ then kp_ - c0_ else 0 - -- this is required to prevent an arithmetic underflow, in the case of kp_ < - -- c0_ we get the above `KESBeforeStartOCERT` failure in the transition. - - DSIGN.verifySignedDSIGN () vkcold (OCert.ocertToSignable oc) tau - ?!: InvalidSignatureOCERT n c0 - KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) - ?!: InvalidKesSignatureOCERT kp_ c0_ t praosMaxKESEvo - - case currentIssueNo of - Nothing -> do - throwError $ NoCounterForKeyHashOCERT hk - Just m -> do - m <= n ?! CounterTooSmallOCERT m n - n <= m + 1 ?! CounterOverIncrementedOCERT m n - where - oc@(OCert vk_hot n c0@(KESPeriod c0_) tau) = Views.hvOCert b - (VKey vkcold) = Views.hvVK b - SlotNo s = Views.hvSlotNo b - hk = hashKey $ Views.hvVK b - kp@(KESPeriod kp_) = - if praosSlotsPerKESPeriod == 0 - then error "kesPeriod: slots per KES period was set to zero" - else KESPeriod . fromIntegral $ s `div` praosSlotsPerKESPeriod - - currentIssueNo :: Maybe Word64 - currentIssueNo - | r@Just{} <- Map.lookup hk ocertCounters = - r - | Map.member (coerceKeyRole hk) stakeDistribution = - Just 0 - | otherwise = - Nothing - -{------------------------------------------------------------------------------- - CannotForge --------------------------------------------------------------------------------} - --- | Expresses that, whilst we believe ourselves to be a leader for this slot, --- we are nonetheless unable to forge a block. -data PraosCannotForge c - = -- | The KES key in our operational certificate can't be used because the - -- current (wall clock) period is before the start period of the key. - -- current KES period. - -- - -- Note: the opposite case, i.e., the wall clock period being after the - -- end period of the key, is caught when trying to update the key in - -- 'updateForgeState'. - PraosCannotForgeKeyNotUsableYet - -- | Current KES period according to the wallclock slot, i.e., the KES - -- period in which we want to use the key. - !OCert.KESPeriod - -- | Start KES period of the KES key. - !OCert.KESPeriod - deriving Generic - -deriving instance Crypto c => Show (PraosCannotForge c) - -praosCheckCanForge :: - PraosParams -> - SlotNo -> - HotKey.KESInfo -> - Either (PraosCannotForge c) () -praosCheckCanForge - praosParams - curSlot - kesInfo - | let startPeriod = HotKey.kesStartPeriod kesInfo - , startPeriod > wallclockPeriod = - throwError $ PraosCannotForgeKeyNotUsableYet wallclockPeriod startPeriod - | otherwise = - return () - where - -- The current wallclock KES period - wallclockPeriod :: OCert.KESPeriod - wallclockPeriod = - OCert.KESPeriod $ - fromIntegral $ - unSlotNo curSlot `div` praosSlotsPerKESPeriod praosParams - -{------------------------------------------------------------------------------- - PraosProtocolSupportsNode --------------------------------------------------------------------------------} - -instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where - type PraosProtocolSupportsNodeCrypto (Praos c) = c - - getPraosNonces _prx = getPraosNoncesPolyPraos - - getOpCertCounters _prx = getOpCertCountersPolyPraos - --- | 'getPraosNonces' for every Praos. -getPraosNoncesPolyPraos :: PolyPraosState proto -> PraosNonces -getPraosNoncesPolyPraos cdst = - PraosNonces - { candidateNonce = praosStateCandidateNonce - , epochNonce = praosStateEpochNonce - , evolvingNonce = praosStateEvolvingNonce - , labNonce = praosStateLabNonce - , previousLabNonce = praosStateLastEpochBlockNonce - } - where - PraosState - { praosStateCandidateNonce - , praosStateEpochNonce - , praosStateEvolvingNonce - , praosStateLabNonce - , praosStateLastEpochBlockNonce - } = cdst - --- | 'getOpCertCounters' for every Praos. -getOpCertCountersPolyPraos :: - PolyPraosState proto -> Map (KeyHash SL.BlockIssuer) Word64 -getOpCertCountersPolyPraos cdst = - praosStateOCertCounters - where - PraosState - { praosStateOCertCounters - } = cdst + cc = SL.forecastChainChecks @t @era f {------------------------------------------------------------------------------- Translation from transitional Praos @@ -1112,35 +244,12 @@ instance TranslateProto (TPraos c) (Praos c) where epochNonce = SL.ticknStateEpochNonce csTickn {------------------------------------------------------------------------------- - Util + PraosProtocolSupportsNode -------------------------------------------------------------------------------} --- | Check value and raise error if it is false. -(?!) :: Bool -> e -> Except e () -a ?! b = unless a $ throwError b - -infix 1 ?! - -(?!:) :: Either e1 a -> (e1 -> e2) -> Except e2 () -(Right _) ?!: _ = pure () -(Left e1) ?!: f = throwError $ f e1 +instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where + type PraosProtocolSupportsNodeCrypto (Praos c) = c -infix 1 ?!: + getPraosNonces _prx = getPraosNoncesPolyPraos -instance Views.ForecastsLeios (Praos c) era where - forecastToPolyPraosLedgerView (f :: SL.Forecast t era) = - Views.PraosLedgerView - { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t - , Views.plvMaxHeaderSize = ccMaxBHSize cc - , Views.plvMaxBodySize = ccMaxBBSize cc - , Views.plvProtocolVersion = ccProtocolVersion cc - , Views.plvCommittee = PraosLacksLeios () - , Views.plvQuorumStakeThreshold = PraosLacksLeios () - , Views.plvAnnouncementPeriodLength = PraosLacksLeios () - , Views.plvVotePeriodLength = PraosLacksLeios () - , Views.plvDiffusionPeriodLength = PraosLacksLeios () - , Views.plvMaxEbBodySize = PraosLacksLeios () - , Views.plvMaxEbTxsSize = PraosLacksLeios () - } - where - cc = SL.forecastChainChecks @t @era f + getOpCertCounters _prx = getOpCertCountersPolyPraos diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 9a5003669a..510824b541 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1175,6 +1175,7 @@ library protocol exposed-modules: Ouroboros.Consensus.Protocol.Ledger.HotKey Ouroboros.Consensus.Protocol.Ledger.Util + Ouroboros.Consensus.Protocol.PolyPraos Ouroboros.Consensus.Protocol.Praos Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common From 922fc87ce21e777894d2d61f16cdee4c530e85a4 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 01:57:11 -0400 Subject: [PATCH 04/19] S-R-P for cardano-ledger diff --- cabal.project | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/cabal.project b/cabal.project index e82b01c360..7f845edb7a 100644 --- a/cabal.project +++ b/cabal.project @@ -20,6 +20,42 @@ index-state: packages: . +-- DO NOT MERGE +-- +-- Points to cardano-ledger's nfrisby/leios-main-proto branch, which is a port +-- from the merge PR https://github.com/IntersectMBO/cardano-ledger/pull/6064 +-- onto the latest CHaP release. I'll get that port merged into master before +-- this ouroboros-consensus PR can merge into main. +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger + tag: dabb9284e3b3769b8e8c5d1588a6bba0067b9bc5 + --sha256: sha256-XyClY0qwNIXvSBfOXAnMN32qwoNFe0TUH3esCTJg1Gk= + subdir: + libs/cardano-data + libs/cardano-ledger-api + libs/small-steps + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-protocol + libs/cardano-protocol-tpraos + eras/byron/chain/executable-spec + eras/byron/ledger/executable-spec + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + eras/mary/impl + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/conway/impl + eras/dijkstra/impl + +-- TEMPORARY: CHaP's cardano-config bounds this ledger's Dijkstra out. +allow-newer: + , cardano-config:cardano-ledger-dijkstra + -- We want to always build the test-suites and benchmarks tests: True benchmarks: True From 13876cfb58bbe0d7ed125eabd88bc08779da3280 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:04:11 +0200 Subject: [PATCH 05/19] Don't fix the mkHeader call in Praos2 to DijkstraEra --- .../shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs | 1 + .../Ouroboros/Consensus/Shelley/Protocol/Abstract.hs | 5 ++++- .../shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs | 7 +++---- .../shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs | 2 +- 4 files changed, 9 insertions(+), 6 deletions(-) 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 2008ef8403..1bb96bb7c4 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 @@ -58,6 +58,7 @@ forgeShelleyBlock do hdr <- mkHeader @_ @(ProtoCrypto proto) + (Proxy @era) hotKey cbl fbIsLeader 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 6ebdbb3068..e67c094be9 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 @@ -28,6 +28,7 @@ import qualified Cardano.Crypto.Hash as Hash import Cardano.Crypto.VRF (OutputVRF) import Cardano.Ledger.BaseTypes (ProtVer, StrictMaybe) import Cardano.Ledger.Block (EbReferencesAnnouncement) +import Cardano.Ledger.Core (Era) import Cardano.Ledger.Hashes ( EraIndependentBlockBody , EraIndependentBlockHeader @@ -146,7 +147,9 @@ class ProtocolHeaderSupportsKES proto where Bool mkHeader :: - (Crypto crypto, Monad m, crypto ~ ProtoCrypto proto) => + (Crypto crypto, Monad m, crypto ~ ProtoCrypto proto, Era era) => + -- | The era of the block being forged + proxy era -> HotKey crypto m -> CanBeLeader proto -> IsLeader proto -> diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 7584f583c9..6444804531 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -12,7 +12,6 @@ import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), StrictMaybe) import Cardano.Ledger.Binary (getVersion32) import Cardano.Ledger.Block (BlockHeaderVersionInfo (..), EbReferencesAnnouncement) import Cardano.Ledger.Chain (ChainChecksPParams (..)) -import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Hashes (EraIndependentBlockBody, HASH) import Cardano.Ledger.Slot (SlotNo (unSlotNo)) import Cardano.Protocol.Crypto (Crypto, KES) @@ -31,7 +30,6 @@ import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Block (BlockNo) import Control.Monad.Except (Except) import Data.Either (isRight) -import Data.Proxy (Proxy (Proxy)) import Data.Word (Word32, Word64) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import Ouroboros.Consensus.Protocol.Praos @@ -109,7 +107,7 @@ instance PraosCrypto c => ProtocolHeaderSupportsKES (Praos c) where configSlotsPerKESPeriod cfg = praosSlotsPerKESPeriod $ praosParams cfg verifyHeaderIntegrity slotsPerKESPeriod = verifyHeaderIntegrityPolyPraos slotsPerKESPeriod . protocolHeaderView - mkHeader hk cbl il slotNo blockNo prevHash bbHash sz protVer (PraosLacksLeios ()) = + mkHeader _ hk cbl il slotNo blockNo prevHash bbHash sz protVer (PraosLacksLeios ()) = mkHeaderPolyPraos hk cbl il slotNo blockNo prevHash bbHash sz protVer id Header -- | 'verifyHeaderIntegrity' for every Praos. @@ -240,6 +238,7 @@ instance LeiosCrypto c => ProtocolHeaderSupportsKES (Praos2 c) where verifyHeaderIntegrity slotsPerKESPeriod = verifyHeaderIntegrityPolyPraos slotsPerKESPeriod . protocolHeaderView mkHeader + era hk cbl il @@ -261,7 +260,7 @@ instance LeiosCrypto c => ProtocolHeaderSupportsKES (Praos2 c) where sz protVer (\pb -> extendHeaderBodyWithLeios pb containsCert mbAnn) - (LeiosCodec.mkHeader (Proxy @DijkstraEra)) + (LeiosCodec.mkHeader era) -- | The Leios header body is the Praos one plus the Leios fields. -- diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs index f6d2db2c79..fcc6d2038b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs @@ -97,7 +97,7 @@ instance PraosCrypto c => ProtocolHeaderSupportsKES (TPraos c) where currentKesPeriod - startOfKesPeriod | otherwise = 0 - mkHeader hotKey canBeLeader isLeader curSlot curNo prevHash bbHash actualBodySize protVer (TPraosLacksLeios ()) = do + mkHeader _ hotKey canBeLeader isLeader curSlot curNo prevHash bbHash actualBodySize protVer (TPraosLacksLeios ()) = do TPraosFields{tpraosSignature, tpraosToSign} <- forgeTPraosFields hotKey canBeLeader isLeader mkBhBody pure $ SL.BHeader tpraosToSign tpraosSignature From c510f993372488e7d7fa3d4d90e22a7381d2ea40 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:17:33 +0200 Subject: [PATCH 06/19] Pull cardano-ledger SRP from `master` --- cabal.project | 66 +++++++++++++++++++-------------------- ouroboros-consensus.cabal | 14 ++++----- 2 files changed, 40 insertions(+), 40 deletions(-) diff --git a/cabal.project b/cabal.project index 7f845edb7a..125c34d8d1 100644 --- a/cabal.project +++ b/cabal.project @@ -20,17 +20,35 @@ index-state: packages: . --- DO NOT MERGE --- --- Points to cardano-ledger's nfrisby/leios-main-proto branch, which is a port --- from the merge PR https://github.com/IntersectMBO/cardano-ledger/pull/6064 --- onto the latest CHaP release. I'll get that port merged into master before --- this ouroboros-consensus PR can merge into main. +-- We want to always build the test-suites and benchmarks +tests: True +benchmarks: True + +multi-repl: True + +import: cabal/asserts.cabal +import: cabal/newer-ghcs.cabal + +package ouroboros-network + -- Certain ThreadNet tests rely on transactions to be submitted promptly after + -- a node (re)start. Therefore, we disable this flag (see + -- https://github.com/IntersectMBO/ouroboros-network/issues/4927 for context). + flags: -txsubmission-delay + +-- We need to disable bitvec's SIMD for now, as it breaks during cross compilation. +if os (windows) + constraints: + bitvec -simd + +constraints: + tasty <1.5.4, + +-- master after https://github.com/IntersectMBO/cardano-ledger/pull/6148 source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger - tag: dabb9284e3b3769b8e8c5d1588a6bba0067b9bc5 - --sha256: sha256-XyClY0qwNIXvSBfOXAnMN32qwoNFe0TUH3esCTJg1Gk= + --sha256: sha256-s/LVusbn3sE+yXYyOJpEg52PY+YVKqwmmEFdHM9ikD0= + tag: 0a72d43f5996c23eae1f6164d7d6a4dfeabe4c7f subdir: libs/cardano-data libs/cardano-ledger-api @@ -52,29 +70,11 @@ source-repository-package eras/conway/impl eras/dijkstra/impl --- TEMPORARY: CHaP's cardano-config bounds this ledger's Dijkstra out. allow-newer: - , cardano-config:cardano-ledger-dijkstra - --- We want to always build the test-suites and benchmarks -tests: True -benchmarks: True - -multi-repl: True - -import: cabal/asserts.cabal -import: cabal/newer-ghcs.cabal - -package ouroboros-network - -- Certain ThreadNet tests rely on transactions to be submitted promptly after - -- a node (re)start. Therefore, we disable this flag (see - -- https://github.com/IntersectMBO/ouroboros-network/issues/4927 for context). - flags: -txsubmission-delay - --- We need to disable bitvec's SIMD for now, as it breaks during cross compilation. -if os (windows) - constraints: - bitvec -simd - -constraints: - tasty <1.5.4, + , cardano-keys:cardano-ledger-core + , cardano-keys:cardano-ledger-shelley + , cardano-keys:cardano-protocol + , cardano-config:cardano-ledger-conway + , cardano-config:cardano-ledger-core + , cardano-config:cardano-ledger-dijkstra + , cardano-config:cardano-ledger-shelley \ No newline at end of file diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 510824b541..4ee868dc94 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -389,7 +389,7 @@ library cardano-crypto-class ^>=2.6, cardano-diffusion:api, cardano-ledger-binary ^>=1.10, - cardano-ledger-core ^>=1.22, + cardano-ledger-core ^>=1.23, cardano-prelude, cardano-slotting, cardano-strict-containers, @@ -1191,8 +1191,8 @@ library protocol cardano-ledger-binary, cardano-ledger-core, cardano-ledger-dijkstra ^>=0.5, - cardano-ledger-shelley ^>=1.20, - cardano-protocol ^>=0.2, + cardano-ledger-shelley ^>=1.21, + cardano-protocol ^>=0.3, cardano-protocol-tpraos ^>=1.6, cardano-slotting, cborg, @@ -1605,17 +1605,17 @@ library cardano cardano-crypto-wrapper, cardano-ledger-allegra ^>=1.10, cardano-ledger-alonzo ^>=1.17, - cardano-ledger-api ^>=1.15, + cardano-ledger-api ^>=1.16, cardano-ledger-babbage ^>=1.15, cardano-ledger-binary, cardano-ledger-byron ^>=1.3, - cardano-ledger-conway ^>=1.24, + cardano-ledger-conway ^>=1.25, cardano-ledger-core, cardano-ledger-dijkstra ^>=0.5, - cardano-ledger-mary ^>=1.11, + cardano-ledger-mary ^>=1.12, cardano-ledger-shelley, cardano-prelude, - cardano-protocol ^>=0.2, + cardano-protocol ^>=0.3, cardano-protocol-tpraos, cardano-slotting, cardano-strict-containers, From eb2b792054acde88c799bbe4e96654eb3d368b17 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:42:49 +0200 Subject: [PATCH 07/19] Remove seedInitialStakeSnapshots --- .../Ouroboros/Consensus/Cardano/Node.hs | 92 +------------------ 1 file changed, 4 insertions(+), 88 deletions(-) diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index 10a2bdee7d..e5124b7c67 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -44,21 +44,9 @@ import Cardano.Chain.Slotting (EpochSlots) import qualified Cardano.Ledger.Api.Era as L import qualified Cardano.Ledger.Api.Transition as L import qualified Cardano.Ledger.BaseTypes as SL -import Cardano.Ledger.Dijkstra.Rules (maxKeyAgeEpochs) import qualified Cardano.Ledger.Shelley.API as SL -import Cardano.Ledger.Shelley.LedgerState (NewEpochState, esSnapshotsL, nesEsL) -import Cardano.Ledger.State - ( SnapShots - , mkGoSnapShot - , mkSetSnapShot - , ssStakeGoL - , ssStakeMarkL - , ssStakeSetL - ) import Cardano.Prelude (cborError) import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) -import Cardano.Slotting.EpochInfo (fixedEpochInfo) -import Cardano.Slotting.Time (mkSlotLength) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR @@ -75,7 +63,7 @@ import Data.SOP.OptNP (NonEmptyOptNP, OptNP (OptSkip)) import qualified Data.SOP.OptNP as OptNP import Data.SOP.Strict import Data.Word (Word16, Word64) -import Lens.Micro ((%~), (&), (.~), (^.)) +import Lens.Micro ((^.)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Byron.ByronHFC import Ouroboros.Consensus.Byron.Ledger (ByronBlock) @@ -376,41 +364,6 @@ toTriggerHardFork = \case CardanoTriggerHardForkAtEpoch epochNo -> TriggerHardForkAtEpoch epochNo --- | Warm the initial stake snapshots for early-bootstrap (test) networks, so the --- stake distribution -- and hence anything reading it at genesis, e.g. the Leios --- committee via @nesPd@ -- is active from the first epochs instead of only after --- the ~2-epoch snapshot pipeline has run. @ssStakeMark@ is already seeded from --- genesis staking by the ledger's 'L.injectIntoTestState'; here we backfill --- set\/go by how early the era boots. Only fires for --- 'CardanoTriggerHardForkAtEpoch' (test-only; real networks use --- 'CardanoTriggerHardForkAtDefaultVersion' and are left untouched): --- --- * hard fork at epoch 0 -> go = set = mark --- * hard fork at epoch 1 -> set = mark --- * hard fork at epoch >=2 -> unchanged --- --- The snapshots are rotated with the ledger's own 'mkSetSnapShot' and --- 'mkGoSnapShot', as the SNAP rule does at an epoch boundary. Rotating the mark --- into the set position is what seats the Leios committee, which only keeps a --- pool's voting key while it is younger than the given maximum key age, so this --- must be the maximum key age the ledger would use (see --- 'initialLeiosMaxKeyAge'). Before Dijkstra the committee size is zero, so the --- committee is empty whatever the maximum key age. -seedInitialStakeSnapshots :: - SL.EpochInterval -> - TriggerHardFork -> - NewEpochState era -> - NewEpochState era -seedInitialStakeSnapshots maxKeyAge trigger nes = case trigger of - TriggerHardForkAtEpoch (EpochNo 0) -> nes & snapshotsL %~ seedGo . seedSet - TriggerHardForkAtEpoch (EpochNo 1) -> nes & snapshotsL %~ seedSet - _ -> nes - where - snapshotsL = nesEsL . esSnapshotsL - seedSet, seedGo :: SnapShots era -> SnapShots era - seedSet ss = ss & ssStakeSetL .~ mkSetSnapShot (ss ^. ssStakeMarkL) maxKeyAge - seedGo ss = ss & ssStakeGoL .~ mkGoSnapShot (ss ^. ssStakeSetL) - newtype CardanoHardForkTriggers = CardanoHardForkTriggers { getCardanoHardForkTriggers :: NP CardanoHardForkTrigger (CardanoShelleyEras StandardCrypto) @@ -551,21 +504,6 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano genesisShelley = cardanoLedgerTransitionConfig ^. L.tcShelleyGenesisL - -- The maximum age of a Leios voting key that the ledger's SNAP rule would - -- use when rotating the initial snapshots (see 'seedInitialStakeSnapshots'). - -- It only depends on the epoch length and the KES parameters, which the - -- Shelley genesis fixes for the early-bootstrap networks that seed their - -- snapshots, so the 'Globals' are built from the genesis alone. - initialLeiosMaxKeyAge :: SL.EpochInterval - initialLeiosMaxKeyAge = - maxKeyAgeEpochs - ( SL.mkShelleyGlobals genesisShelley $ - fixedEpochInfo - (SL.sgEpochLength genesisShelley) - (mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesisShelley) - ) - (EpochNo 0) - ProtocolParamsByron { byronGenesis = genesisByron , byronLeaderCredentials = mCredsByron @@ -907,34 +845,15 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano (CardanoEras c) perEraInjections = fn (Comp . pure) - :* hczipWith - (Proxy @IsShelleyBlock) - (\(K trigger) -> shelleyInjection trigger) - perEraTriggers - shelleyTcfgs - - -- Crypto-erased triggers per Shelley-based era, so 'shelleyInjection' can - -- warm the initial stake snapshots on an early ('AtEpoch') bootstrap. A K-NP - -- avoids the @c ~ StandardCrypto@ mismatch of the raw 'CardanoHardForkTriggers'. - perEraTriggers :: NP (K TriggerHardFork) (CardanoShelleyEras c) - perEraTriggers = - K (toTriggerHardFork triggerHardForkShelley) - :* K (toTriggerHardFork triggerHardForkAllegra) - :* K (toTriggerHardFork triggerHardForkMary) - :* K (toTriggerHardFork triggerHardForkAlonzo) - :* K (toTriggerHardFork triggerHardForkBabbage) - :* K (toTriggerHardFork triggerHardForkConway) - :* K (toTriggerHardFork triggerHardForkDijkstra) - :* Nil + :* hcmap (Proxy @IsShelleyBlock) shelleyInjection shelleyTcfgs shelleyInjection :: forall proto era. Shelley.ShelleyCompatible proto era => - TriggerHardFork -> WrapTransitionConfig (ShelleyBlock proto era) -> (Flip LedgerState ValuesMK -.-> (m :.: Flip LedgerState ValuesMK)) (ShelleyBlock proto era) - shelleyInjection trigger (WrapTransitionConfig tcfg) = fn $ \(Flip stIn) -> Comp $ do + shelleyInjection (WrapTransitionConfig tcfg) = fn $ \(Flip stIn) -> Comp $ do let stowed = stowLedgerTables stIn newNES <- L.injectIntoTestState @@ -942,10 +861,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano tcfg (Shelley.shelleyLedgerState stowed) pure . Flip . unstowLedgerTables $ - stowed - { Shelley.shelleyLedgerState = - seedInitialStakeSnapshots initialLeiosMaxKeyAge trigger newNES - } + stowed{Shelley.shelleyLedgerState = newNES} shelleyTcfgs :: NP WrapTransitionConfig (CardanoShelleyEras c) shelleyTcfgs = From d6ac79f17ddcef6c94af1b6d6a8800071bdc71f7 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:43:04 +0200 Subject: [PATCH 08/19] Use nesStakePoolDistrG instead of the deleted nesPd --- .../src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 05c8492d29..89a8c5979d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -86,7 +86,6 @@ import Cardano.Ledger.Core import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Governance as SL -import Cardano.Ledger.Shelley.LedgerState (NewEpochState (..)) import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.State as SL import Cardano.Slotting.EpochInfo @@ -876,8 +875,8 @@ instance CanUpgradeLedgerTables LedgerState (ShelleyBlock proto era) where instance LedgerStateSupportsPeras (LedgerState (ShelleyBlock proto era)) where getPoolDistr = - nesPd . shelleyLedgerState + view SL.nesStakePoolDistrG . shelleyLedgerState instance LedgerStateSupportsPeras (Ticked LedgerState (ShelleyBlock proto era)) where getPoolDistr = - nesPd . tickedShelleyLedgerState + view SL.nesStakePoolDistrG . tickedShelleyLedgerState From 56a57cbaaa23b87857f901cc9ebf9c83ce2804fc Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:44:37 +0200 Subject: [PATCH 09/19] Use `mkHeaderBody` insted of the now non-bidirectional `HeaderBody` --- .../Consensus/Shelley/Protocol/Praos.hs | 36 ++++++++-------- .../Test/Consensus/Shelley/Examples.hs | 41 ++++++++++--------- 2 files changed, 41 insertions(+), 36 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 6444804531..1765cf078a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -12,6 +12,7 @@ import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), StrictMaybe) import Cardano.Ledger.Binary (getVersion32) import Cardano.Ledger.Block (BlockHeaderVersionInfo (..), EbReferencesAnnouncement) import Cardano.Ledger.Chain (ChainChecksPParams (..)) +import Cardano.Ledger.Core (Era) import Cardano.Ledger.Hashes (EraIndependentBlockBody, HASH) import Cardano.Ledger.Slot (SlotNo (unSlotNo)) import Cardano.Protocol.Crypto (Crypto, KES) @@ -259,7 +260,7 @@ instance LeiosCrypto c => ProtocolHeaderSupportsKES (Praos2 c) where bbHash sz protVer - (\pb -> extendHeaderBodyWithLeios pb containsCert mbAnn) + (\pb -> extendHeaderBodyWithLeios era pb containsCert mbAnn) (LeiosCodec.mkHeader era) -- | The Leios header body is the Praos one plus the Leios fields. @@ -267,26 +268,29 @@ instance LeiosCrypto c => ProtocolHeaderSupportsKES (Praos2 c) where -- The version info has the protocol version's wire format: the highest -- supported major version, and the self-reported software tag. extendHeaderBodyWithLeios :: + (Crypto c, Era era) => + proxy era -> HeaderBody c -> -- | Whether the block body carries a Leios certificate Bool -> StrictMaybe EbReferencesAnnouncement -> LeiosCodec.HeaderBody c -extendHeaderBodyWithLeios pb containsCert ann = - LeiosCodec.HeaderBody - { LeiosCodec.hbBlockNo = hbBlockNo pb - , LeiosCodec.hbSlotNo = hbSlotNo pb - , LeiosCodec.hbPrev = hbPrev pb - , LeiosCodec.hbVk = hbVk pb - , LeiosCodec.hbVrfVk = hbVrfVk pb - , LeiosCodec.hbVrfRes = hbVrfRes pb - , LeiosCodec.hbBodySize = hbBodySize pb - , LeiosCodec.hbBodyHash = hbBodyHash pb - , LeiosCodec.hbOCert = hbOCert pb - , LeiosCodec.hbVersionInfo = BlockHeaderVersionInfo (getVersion32 major) minor - , LeiosCodec.hbBlockBodyContainsLeiosCert = containsCert - , LeiosCodec.hbEbReferencesAnnouncement = ann - } +extendHeaderBodyWithLeios proxy pb containsCert ann = + LeiosCodec.mkHeaderBody proxy $ + LeiosCodec.HeaderBodyRaw + { LeiosCodec.hbrBlockNo = hbBlockNo pb + , LeiosCodec.hbrSlotNo = hbSlotNo pb + , LeiosCodec.hbrPrev = hbPrev pb + , LeiosCodec.hbrVk = hbVk pb + , LeiosCodec.hbrVrfVk = hbVrfVk pb + , LeiosCodec.hbrVrfRes = hbVrfRes pb + , LeiosCodec.hbrBodySize = hbBodySize pb + , LeiosCodec.hbrBodyHash = hbBodyHash pb + , LeiosCodec.hbrOCert = hbOCert pb + , LeiosCodec.hbrVersionInfo = BlockHeaderVersionInfo (getVersion32 major) minor + , LeiosCodec.hbrBlockBodyContainsLeiosCert = containsCert + , LeiosCodec.hbrEbReferencesAnnouncement = ann + } where ProtVer major minor = hbProtVer pb 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 525de25b79..ca4a7c9b5b 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 @@ -414,26 +414,27 @@ translateLeiosHeader (SL.BHeader bhBody bhSig) = pb = praosHeaderBodyFromTPraos bhBody SL.ProtVer major minor = Praos.hbProtVer pb hBody = - Leios.HeaderBody - { Leios.hbBlockNo = Praos.hbBlockNo pb - , Leios.hbSlotNo = Praos.hbSlotNo pb - , Leios.hbPrev = Praos.hbPrev pb - , Leios.hbVk = Praos.hbVk pb - , Leios.hbVrfVk = Praos.hbVrfVk pb - , Leios.hbVrfRes = Praos.hbVrfRes pb - , Leios.hbBodySize = Praos.hbBodySize pb - , Leios.hbBodyHash = Praos.hbBodyHash pb - , Leios.hbOCert = Praos.hbOCert pb - , Leios.hbVersionInfo = SL.BlockHeaderVersionInfo (SL.getVersion32 major) minor - , Leios.hbBlockBodyContainsLeiosCert = True - , Leios.hbEbReferencesAnnouncement = - SL.SJust $ - SL.EbReferencesAnnouncement - { SL.ebReferencesAnnouncementHash = - unsafeMakeSafeHash $ Hash.castHash $ Praos.hbBodyHash pb - , SL.ebReferencesAnnouncementSize = 123 - } - } + Leios.mkHeaderBody (Proxy @DijkstraEra) $ + Leios.HeaderBodyRaw + { Leios.hbrBlockNo = Praos.hbBlockNo pb + , Leios.hbrSlotNo = Praos.hbSlotNo pb + , Leios.hbrPrev = Praos.hbPrev pb + , Leios.hbrVk = Praos.hbVk pb + , Leios.hbrVrfVk = Praos.hbVrfVk pb + , Leios.hbrVrfRes = Praos.hbVrfRes pb + , Leios.hbrBodySize = Praos.hbBodySize pb + , Leios.hbrBodyHash = Praos.hbBodyHash pb + , Leios.hbrOCert = Praos.hbOCert pb + , Leios.hbrVersionInfo = SL.BlockHeaderVersionInfo (SL.getVersion32 major) minor + , Leios.hbrBlockBodyContainsLeiosCert = True + , Leios.hbrEbReferencesAnnouncement = + SL.SJust $ + SL.EbReferencesAnnouncement + { SL.ebReferencesAnnouncementHash = + unsafeMakeSafeHash $ Hash.castHash $ Praos.hbBodyHash pb + , SL.ebReferencesAnnouncementSize = 123 + } + } examplesShelley :: Examples StandardShelleyBlock examplesShelley = fromShelleyLedgerExamples ledgerExamplesShelley From 354963558c9874b6dc8fc9c3ed8032bff4f98400 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:48:19 +0200 Subject: [PATCH 10/19] Regenerate golden files --- .../CardanoNodeToNodeVersion2/Header_Dijkstra | Bin 856 -> 894 bytes .../Result_Dijkstra_LedgerTip | Bin 37 -> 37 bytes .../cardano/disk/ChainDepState_Dijkstra | Bin 451 -> 452 bytes .../cardano/disk/ExtLedgerState_Allegra | Bin 814 -> 743 bytes .../golden/cardano/disk/ExtLedgerState_Alonzo | Bin 1044 -> 973 bytes .../cardano/disk/ExtLedgerState_Babbage | Bin 1094 -> 1023 bytes .../golden/cardano/disk/ExtLedgerState_Conway | Bin 1735 -> 1662 bytes .../cardano/disk/ExtLedgerState_Dijkstra | Bin 2045 -> 1973 bytes .../golden/cardano/disk/ExtLedgerState_Mary | Bin 932 -> 861 bytes .../cardano/disk/ExtLedgerState_Shelley | Bin 752 -> 681 bytes .../golden/cardano/disk/LedgerState_Allegra | Bin 519 -> 448 bytes .../golden/cardano/disk/LedgerState_Alonzo | Bin 683 -> 612 bytes .../golden/cardano/disk/LedgerState_Babbage | Bin 700 -> 629 bytes .../golden/cardano/disk/LedgerState_Conway | Bin 1308 -> 1235 bytes .../golden/cardano/disk/LedgerState_Dijkstra | Bin 1585 -> 1512 bytes .../golden/cardano/disk/LedgerState_Mary | Bin 604 -> 533 bytes .../golden/cardano/disk/LedgerState_Shelley | Bin 488 -> 417 bytes .../golden/shelley/disk/ExtLedgerState | Bin 676 -> 605 bytes .../golden/shelley/disk/LedgerState | Bin 450 -> 379 bytes 19 files changed, 0 insertions(+), 0 deletions(-) diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra index d87673ac96d9dc64539f44f3989bc0c7b21d3ae2..dd07762fb525310558461a79bd1bef0671319295 100644 GIT binary patch delta 33 pcmcb?_K%ITiT#E|By)LF&qmH3My9V#lQ|icm?Ww*GA4B#?8AK4>JM)Xyyo* diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion3/CardanoNodeToClientVersion19/Result_Dijkstra_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion3/CardanoNodeToClientVersion19/Result_Dijkstra_LedgerTip index 2171fa143432fbf3e6a9d875aa3eb7355f49a881..60e5b587ea798cc67977bac6f7d7b6f90722d5a1 100644 GIT binary patch literal 37 tcmZo{;*3zRILZC%r=O7H0fvc9V$mrnC4OHRHax3m_~qT2feoX#87pC>tzB8#M=dz|V{5%TlfK4aU)0y#$3mZk*@7$#3*)M5F?(9|%I(QR@7(>(y*U<{i8 delta 72 zcmV-O0Js0=1+E5=Zvls~a2^2!gMy%-lam1~0fLcnA1H%@0RaJ6AjRSuvB~xVErG+b eUNkn#e;xOKmQt=h6A;3VVjb9fOaZgM0Vo0fr5sHF diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo index f4c9d4d7d780b93cf53369d01953ca6273b0f722..fc643e115450f2db6f5957246c01915002279e94 100644 GIT binary patch delta 42 zcmV+_0M-AL2+aqOu?2MAuV6r)r4oeeMRHwO#k&!V%;pii&jVHe` r={6qT6lY>~x?c8s{j{KUcESRO`jTXCRQoV~V`yra$k;LYJ<~k^34bH> diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage index 85d8c1167511995ad92be109ca237a58f6721b2e..26032bf05c3378c3ebd7ad02b8b12fb9e0ee4ca2 100644 GIT binary patch delta 42 zcmV+_0M-A-2>%C=(glV9p;#P~p#dDR^H2c=go2=;0Fy@oECludf`E|$sgq~}-e=zs Ag8%>k delta 90 zcmey*evD(nCDwL^g%L877c$Ch{2ai@(%iIQ!DJ669hN4js7`YeBO_yk!qG=k8&7^? r(rrAvDbB>~biM5N`e{My?1Tjl^(D#PsPplj#NCM2!#- delta 80 zcmV-W0I&c4495+S^8tsk^r`~{gMy%-lcNML0fLeBA1;H~9)bY@0azf#;u^8Z_5v+| m!?Ip9Hp_n<_kWgBu09hG!j57c*n3O?_5gx_kpaq+patHiTqA`5 diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra index a9655dc95dd38124de6e29b3a27ea9c0b684a129..5397aba5ea7f37187858beb44d7b55b0bf9d17f7 100644 GIT binary patch delta 48 zcmey%zmsVM@nieczn7o};f3gAFdnU%t$%^dP*c+Of85<1rGHk$=;~;Vf@C>)G(3pH4{U}i_@% delta 82 zcmV-Y0ImPs2BZg&kO7CWkx~H!gMy%-ljs2~1cISh9Ft!G94v!^0RaJ6AjRSuvB~xV oErG+bUNkn#e;xOKmQt=h6A;3VVjb9fOab-)f`E|$XOn*d-ba8TR{#J2 diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley index 3847aa50984abb82804a8fb910e1d1c0d1064b1b..cce00d303fc3198ef47d6aa4b0e54c93d4f8c02d 100644 GIT binary patch delta 34 qcmeysx{`H50At(6KsiR%mZk*@7$z4p>aZ+eXlj_qs6JVU=^g;l;R}uc delta 74 zcmV-Q0JZM(s{0047~2&Vu5 delta 69 zcmV-L0J{Ic1BV2VZUKj}Zyo^zgMy%-lac`}0fLcmA1Z@_0RaJ6AjRSuvB~xVErG+b bUNkn#e;xOKmQt=h6A;3VVjb9fOab-)lVuxI diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo index b0b186a13d3d45d32462522cdd22def831502066..869f1133144a9397995ebe0d4366cab8c63de0ae 100644 GIT binary patch delta 25 hcmZ3@`h;b|2FA9H8ygr|TbdRuV3=&mq{H-$0RV?w348zm delta 73 zcmV-P0Ji_+1giy*umOj$v48;tgMy%-lQse@1cISh9FutPg%L877ck0f{1m{*(%iIQ!DM$P9hN4js8(|mBO_yk!qG=k8&7^? i(rrAvDbB>~biM5N`e{My?1Tjl^(D#PsPDeHx|s_S delta 98 zcmV-o0G`gMy%-lcEGKOoE|U9N?!EF_;p=_j9@g>|JX={MD-1 zPzHco1bYZ2L4(*Hf&l>mSRlpX8nMat0xf~VvR*Vc%YPmBf0k0NJ`)haj$$3ydrSfL E0D*cd1ONa4 diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra index 8fd88d55a0bfea9eb8925f9203e1492b3c7dea48..efe32bb0b96254ab1fe4eaa110970e1e11aa92f3 100644 GIT binary patch delta 32 ocmdnU^MZSWFe6hN!{leI@|#T<>sVM@nieczn7oZupXnO|0J9tl!~g&Q delta 74 zcmV-Q0JZ<<3$YBa69EB-vlIcI1O$VEprDht1up@DlNA9UEQ8n{f&l>mSRlpX8nMat g0xf~VvR*Vc%YPmBf0k0NJ`)haj$$3ydrSfL0Pi{+asU7T diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary index 5b05a7571fed6316cba22d175aff396bf70cfe48..0e99c242f4ac2992f7661b9ca5949caaa3540457 100644 GIT binary patch delta 25 hcmcb^GL>aQKV#d*2|M$)}004Ah2sHoz delta 69 zcmV-L0J{I71Ly;gPXULqP#ysUgMy%-lXC$q0fLcHA1Z@_0RaJ6AjRSuvB~xVErG+b bUNkn#e;xOKmQt=h6A;3VVjb9fOaY((h}#;% diff --git a/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState b/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState index 90dc8e099da1ba86c8063ac725f78301b8be572a..8c2c0535995c33f5456b6859e3e488de5672c181 100644 GIT binary patch delta 26 icmZ3&dY5H_7Gv8+Z8=8PmZk*@7$*BN>P$Y!_!t0qq6t?3 delta 71 zcmV-N0J#6%1f&I!DglSFD;@y^gMy%-lTHCF0fLb%A1H%@0RaJ6AjRSuvB~xVErG+b dUNkn#e;xOKmQt=h6A;3VVjb9fOaYU60pp%d8+ZT! diff --git a/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState b/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState index fc69f5815b12c0495fd2e7fb12cae2db29adbcf1..5d7fd800c08a283093eaadafd9779e4f2a3b13f4 100644 GIT binary patch delta 25 hcmX@a{F`ZlCS%)1EjdQkmZk*@7$*BL>M$)}0044t2lfB} delta 69 zcmV-L0J{JC0>T53DFKJEDjop@gMy%-lT86E0fLb$A1Z@_0RaJ6AjRSuvB~xVErG+b bUNkn#e;xOKmQt=h6A;3VVjb9fOaY((c0U?j From 3a1f4bc38aac1f3b5e9ec1bb6fc7b4d19b3e12ac Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:50:51 +0200 Subject: [PATCH 11/19] Dijkstra uses its header type in CDDL --- .../cddl/node-to-node/chainsync/header.cddl | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/ouroboros-consensus-cardano/cddl/node-to-node/chainsync/header.cddl b/ouroboros-consensus-cardano/cddl/node-to-node/chainsync/header.cddl index 0b3e1af882..ebc1789115 100644 --- a/ouroboros-consensus-cardano/cddl/node-to-node/chainsync/header.cddl +++ b/ouroboros-consensus-cardano/cddl/node-to-node/chainsync/header.cddl @@ -6,7 +6,7 @@ header serialisedShelleyHeader, serialisedShelleyHeader, serialisedShelleyHeader, - serialisedShelleyHeader> + serialisedShelleyHeader> byronHeader = [byronRegularIdx, #6.24(bytes .cbor byron.blockhead)] / [byronBoundaryIdx, #6.24(bytes .cbor byron.ebbhead)] @@ -16,8 +16,6 @@ byronRegularIdx = [1, base.word32] serialisedShelleyHeader = #6.24(bytes .cbor era) -dijkstraPraosHeader = conway.header - ;# include byron as byron ;# include shelley as shelley ;# include allegra as allegra From aae22bea3bbda0b9dd5e1940cb31ed91c33e50fe Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 13:57:14 +0200 Subject: [PATCH 12/19] Changelog fragment for Praos2 --- .../20261009_135300_javier.sagredo_praos2.md | 93 +++++++++++++++++++ .../Ouroboros/Consensus/Protocol/PolyPraos.hs | 2 +- 2 files changed, 94 insertions(+), 1 deletion(-) create mode 100644 changelog.d/20261009_135300_javier.sagredo_praos2.md diff --git a/changelog.d/20261009_135300_javier.sagredo_praos2.md b/changelog.d/20261009_135300_javier.sagredo_praos2.md new file mode 100644 index 0000000000..ff6a70ac3b --- /dev/null +++ b/changelog.d/20261009_135300_javier.sagredo_praos2.md @@ -0,0 +1,93 @@ + + +### Breaking + +- The Dijkstra era now runs a new protocol, `Praos2` (in the new module + `Ouroboros.Consensus.Protocol.Praos2`): Praos with the Leios overlay. Every + Dijkstra type in `ouroboros-consensus-cardano` (`StandardDijkstraBlock`, the + `CardanoShelleyEras` list, and the `Dijkstra` patterns of `CardanoBlock`, + `CardanoHeader`, `CardanoGenTx`, the configurations, and so on) changes from + `ShelleyBlock (Praos c) DijkstraEra` to `ShelleyBlock (Praos2 c) + DijkstraEra`. `CardanoHardForkConstraints` additionally requires the new + `LeiosCrypto c`. +- Dijkstra headers are now the Leios block header from `cardano-protocol`, + which adds whether the block body carries a Leios certificate and an optional + endorser block announcement. This changes the wire format of Dijkstra headers + and blocks, and the on-disk encoding of the Dijkstra `ChainDepState`, which + records the latest announcement. The `ChainDepState` encoding of the other + eras is unchanged. The `LeiosEraBlockHeader` instance that adapted the Praos header to + Dijkstra is removed, as is `ShelleyCompatible (Praos c) DijkstraEra`. +- `Praos2` validates the Leios fields of a header, failing with the new + `LeiosEbTooBig`, `LeiosCertWithoutAnnouncement` and `LeiosCertTooYoung` + validation errors. These constructors cannot be built for `Praos`. +- The Praos implementation moved to the new module + `Ouroboros.Consensus.Protocol.PolyPraos`, where its types are indexed by the + protocol so that `Praos` and `Praos2` share them: + - `PraosState` is replaced by `PolyPraosState proto`, which gains the + `praosStateLeiosAnnouncement` field. `PraosState c` is now a synonym for + `PolyPraosState (Praos c)`. + - `PraosValidationErr c` is replaced by `PolyPraosValidationErr proto c`, and + is now a synonym for `PolyPraosValidationErr (Praos c) c`. + - In `Ouroboros.Consensus.Protocol.Praos.Views`, `HeaderView crypto` becomes + `PolyPraosValidateView proto crypto`, which gains the `hvLeios` field and + signs `Signed (ShelleyProtocolHeader proto)` instead of the Praos + `HeaderBody`. `PraosLedgerView` becomes `PolyPraosLedgerView proto`, which + gains the Leios fields `plvCommittee`, `plvQuorumStakeThreshold`, + `plvAnnouncementPeriodLength`, `plvVotePeriodLength`, + `plvDiffusionPeriodLength`, `plvMaxEbBodySize` and `plvMaxEbTxsSize`. + `forecastToPraosLedgerView` is replaced by the method + `forecastToPolyPraosLedgerView` of the new class `ForecastsLeios`. + - `Ouroboros.Consensus.Protocol.Praos` re-exports what it used to define, and + adds the synonyms `PraosLedgerView c` and `PraosValidateView c`. + - `PraosCrypto c` is now defined through the new `PolyPraosCrypto proto c`. + - `praosCheckCanForge` takes the `PraosParams` instead of the whole + `ConsensusConfig (Praos c)`. +- New data family `LeiosOnly proto a b` in + `Ouroboros.Consensus.Protocol.Praos.Common`, which is `a` for the protocols + without Leios and `b` for those with it. It gates the Leios fields and error + constructors of the shared types. Its instances for `TPraos`, `Praos` and + `Praos2` have the constructors `TPraosLacksLeios`, `PraosLacksLeios` and + `Praos2HasLeios`. +- `ShelleyProtocolHeader` is now defined in + `Ouroboros.Consensus.Protocol.Praos.Common`. + `Ouroboros.Consensus.Shelley.Protocol.Abstract` still re-exports it. +- `ProtocolHeaderSupportsKES.mkHeader` takes a proxy for the era of the block + being forged, and the Leios fields of the header as a + `LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)`. + `forgeShelleyBlock` additionally requires `Applicative (LeiosOnly proto ())`. +- The `EncodeDisk` and `DecodeDisk` instances for the Praos chain-dependent + state are now for `PolyPraosState proto`, and require the new + `SerialisePraosState proto`. +- Integrated a new `cardano-ledger`: + - The on-disk encoding of the ledger state changes in every Shelley-based + era. + - `protocolInfoCardano` no longer seeds the initial stake snapshots itself + when hard-forking at epoch 0 or 1. The ledger's `injectIntoTestState` now + seeds them in every Shelley-based era, and seats the initial Leios committee + in Dijkstra. + - Dijkstra header bodies are built with the ledger's `mkHeaderBody`, which + memoizes their serialisation. The KES signature therefore covers the bytes + of the body as forged (encoded at the era's protocol version) or as + received, instead of a re-encoding at the version in the header's version + info. + - The node-to-node CDDL for Dijkstra headers refers to the ledger's + `dijkstra.header`, instead of aliasing the Conway header. + - `getPoolDistr` for Shelley ledger states reads the stake pool distribution + through the ledger's `nesStakePoolDistrG`, since `nesPd` was removed. + +### Non-Breaking + +- New `praos2SharedBlockForging` in `Ouroboros.Consensus.Shelley.Node.Praos`, + used to forge Dijkstra blocks. Forging does not yet certify or announce + endorser blocks. +- New `TranslateProto` instances from `Praos` and from `TPraos` to `Praos2`. +- New `minCertificationSlot` in `Ouroboros.Consensus.Leios.Types`: the earliest + slot at which a block may certify an endorser block announced in a given slot, + once the announcement, vote and diffusion periods have elapsed. +- New `TypeSwitch` class in `Ouroboros.Consensus.Protocol.Praos.Common`, used to + build the `LeiosOnly` values that only one kind of protocol can have. diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs index 956d896414..7c0cf989d0 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs @@ -34,7 +34,7 @@ -- extensible, since there is, unfortunately, no such thing as an extensible -- security proof. Our protocol changes are well studied before implemented, and -- have never happened concurrently. --- +-- -- In other words: it's a very important benefit that there is /one definition/ -- to look at in order to see everything all of the Praos extensions -- /cumulatively/ do. The type-level DSL used to isolate extension components is From 4e3637bd94fca0472810543ac6b60a5eb889235c Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 14:13:37 +0200 Subject: [PATCH 13/19] Style: put kind signature next to ForecastsLeios --- .../Ouroboros/Consensus/Protocol/Praos/Views.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) 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 af3fa0b1ba..1a932be490 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 @@ -100,13 +100,12 @@ deriving instance ) => Show (PolyPraosLedgerView proto) -type ForecastsLeios :: Type -> Type -> Constraint - -- | How a protocol reads an era's forecast. -- -- A method rather than one shared function because only the protocols with -- Leios may demand more of their era than 'SL.EraForecast', and knowing -- @proto@ alone cannot supply that @era@ dictionary. +type ForecastsLeios :: Type -> Type -> Constraint class ForecastsLeios proto era where forecastToPolyPraosLedgerView :: SL.EraForecast era => SL.Forecast t era -> PolyPraosLedgerView proto From 0b3ef715195315ed88afb73583d351f5fefb72a4 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 9 Oct 2026 16:28:11 +0200 Subject: [PATCH 14/19] HLint: redundant pragma --- .../src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 1765cf078a..57591eb68f 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} From aba3dabcb87452f12695c3464e9ec8c80fb5b2d6 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 10:56:34 -0400 Subject: [PATCH 15/19] LeiosOnly: add WhenLeios and VoidUnlessLeios type synonyms --- .../Consensus/Shelley/Ledger/Forge.hs | 4 +- .../Ouroboros/Consensus/Shelley/Node/Praos.hs | 6 +-- .../Consensus/Shelley/Protocol/Abstract.hs | 4 +- .../Ouroboros/Consensus/Protocol/PolyPraos.hs | 39 +++++++++---------- .../Ouroboros/Consensus/Protocol/Praos.hs | 2 + .../Consensus/Protocol/Praos/Common.hs | 17 ++++++-- .../Consensus/Protocol/Praos/Views.hs | 26 ++++++------- .../Protocol/Serialisation/Generators.hs | 4 +- 8 files changed, 57 insertions(+), 45 deletions(-) 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 1bb96bb7c4..60c96c0cdb 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 @@ -24,7 +24,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader) import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) -import Ouroboros.Consensus.Protocol.Praos.Common (LeiosOnly, pureLeiosOnly) +import Ouroboros.Consensus.Protocol.Praos.Common (WhenLeios, pureLeiosOnly) import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config ( shelleyProtocolVersion @@ -44,7 +44,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract forgeShelleyBlock :: forall m era proto. ( ShelleyCompatible proto era - , Applicative (LeiosOnly proto ()) + , Applicative (WhenLeios proto) , Monad m ) => HotKey (ProtoCrypto proto) m -> diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index b786d829a7..329b5ddcaf 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -27,8 +27,8 @@ import Ouroboros.Consensus.Protocol.Praos , PraosParams (..) , praosCheckCanForge ) -import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader) -import Ouroboros.Consensus.Protocol.Praos2 (ConsensusConfig (..), LeiosOnly, Praos2) +import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader, WhenLeios) +import Ouroboros.Consensus.Protocol.Praos2 (ConsensusConfig (..), Praos2) import Ouroboros.Consensus.Shelley.Ledger ( ShelleyBlock , ShelleyCompatible @@ -86,7 +86,7 @@ basePraosSharedBlockForging :: , ProtoCrypto proto ~ c , CanBeLeader proto ~ PraosCanBeLeader c , CannotForgeError proto ~ PraosCannotForge c - , Applicative (LeiosOnly proto ()) + , Applicative (WhenLeios proto) , IOLike m ) => -- | The Praos parameters within this protocol's configuration 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 e67c094be9..2e0bdf356e 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 @@ -61,8 +61,8 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import Ouroboros.Consensus.Protocol.Praos.Common ( HasMaxMajorProtVer - , LeiosOnly , ShelleyProtocolHeader + , WhenLeios ) import Ouroboros.Consensus.Protocol.Signed (SignedHeader) import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -167,7 +167,7 @@ class ProtocolHeaderSupportsKES proto where ProtVer -> -- | Optional fields for Leios: whether the body carries a certificate, and -- this header's announcement, if any - LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement) -> + WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement) -> m (ShelleyProtocolHeader proto) -- | ProtocolHeaderSupportsProtocol` provides support for the concrete diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs index 7c0cf989d0..2360d850a6 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs @@ -134,7 +134,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) import Data.Typeable (Typeable) -import Data.Void (Void) import Data.Word (Word32, Word64) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -304,21 +303,21 @@ data PolyPraosState proto = PraosState -- ^ Nonce corresponding to the LAB nonce of the last block of the previous -- epoch , praosStateLeiosAnnouncement :: - !(LeiosOnly proto () (StrictMaybe AnnouncedBy)) + !(WhenLeios proto (StrictMaybe AnnouncedBy)) -- ^ The announcement carried by the most recently applied header, if any. -- A header with no announcement clears it. } deriving Generic deriving instance - Show (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Show (PolyPraosState proto) + Show (WhenLeios proto (StrictMaybe AnnouncedBy)) => Show (PolyPraosState proto) deriving instance - Eq (LeiosOnly proto () (StrictMaybe AnnouncedBy)) => Eq (PolyPraosState proto) + Eq (WhenLeios proto (StrictMaybe AnnouncedBy)) => Eq (PolyPraosState proto) instance ( Typeable proto - , NoThunks (LeiosOnly proto () (StrictMaybe AnnouncedBy)) + , NoThunks (WhenLeios proto (StrictMaybe AnnouncedBy)) ) => NoThunks (PolyPraosState proto) @@ -358,8 +357,8 @@ instance SerialisePraosState proto => FromCBOR (PolyPraosState proto) where -- already chosen when the version is read. type SerialisePraosState proto = ( Typeable proto - , Applicative (LeiosOnly proto ()) - , Traversable (LeiosOnly proto ()) + , Applicative (WhenLeios proto) + , Traversable (WhenLeios proto) ) instance SerialisePraosState proto => Serialise (PolyPraosState proto) where @@ -462,33 +461,33 @@ data PolyPraosValidationErr proto c | -- | The header sets its cert bit, but its predecessor announced no endorser -- block, so there is nothing for the certificate to certify. LeiosCertWithoutAnnouncement - !(LeiosOnly proto Void ()) + !(VoidUnlessLeios proto ()) | -- | The header sets its cert bit too soon after its predecessor's -- announcement: the announcement, voting and diffusion periods have not all -- elapsed. LeiosCertTooYoung - !(LeiosOnly proto Void ()) + !(VoidUnlessLeios proto ()) !SlotNo -- Slot of the announcing block !SlotNo -- Slot of this header !SlotNo -- Earliest slot in which this header could have certified | -- | The header announces an endorser block larger than the protocol -- parameters allow. LeiosEbTooBig - !(LeiosOnly proto Void ()) + !(VoidUnlessLeios proto ()) !Word32 -- Announced size !Word32 -- Maximum size deriving Generic deriving instance - (Crypto c, Eq (LeiosOnly proto Void ())) => + (Crypto c, Eq (VoidUnlessLeios proto ())) => Eq (PolyPraosValidationErr proto c) deriving instance - (Typeable proto, Crypto c, NoThunks (LeiosOnly proto Void ())) => + (Typeable proto, Crypto c, NoThunks (VoidUnlessLeios proto ())) => NoThunks (PolyPraosValidationErr proto c) deriving instance - (Crypto c, Show (LeiosOnly proto Void ())) => + (Crypto c, Show (VoidUnlessLeios proto ())) => Show (PolyPraosValidationErr proto c) instance ChainDepStateSupportsPeras (PolyPraosState proto) where @@ -588,8 +587,8 @@ tickChainDepStatePolyPraos -- - Call 'reupdateChainDepState' updateChainDepStatePolyPraos :: ( PolyPraosCrypto proto c - , Applicative (LeiosOnly proto ()) - , Foldable (LeiosOnly proto ()) + , Applicative (WhenLeios proto) + , Foldable (WhenLeios proto) , TypeSwitch (LeiosOnly proto) ) => PraosParams -> @@ -630,7 +629,7 @@ updateChainDepStatePolyPraos -- - Record the header's announcement, if any, replacing the previous one. reupdateChainDepStatePolyPraos :: forall proto c. - Functor (LeiosOnly proto ()) => + Functor (WhenLeios proto) => PraosParams -> EpochInfo (Except History.PastHorizonException) -> Views.PolyPraosValidateView proto c -> @@ -681,8 +680,8 @@ reupdateChainDepStatePolyPraos -- They run only for protocols with Leios, which are the ones that fill -- 'typeSwitchR'. leiosContextFreeHeaderChecks :: - ( Applicative (LeiosOnly proto ()) - , Foldable (LeiosOnly proto ()) + ( Applicative (WhenLeios proto) + , Foldable (WhenLeios proto) , TypeSwitch (LeiosOnly proto) ) => Views.PolyPraosLedgerView proto -> @@ -708,8 +707,8 @@ leiosContextFreeHeaderChecks lv b = -- the certification gap, and only the predecessor's state says which -- announcement that is. leiosHeaderChecks :: - ( Applicative (LeiosOnly proto ()) - , Foldable (LeiosOnly proto ()) + ( Applicative (WhenLeios proto) + , Foldable (WhenLeios proto) , TypeSwitch (LeiosOnly proto) ) => EpochInfo (Except History.PastHorizonException) -> 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 eefba69266..24fe754713 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 @@ -19,6 +19,8 @@ module Ouroboros.Consensus.Protocol.Praos ( ConsensusConfig (..) , LeiosOnly (..) + , VoidUnlessLeios + , WhenLeios , Praos , PraosCrypto , PraosLedgerView 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 8031494965..444245f5d9 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 @@ -14,6 +14,8 @@ -- | Various things common to iterations of the Praos protocol. module Ouroboros.Consensus.Protocol.Praos.Common ( LeiosOnly + , VoidUnlessLeios + , WhenLeios , pureLeiosOnly , TypeSwitch (..) , ShelleyProtocolHeader @@ -378,18 +380,27 @@ type family ShelleyProtocolHeader proto = (sh :: Type) | sh -> proto -- One such family per extension, which is what keeps every type that mentions -- one indexed by @proto@ alone. Its two intended uses: -- --- * @LeiosOnly proto Void ()@ gates a constructor, since the protocols +-- * @VoidUnlessLeios proto ()@ gates a constructor, since the protocols -- without Leios cannot build it. -- --- * @LeiosOnly proto () a@ gates a field, which those protocols have but +-- * @WhenLeios proto a@ gates a field, which those protocols have but -- cannot put anything in. type LeiosOnly :: Type -> Type -> Type -> Type data family LeiosOnly proto a :: Type -> Type +-- | The field use of 'LeiosOnly': present only when the protocol has Leios. +type WhenLeios :: Type -> Type -> Type +type WhenLeios proto = LeiosOnly proto () + +-- | The constructor use of 'LeiosOnly': inhabited only when the protocol has +-- Leios. +type VoidUnlessLeios :: Type -> Type -> Type +type VoidUnlessLeios proto = LeiosOnly proto Void + -- | 'pure' for the field form of 'LeiosOnly', with @proto@ first so callers -- can fix it with a type application. pureLeiosOnly :: - forall proto b. Applicative (LeiosOnly proto ()) => b -> LeiosOnly proto () b + forall proto b. Applicative (WhenLeios proto) => b -> WhenLeios proto b pureLeiosOnly = pure -- | Allow for any type on the side of a type-level switch that wasn't chosen 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 1a932be490..422d10d78d 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 @@ -30,7 +30,7 @@ import Cardano.Protocol.TPraos.OCert (OCert) import Cardano.Slotting.Slot (SlotNo) import Data.Kind (Constraint, Type) import Data.Word (Word16, Word32) -import Ouroboros.Consensus.Protocol.Praos.Common (LeiosOnly, ShelleyProtocolHeader) +import Ouroboros.Consensus.Protocol.Praos.Common (ShelleyProtocolHeader, WhenLeios) import Ouroboros.Consensus.Protocol.Signed (Signed) {------------------------------------------------------------------------------- @@ -52,7 +52,7 @@ data PolyPraosValidateView proto crypto = HeaderView -- ^ operational certificate , hvSlotNo :: !SlotNo -- ^ Slot - , hvLeios :: !(LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)) + , hvLeios :: !(WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)) -- ^ Whether this block's body carries a Leios certificate, and the endorser -- block this header announces , hvSigned :: !(Signed (ShelleyProtocolHeader proto)) @@ -76,27 +76,27 @@ data PolyPraosLedgerView proto = PraosLedgerView -- ^ Maximum block body size , plvProtocolVersion :: !ProtVer -- ^ Current protocol version - , plvCommittee :: !(LeiosOnly proto () LeiosCommittee) + , plvCommittee :: !(WhenLeios proto LeiosCommittee) -- ^ Who may vote this epoch, and with what weight - , plvQuorumStakeThreshold :: !(LeiosOnly proto () UnitInterval) + , plvQuorumStakeThreshold :: !(WhenLeios proto UnitInterval) -- ^ Weight a certificate must accumulate - , plvAnnouncementPeriodLength :: !(LeiosOnly proto () Milliseconds32) - , plvVotePeriodLength :: !(LeiosOnly proto () Milliseconds32) - , plvDiffusionPeriodLength :: !(LeiosOnly proto () Milliseconds32) + , plvAnnouncementPeriodLength :: !(WhenLeios proto Milliseconds32) + , plvVotePeriodLength :: !(WhenLeios proto Milliseconds32) + , plvDiffusionPeriodLength :: !(WhenLeios proto Milliseconds32) -- ^ The three periods that determine how long after its announcement an -- endorser block may be certified. Kept as durations, since converting to a -- count of slots needs the slot length, which only the consensus config has. - , plvMaxEbBodySize :: !(LeiosOnly proto () Word32) + , plvMaxEbBodySize :: !(WhenLeios proto Word32) -- ^ Maximum size of an endorser block itself, not its closure - , plvMaxEbTxsSize :: !(LeiosOnly proto () Word32) + , plvMaxEbTxsSize :: !(WhenLeios proto Word32) -- ^ Maximum total size of the transactions an endorser block references } deriving instance - ( Show (LeiosOnly proto () LeiosCommittee) - , Show (LeiosOnly proto () UnitInterval) - , Show (LeiosOnly proto () Milliseconds32) - , Show (LeiosOnly proto () Word32) + ( Show (WhenLeios proto LeiosCommittee) + , Show (WhenLeios proto UnitInterval) + , Show (WhenLeios proto Milliseconds32) + , Show (WhenLeios proto Word32) ) => Show (PolyPraosLedgerView proto) diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index f147f73a23..eadf6151ad 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -80,8 +80,8 @@ instance Arbitrary AnnouncedBy where <*> (EbReferencesAnnouncement <$> arbitrary <*> arbitrary) instance - ( Applicative (Praos.LeiosOnly proto ()) - , Traversable (Praos.LeiosOnly proto ()) + ( Applicative (Praos.WhenLeios proto) + , Traversable (Praos.WhenLeios proto) ) => Arbitrary (PolyPraosState proto) where From ca727c68bea65277ecf0c573a24e6eb92c581cc7 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 11:06:43 -0400 Subject: [PATCH 16/19] Praos2: blockMatchesHeader and add Shelley Integrity test Co-authored-by: Sebastian Nagel --- .../CardanoNodeToNodeVersion2/Header_Dijkstra | Bin 894 -> 894 bytes .../Result_Dijkstra_LedgerTip | Bin 37 -> 37 bytes .../Ouroboros/Consensus/Shelley/Eras.hs | 24 +++++++ .../Consensus/Shelley/Ledger/Block.hs | 14 +++- .../Consensus/Shelley/Protocol/Abstract.hs | 9 +++ .../Consensus/Shelley/Protocol/Praos.hs | 3 + .../Consensus/Shelley/Protocol/TPraos.hs | 2 + .../Test/Consensus/Shelley/Examples.hs | 5 +- .../test/shelley-test/Main.hs | 2 + .../Test/Consensus/Shelley/Integrity.hs | 64 ++++++++++++++++++ ouroboros-consensus.cabal | 7 +- 11 files changed, 124 insertions(+), 6 deletions(-) create mode 100644 ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Integrity.hs diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra index dd07762fb525310558461a79bd1bef0671319295..d310b00dc52e90434a4d1faba8f17d90d3d672b0 100644 GIT binary patch delta 19 bcmeyz_K$7DR7R#RO_Mnpl{W8WJjw_FRQU(F delta 19 bcmeyz_K$7DR7R$+O_Mnpl{W8WJjw_FRRjmR diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion3/CardanoNodeToClientVersion19/Result_Dijkstra_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion3/CardanoNodeToClientVersion19/Result_Dijkstra_LedgerTip index 60e5b587ea798cc67977bac6f7d7b6f90722d5a1..4103dd943843bd2ad8f9461b014d598b32c53e0c 100644 GIT binary patch literal 37 vcmV+=0NVe7f(ck4lv%Xu5qDINLgF+mY2*pjru?RwgmC)@IGfWiaKENELf;YN literal 37 tcmZo{;*3zRILZC%r=O7H0fvc9V$mrnC4OHRHax3m PerasEnabled PerasRoundLength getShelleyEraPerasRoundLength _ = NoPerasEnabled + -- | Whether this block body carries a Leios certificate. + -- + -- Eras that don't support Leios define this as + -- 'defaultBlockBodyContainsLeiosCert'. + blockBodyContainsLeiosCert :: Core.BlockBody era -> Bool + data ConwayEraGovDict era where ConwayEraGovDict :: (CG.ConwayEraGov era, CG.ConwayEraCertState era) => ConwayEraGovDict era @@ -176,6 +183,9 @@ defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx = defaultGetConwayEraGovDict :: proxy era -> Maybe (ConwayEraGovDict era) defaultGetConwayEraGovDict _ = Nothing +defaultBlockBodyContainsLeiosCert :: Core.BlockBody era -> Bool +defaultBlockBodyContainsLeiosCert _ = False + instance ShelleyBasedEra ShelleyEra where applyShelleyBasedTx = defaultApplyShelleyBasedTx @@ -183,6 +193,8 @@ instance ShelleyBasedEra ShelleyEra where mkEraMkMempoolApplyTxError _prx = Nothing + blockBodyContainsLeiosCert = defaultBlockBodyContainsLeiosCert + instance ShelleyBasedEra AllegraEra where applyShelleyBasedTx = defaultApplyShelleyBasedTx @@ -190,6 +202,8 @@ instance ShelleyBasedEra AllegraEra where mkEraMkMempoolApplyTxError _prx = Nothing + blockBodyContainsLeiosCert = defaultBlockBodyContainsLeiosCert + instance ShelleyBasedEra MaryEra where applyShelleyBasedTx = defaultApplyShelleyBasedTx @@ -197,6 +211,8 @@ instance ShelleyBasedEra MaryEra where mkEraMkMempoolApplyTxError _prx = Nothing + blockBodyContainsLeiosCert = defaultBlockBodyContainsLeiosCert + instance ShelleyBasedEra AlonzoEra where applyShelleyBasedTx = applyAlonzoBasedTx @@ -204,6 +220,8 @@ instance ShelleyBasedEra AlonzoEra where mkEraMkMempoolApplyTxError _prx = Nothing + blockBodyContainsLeiosCert = defaultBlockBodyContainsLeiosCert + instance ShelleyBasedEra BabbageEra where applyShelleyBasedTx = applyAlonzoBasedTx @@ -211,6 +229,8 @@ instance ShelleyBasedEra BabbageEra where mkEraMkMempoolApplyTxError _prx = Nothing + blockBodyContainsLeiosCert = defaultBlockBodyContainsLeiosCert + instance ShelleyBasedEra ConwayEra where applyShelleyBasedTx = applyAlonzoBasedTx @@ -219,6 +239,8 @@ instance ShelleyBasedEra ConwayEra where mkEraMkMempoolApplyTxError _prx = Just $ \txt -> ConwayApplyTxError (NE.singleton (Conway.ConwayMempoolFailure txt)) + blockBodyContainsLeiosCert = defaultBlockBodyContainsLeiosCert + instance ShelleyBasedEra DijkstraEra where applyShelleyBasedTx = applyAlonzoBasedTx @@ -231,6 +253,8 @@ instance ShelleyBasedEra DijkstraEra where getShelleyEraPerasRoundLength _ = dijkstraPerasRoundLength + blockBodyContainsLeiosCert bb = isSJust (bb ^. leiosCertBlockBodyL) + applyAlonzoBasedTx :: forall era. ( AlonzoEraTx era 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 f75a5c9e71..742b7425a6 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 @@ -54,7 +54,11 @@ import Cardano.Ledger.Core as SL , eraProtVerLow , toEraCBOR ) -import qualified Cardano.Ledger.Core as SL (TranslationContext, hashBlockBody) +import qualified Cardano.Ledger.Core as SL + ( TranslationContext + , hashBlockBody + , txSeqBlockBodyL + ) import Cardano.Ledger.Hashes (HASH) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (Crypto) @@ -63,6 +67,7 @@ import qualified Data.ByteString.Lazy as Lazy import Data.Coerce (coerce) import Data.Typeable (Typeable) import GHC.Generics (Generic) +import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HardFork.Combinator @@ -89,6 +94,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , ShelleyProtocolHeader , pHeaderBlock , pHeaderBodyHash + , pHeaderContainsLeiosCert , pHeaderHash , pHeaderSlot ) @@ -219,9 +225,15 @@ instance ShelleyCompatible proto era => GetHeader (ShelleyBlock proto era) where -- Compute the hash the body of the block (the transactions) and compare -- that against the hash of the body stored in the header. SL.hashBlockBody blockBody == pHeaderBodyHash shelleyHdr + -- The body hash does not cover this claim, so it is checked separately. + && bodyContainsCert == pHeaderContainsLeiosCert shelleyHdr + -- A CertRB carries a certificate instead of transactions, never both. + && not (bodyContainsCert && bodyContainsTxs) where ShelleyHeader{shelleyHeaderRaw = shelleyHdr} = hdr ShelleyBlock{shelleyBlockRaw = SL.Block _ blockBody} = blk + bodyContainsCert = blockBodyContainsLeiosCert blockBody + bodyContainsTxs = not (null (blockBody ^. SL.txSeqBlockBodyL)) headerIsEBB = const Nothing 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 2e0bdf356e..6ee1356078 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 @@ -21,6 +21,7 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract , ShelleyHash (..) , ShelleyProtocol , ShelleyProtocolHeader + , defaultHeaderContainsLeiosCert ) where import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR)) @@ -117,6 +118,11 @@ class pHeaderSize :: ShelleyProtocolHeader proto -> Natural pHeaderBlockSize :: ShelleyProtocolHeader proto -> Natural + -- | Whether the header says its block body carries a Leios certificate. + -- Protocols that don't support Leios define this as + -- 'defaultHeaderContainsLeiosCert'. + pHeaderContainsLeiosCert :: ShelleyProtocolHeader proto -> Bool + type EnvelopeCheckError proto :: Type -- | Carry out any protocol-specific envelope checks. For example, this might @@ -127,6 +133,9 @@ class ShelleyProtocolHeader proto -> Except (EnvelopeCheckError proto) () +defaultHeaderContainsLeiosCert :: ShelleyProtocolHeader proto -> Bool +defaultHeaderContainsLeiosCert = const False + -- | `ProtocolHeaderSupportsKES` describes functionality common to protocols -- using key evolving signature schemes. This includes verifying the header -- integrity (e.g. validating the KES signature), as well as constructing the diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index 57591eb68f..5f2bfb721c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -52,6 +52,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (ShelleyHash) , ShelleyProtocol + , defaultHeaderContainsLeiosCert ) import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ( EnvelopeError @@ -69,6 +70,7 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where pHeaderBlock (Header body _) = hbBlockNo body pHeaderSize hdr = fromIntegral $ headerSize hdr pHeaderBlockSize (Header body _) = fromIntegral $ hbBodySize body + pHeaderContainsLeiosCert = defaultHeaderContainsLeiosCert type EnvelopeCheckError _ = EnvelopeError @@ -223,6 +225,7 @@ instance LeiosCrypto c => ProtocolHeaderSupportsEnvelope (Praos2 c) where pHeaderBlock = LeiosCodec.hbBlockNo . LeiosCodec.headerBody pHeaderSize hdr = fromIntegral $ LeiosCodec.headerSize hdr pHeaderBlockSize = fromIntegral . LeiosCodec.hbBodySize . LeiosCodec.headerBody + pHeaderContainsLeiosCert = LeiosCodec.hbBlockBodyContainsLeiosCert . LeiosCodec.headerBody type EnvelopeCheckError _ = EnvelopeError diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs index fcc6d2038b..63297a9821 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs @@ -42,6 +42,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , ShelleyHash (..) , ShelleyProtocol , ShelleyProtocolHeader + , defaultHeaderContainsLeiosCert ) import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ( EnvelopeError @@ -61,6 +62,7 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where pHeaderBlock = SL.bheaderBlockNo . SL.bhbody pHeaderSize = fromIntegral . originalBytesSize pHeaderBlockSize = fromIntegral @Word32 @Natural . SL.bsize . SL.bhbody + pHeaderContainsLeiosCert = defaultHeaderContainsLeiosCert type EnvelopeCheckError _ = EnvelopeError 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 ca4a7c9b5b..95a1b458c1 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 @@ -406,7 +406,8 @@ fromShelleyLedgerExamplesPraos2 = fromShelleyLedgerExamplesPolyPraos translateLeiosHeader -- | As 'translatePraosHeader', with the Leios fields of an example block that --- carries a certificate and announces an endorser block of its own. +-- announces an endorser block. It carries no certificate, since the example +-- body has none and 'blockMatchesHeader' requires the two to agree. translateLeiosHeader :: SL.BHeader StandardCrypto -> Leios.Header StandardCrypto translateLeiosHeader (SL.BHeader bhBody bhSig) = Leios.mkHeader (Proxy @DijkstraEra) hBody (coerce bhSig) @@ -426,7 +427,7 @@ translateLeiosHeader (SL.BHeader bhBody bhSig) = , Leios.hbrBodyHash = Praos.hbBodyHash pb , Leios.hbrOCert = Praos.hbOCert pb , Leios.hbrVersionInfo = SL.BlockHeaderVersionInfo (SL.getVersion32 major) minor - , Leios.hbrBlockBodyContainsLeiosCert = True + , Leios.hbrBlockBodyContainsLeiosCert = False , Leios.hbrEbReferencesAnnouncement = SL.SJust $ SL.EbReferencesAnnouncement diff --git a/ouroboros-consensus-cardano/test/shelley-test/Main.hs b/ouroboros-consensus-cardano/test/shelley-test/Main.hs index b5d3e2196d..1180c51658 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Main.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Main.hs @@ -3,6 +3,7 @@ module Main (main) where import qualified Test.Consensus.Shelley.Coherence (tests) import qualified Test.Consensus.Shelley.EndorserBlock (tests) import qualified Test.Consensus.Shelley.Golden (tests) +import qualified Test.Consensus.Shelley.Integrity (tests) import qualified Test.Consensus.Shelley.LedgerTables (tests) import qualified Test.Consensus.Shelley.Serialisation (tests) import qualified Test.Consensus.Shelley.SupportedNetworkProtocolVersion (tests) @@ -23,6 +24,7 @@ tests = [ Test.Consensus.Shelley.Coherence.tests , Test.Consensus.Shelley.EndorserBlock.tests , Test.Consensus.Shelley.Golden.tests + , Test.Consensus.Shelley.Integrity.tests , Test.Consensus.Shelley.LedgerTables.tests , Test.Consensus.Shelley.Serialisation.tests , Test.Consensus.Shelley.SupportedNetworkProtocolVersion.tests diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Integrity.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Integrity.hs new file mode 100644 index 0000000000..1df735f792 --- /dev/null +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Integrity.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeApplications #-} + +-- | A header's claim that its body carries a Leios certificate is the one +-- Leios claim checkable from the block alone. +module Test.Consensus.Shelley.Integrity (tests) where + +import Cardano.Ledger.Dijkstra (DijkstraEra) +import Cardano.Ledger.MemoBytes (getMemoRawType) +import qualified Cardano.Protocol.Leios.BlockHeader as Leios +import Data.Proxy (Proxy (Proxy)) +import Ouroboros.Consensus.Block (blockMatchesHeader, getHeader) +import Ouroboros.Consensus.Shelley.HFEras (StandardDijkstraBlock) +import Ouroboros.Consensus.Shelley.Ledger + ( Header + , mkShelleyHeader + , shelleyHeaderRaw + ) +import Ouroboros.Consensus.Shelley.Protocol.Abstract (pHeaderBodyHash) +import Test.Consensus.Shelley.Examples (examplesDijkstra) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) +import Test.Util.Serialisation.Examples (exampleBlock) + +tests :: TestTree +tests = + testGroup + "Integrity" + [ testCase "an example Dijkstra block matches its header" $ + mapM_ + (\blk -> assertBool "does not match" (blockMatchesHeader (getHeader blk) blk)) + exampleDijkstraBlocks + , testCase "a Dijkstra header claiming a Leios certificate its body lacks does not match" $ + mapM_ + ( \blk -> do + let lying = claimLeiosCert (getHeader blk) + -- Without this, the mismatch could be the body hash's doing. + assertEqual + "the body hash moved too" + (pHeaderBodyHash (shelleyHeaderRaw (getHeader blk))) + (pHeaderBodyHash (shelleyHeaderRaw lying)) + assertBool "matches despite the false claim" $ + not (blockMatchesHeader lying blk) + ) + exampleDijkstraBlocks + ] + +exampleDijkstraBlocks :: [StandardDijkstraBlock] +exampleDijkstraBlocks = snd <$> exampleBlock examplesDijkstra + +-- | The same header, claiming its body carries a Leios certificate. +-- +-- The body hash is left alone, so only the claim disagrees. +claimLeiosCert :: Header StandardDijkstraBlock -> Header StandardDijkstraBlock +claimLeiosCert hdr = + mkShelleyHeader $ + -- TODO: should be able to use lenses, but blockBodyContainsLeiosCert has none yet in ledger + Leios.mkHeader + era + (Leios.mkHeaderBody era rawBody{Leios.hbrBlockBodyContainsLeiosCert = True}) + (Leios.headerSig raw) + where + era = Proxy @DijkstraEra + raw = shelleyHeaderRaw hdr + rawBody = getMemoRawType (Leios.headerBody raw) diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 4ee868dc94..9b89ff5c2e 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1804,6 +1804,7 @@ test-suite shelley-test Test.Consensus.Shelley.Coherence Test.Consensus.Shelley.EndorserBlock Test.Consensus.Shelley.Golden + Test.Consensus.Shelley.Integrity Test.Consensus.Shelley.LedgerTables Test.Consensus.Shelley.Serialisation Test.Consensus.Shelley.SupportedNetworkProtocolVersion @@ -1817,9 +1818,9 @@ test-suite shelley-test cardano-ledger-babbage:testlib, cardano-ledger-conway:testlib, cardano-ledger-core, - cardano-ledger-dijkstra:testlib, + cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib}, cardano-ledger-shelley, - cardano-protocol-tpraos, + cardano-protocol, cardano-slotting, cborg, constraints, @@ -1934,7 +1935,7 @@ test-suite cardano-test cardano-ledger-dijkstra:{cardano-ledger-dijkstra, testlib}, cardano-ledger-mary:testlib, cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, - cardano-protocol-tpraos, + cardano-protocol, cardano-slotting, cborg, constraints, From 83cad3a10314c6f80dfb62c7fb7376f1db6e0ecf Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 11:23:07 -0400 Subject: [PATCH 17/19] TypeSwitch: fixup stale Haddock --- .../Ouroboros/Consensus/Protocol/Praos/Common.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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 444245f5d9..433805c786 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 @@ -406,8 +406,8 @@ pureLeiosOnly = pure -- | Allow for any type on the side of a type-level switch that wasn't chosen -- -- For our types like 'LeiosOnly', there is only one instance that type checks. --- See 'Ouroboros.Consensus.Protocol.Praos.leiosContextFreeHeaderChecks' for an --- example use. +-- See 'Ouroboros.Consensus.Protocol.PolyPraos.leiosContextFreeHeaderChecks' for +-- an example use. -- -- Example: -- @@ -417,8 +417,8 @@ pureLeiosOnly = pure -- > typeSwitchL = L (L ()) -- > typeSwitchR = L () -- --- The usefulness is that the inner layer of L (L ()) is parametrically --- polymorphic in @a@. +-- The usefulness is that the inner layer of L (L ()) can have any type, even +-- 'Void'. -- -- Another way to think about it: these @ff@ are types like 'Either' except the -- choice between 'Left' and 'Right' is made statically rather than dynamically. From d49d3dea73168e928cbbf31e3c7b36cac6a13ef4 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 11:41:24 -0400 Subject: [PATCH 18/19] PolyPraos: improve name of ForecastLeios, which is not Leios specific --- .../Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs | 4 ++-- .../Ouroboros/Consensus/Protocol/Praos.hs | 2 +- .../Ouroboros/Consensus/Protocol/Praos/Views.hs | 6 +++--- .../Ouroboros/Consensus/Protocol/Praos2.hs | 2 +- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index 426642aa5e..df21738c73 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -91,7 +91,7 @@ instance -- Uses the same projection as 'ledgerViewForecastAtPolyPraos', so the two agree. protocolLedgerViewPolyPraos :: forall proto era mk. - ( Praos.ForecastsLeios proto era + ( Praos.ForecastToPolyPraosLedgerView proto era , SL.EraForecast era ) => LedgerConfig (ShelleyBlock proto era) -> @@ -104,7 +104,7 @@ protocolLedgerViewPolyPraos _cfg = ledgerViewForecastAtPolyPraos :: forall proto era mk. ( ShelleyCompatible proto era - , Praos.ForecastsLeios proto era + , Praos.ForecastToPolyPraosLedgerView proto era ) => LedgerConfig (ShelleyBlock proto era) -> LedgerState (ShelleyBlock proto era) mk -> 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 24fe754713..8faf782efd 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 @@ -182,7 +182,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where reupdateChainDepState (PraosConfig prms ei) = reupdateChainDepStatePolyPraos prms ei -instance Views.ForecastsLeios (Praos c) era where +instance Views.ForecastToPolyPraosLedgerView (Praos c) era where forecastToPolyPraosLedgerView (f :: SL.Forecast t era) = Views.PraosLedgerView { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t 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 422d10d78d..f4f401b6cc 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 @@ -8,7 +8,7 @@ module Ouroboros.Consensus.Protocol.Praos.Views ( PolyPraosLedgerView (..) , PolyPraosValidateView (..) - , ForecastsLeios (..) + , ForecastToPolyPraosLedgerView (..) ) where import Cardano.Crypto.KES (SignedKES) @@ -105,7 +105,7 @@ deriving instance -- A method rather than one shared function because only the protocols with -- Leios may demand more of their era than 'SL.EraForecast', and knowing -- @proto@ alone cannot supply that @era@ dictionary. -type ForecastsLeios :: Type -> Type -> Constraint -class ForecastsLeios proto era where +type ForecastToPolyPraosLedgerView :: Type -> Type -> Constraint +class ForecastToPolyPraosLedgerView proto era where forecastToPolyPraosLedgerView :: SL.EraForecast era => SL.Forecast t era -> PolyPraosLedgerView proto diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs index 3115772eb4..b3b31596bb 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos2.hs @@ -133,7 +133,7 @@ instance LeiosCrypto c => ConsensusProtocol (Praos2 c) where reupdateChainDepState (LeiosConfig (PraosConfig prms ei)) = reupdateChainDepStatePolyPraos prms ei -instance Dijkstra.DijkstraEraForecast era => Views.ForecastsLeios (Praos2 c) era where +instance Dijkstra.DijkstraEraForecast era => Views.ForecastToPolyPraosLedgerView (Praos2 c) era where forecastToPolyPraosLedgerView (f :: SL.Forecast t era) = Views.PraosLedgerView { Views.plvPoolDistr = f ^. SL.poolDistrForecastL @era @t From c7d790273e8bf94e21dad1899e378261b41933a0 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Fri, 9 Oct 2026 11:41:32 -0400 Subject: [PATCH 19/19] Update changelog fragment --- .../20261009_135300_javier.sagredo_praos2.md | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/changelog.d/20261009_135300_javier.sagredo_praos2.md b/changelog.d/20261009_135300_javier.sagredo_praos2.md index ff6a70ac3b..a6d76e431c 100644 --- a/changelog.d/20261009_135300_javier.sagredo_praos2.md +++ b/changelog.d/20261009_135300_javier.sagredo_praos2.md @@ -41,7 +41,8 @@ For top level release notes, leave all the headers commented out. `plvAnnouncementPeriodLength`, `plvVotePeriodLength`, `plvDiffusionPeriodLength`, `plvMaxEbBodySize` and `plvMaxEbTxsSize`. `forecastToPraosLedgerView` is replaced by the method - `forecastToPolyPraosLedgerView` of the new class `ForecastsLeios`. + `forecastToPolyPraosLedgerView` of the new class + `ForecastToPolyPraosLedgerView`. - `Ouroboros.Consensus.Protocol.Praos` re-exports what it used to define, and adds the synonyms `PraosLedgerView c` and `PraosValidateView c`. - `PraosCrypto c` is now defined through the new `PolyPraosCrypto proto c`. @@ -53,13 +54,24 @@ For top level release notes, leave all the headers commented out. constructors of the shared types. Its instances for `TPraos`, `Praos` and `Praos2` have the constructors `TPraosLacksLeios`, `PraosLacksLeios` and `Praos2HasLeios`. + The synonyms `WhenLeios proto` (for `LeiosOnly proto ()`, a field only the + protocols with Leios fill) and `VoidUnlessLeios proto` (for + `LeiosOnly proto Void`, a constructor only they can build) name its two + uses, and `pureLeiosOnly` is `pure` at `WhenLeios proto`. - `ShelleyProtocolHeader` is now defined in `Ouroboros.Consensus.Protocol.Praos.Common`. `Ouroboros.Consensus.Shelley.Protocol.Abstract` still re-exports it. +- `blockMatchesHeader` for Shelley-based blocks additionally requires that the + header's claim that the body carries a Leios certificate is true, and that a + body does not carry both a certificate and transactions. This adds the method + `pHeaderContainsLeiosCert` to `ProtocolHeaderSupportsEnvelope` (with + `defaultHeaderContainsLeiosCert` for protocols without Leios) and the method + `blockBodyContainsLeiosCert` to `ShelleyBasedEra` (with + `defaultBlockBodyContainsLeiosCert` for eras without Leios). - `ProtocolHeaderSupportsKES.mkHeader` takes a proxy for the era of the block being forged, and the Leios fields of the header as a - `LeiosOnly proto () (Bool, StrictMaybe EbReferencesAnnouncement)`. - `forgeShelleyBlock` additionally requires `Applicative (LeiosOnly proto ())`. + `WhenLeios proto (Bool, StrictMaybe EbReferencesAnnouncement)`. + `forgeShelleyBlock` additionally requires `Applicative (WhenLeios proto)`. - The `EncodeDisk` and `DecodeDisk` instances for the Praos chain-dependent state are now for `PolyPraosState proto`, and require the new `SerialisePraosState proto`.