diff --git a/cabal.project b/cabal.project index e82b01c360..125c34d8d1 100644 --- a/cabal.project +++ b/cabal.project @@ -42,3 +42,39 @@ if os (windows) 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 + --sha256: sha256-s/LVusbn3sE+yXYyOJpEg52PY+YVKqwmmEFdHM9ikD0= + tag: 0a72d43f5996c23eae1f6164d7d6a4dfeabe4c7f + 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 + +allow-newer: + , 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/changelog.d/20261009_135300_javier.sagredo_praos2.md b/changelog.d/20261009_135300_javier.sagredo_praos2.md new file mode 100644 index 0000000000..a6d76e431c --- /dev/null +++ b/changelog.d/20261009_135300_javier.sagredo_praos2.md @@ -0,0 +1,105 @@ + + +### 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 + `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`. + - `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`. + 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 + `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`. +- 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-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 diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra index d87673ac96..d310b00dc5 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra differ 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 2171fa1434..4103dd9438 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion3/CardanoNodeToClientVersion19/Result_Dijkstra_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion3/CardanoNodeToClientVersion19/Result_Dijkstra_LedgerTip @@ -1 +1 @@ - X i^՟'9"{N< \ No newline at end of file + X YwTB4,i զp8/p7 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra index e245d9b17c..5f859d4e58 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/ChainDepState_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra index 335d164316..ade1b215ac 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo index f4c9d4d7d7..fc643e1154 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage index 85d8c11675..26032bf05c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway index 57de590a88..90b7f062f8 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra index a9655dc95d..5397aba5ea 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary index 706a0abb39..74e374cfd5 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley index 3847aa5098..cce00d303f 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley and b/ouroboros-consensus-cardano/golden/cardano/disk/ExtLedgerState_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra index 1d550e294a..6c808c08de 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo index b0b186a13d..869f113314 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage index 1b91cfe6c4..a96ddad9e0 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway index d6c94cb944..1746337329 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra index 8fd88d55a0..efe32bb0b9 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary index 5b05a7571f..0e99c242f4 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley index a19053198d..e37b49a888 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerState_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState b/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState index 90dc8e099d..8c2c053599 100644 Binary files a/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState and b/ouroboros-consensus-cardano/golden/shelley/disk/ExtLedgerState differ diff --git a/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState b/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState index fc69f5815b..5d7fd800c0 100644 Binary files a/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState and b/ouroboros-consensus-cardano/golden/shelley/disk/LedgerState differ 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..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) @@ -104,6 +92,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 () @@ -375,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) @@ -423,7 +377,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 @@ -550,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 @@ -769,7 +708,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano -- Dijkstra - blockConfigDijkstra :: BlockConfig (ShelleyBlock (Praos c) DijkstraEra) + blockConfigDijkstra :: BlockConfig (ShelleyBlock (Praos2 c) DijkstraEra) blockConfigDijkstra = Shelley.mkShelleyBlockConfig cardanoProtocolVersion @@ -777,10 +716,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 @@ -906,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 @@ -941,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 = @@ -1039,6 +956,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 +972,7 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano :* tpraos :* praos :* praos - :* praos + :* praos2 :* Nil protocolClientInfoCardano :: diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index 1339ef0cab..8d01928c72 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -47,6 +47,7 @@ import qualified Cardano.Ledger.Conway.Rules as SL ) import qualified Cardano.Ledger.Conway.State as CG import Cardano.Ledger.Dijkstra (ApplyTxError (DijkstraApplyTxError), DijkstraEra) +import Cardano.Ledger.Dijkstra.BlockBody (leiosCertBlockBodyL) import qualified Cardano.Ledger.Dijkstra.Rules as Dijkstra import qualified Cardano.Ledger.Dijkstra.Rules as SL ( DijkstraLedgerPredFailure (..) @@ -144,6 +145,12 @@ class getShelleyEraPerasRoundLength :: proxy era -> 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/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/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/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index c9672c091a..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 @@ -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 (WhenLeios, 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 (WhenLeios proto) + , Monad m + ) => HotKey (ProtoCrypto proto) m -> CanBeLeader proto -> ForgeBlockArgs (ShelleyBlock proto era) -> @@ -52,6 +58,7 @@ forgeShelleyBlock do hdr <- mkHeader @_ @(ProtoCrypto proto) + (Proxy @era) hotKey cbl fbIsLeader @@ -61,6 +68,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 +76,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/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 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..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 @@ -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.ForecastToPolyPraosLedgerView 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.ForecastToPolyPraosLedgerView 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..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 @@ -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, WhenLeios) +import Ouroboros.Consensus.Protocol.Praos2 (ConsensusConfig (..), 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 praosParams + +-- | '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 (WhenLeios proto) + , IOLike m + ) => + -- | 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 + getPraosParams hotKey slotToPeriod ShelleyLeaderCredentials @@ -85,8 +111,20 @@ praosSharedBlockForging <$> HotKey.evolve hotKey (slotToPeriod curSlot) , checkCanForge = \cfg curSlot _tickedChainDepState _isLeader -> praosCheckCanForge - (configConsensus cfg) + (getPraosParams (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 (praosParams . 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..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,12 +21,15 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract , ShelleyHash (..) , ShelleyProtocol , ShelleyProtocolHeader + , defaultHeaderContainsLeiosCert ) where 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.Core (Era) import Cardano.Ledger.Hashes ( EraIndependentBlockBody , EraIndependentBlockHeader @@ -57,7 +60,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 + , ShelleyProtocolHeader + , WhenLeios + ) import Ouroboros.Consensus.Protocol.Signed (SignedHeader) import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -93,9 +100,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. @@ -114,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 @@ -124,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 @@ -144,7 +156,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 -> @@ -160,6 +174,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 + WhenLeios 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..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 @@ -4,27 +4,46 @@ 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.Core (Era) +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.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 +52,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (ShelleyHash) , ShelleyProtocol - , ShelleyProtocolHeader + , defaultHeaderContainsLeiosCert ) import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ( EnvelopeError @@ -43,8 +62,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 @@ -53,58 +70,105 @@ 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 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,121 @@ 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 + pHeaderContainsLeiosCert = LeiosCodec.hbBlockBodyContainsLeiosCert . 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 + era + hk + cbl + il + slotNo + blockNo + prevHash + bbHash + sz + protVer + (Praos2HasLeios (containsCert, mbAnn)) = + mkHeaderPolyPraos + hk + cbl + il + slotNo + blockNo + prevHash + bbHash + sz + protVer + (\pb -> extendHeaderBodyWithLeios era pb containsCert mbAnn) + (LeiosCodec.mkHeader era) + +-- | 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 :: + (Crypto c, Era era) => + proxy era -> + HeaderBody c -> + -- | Whether the block body carries a Leios certificate + Bool -> + StrictMaybe EbReferencesAnnouncement -> + LeiosCodec.HeaderBody c +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 + +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..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 @@ -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 (..) @@ -41,6 +42,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract , ShelleyHash (..) , ShelleyProtocol , ShelleyProtocolHeader + , defaultHeaderContainsLeiosCert ) import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks ( EnvelopeError @@ -60,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 @@ -96,7 +99,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..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 @@ -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,65 @@ 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 +-- 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) + where + pb = praosHeaderBodyFromTPraos bhBody + SL.ProtVer major minor = Praos.hbProtVer pb + hBody = + 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 = False + , Leios.hbrEbReferencesAnnouncement = + SL.SJust $ + SL.EbReferencesAnnouncement + { SL.ebReferencesAnnouncementHash = + unsafeMakeSafeHash $ Hash.castHash $ Praos.hbBodyHash pb + , SL.ebReferencesAnnouncementSize = 123 + } + } + examplesShelley :: Examples StandardShelleyBlock examplesShelley = fromShelleyLedgerExamples ledgerExamplesShelley @@ -399,7 +456,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-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-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..2360d850a6 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/PolyPraos.hs @@ -0,0 +1,983 @@ +{-# 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.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 :: + !(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 (WhenLeios proto (StrictMaybe AnnouncedBy)) => Show (PolyPraosState proto) + +deriving instance + Eq (WhenLeios proto (StrictMaybe AnnouncedBy)) => Eq (PolyPraosState proto) + +instance + ( Typeable proto + , NoThunks (WhenLeios 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 (WhenLeios proto) + , Traversable (WhenLeios 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 + !(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 + !(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 + !(VoidUnlessLeios proto ()) + !Word32 -- Announced size + !Word32 -- Maximum size + deriving Generic + +deriving instance + (Crypto c, Eq (VoidUnlessLeios proto ())) => + Eq (PolyPraosValidationErr proto c) + +deriving instance + (Typeable proto, Crypto c, NoThunks (VoidUnlessLeios proto ())) => + NoThunks (PolyPraosValidationErr proto c) + +deriving instance + (Crypto c, Show (VoidUnlessLeios proto ())) => + 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 (WhenLeios proto) + , Foldable (WhenLeios 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 (WhenLeios 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 (WhenLeios proto) + , Foldable (WhenLeios 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 (WhenLeios proto) + , Foldable (WhenLeios 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 01662682bc..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 @@ -1,245 +1,148 @@ +{-# 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 with no extensions. module Ouroboros.Consensus.Protocol.Praos ( ConsensusConfig (..) + , LeiosOnly (..) + , VoidUnlessLeios + , WhenLeios , Praos - , PraosCannotForge (..) , 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 (..) + , PraosCannotForge (..) , PraosFields (..) , PraosIsLeader (..) , PraosParams (..) - , PraosState (..) , PraosToSign (..) - , PraosValidationErr (..) + , SerialisePraosState , Ticked (..) + , checkIsLeaderPolyPraos , forgePraosFields + , getOpCertCountersPolyPraos + , getPraosNoncesPolyPraos + , leiosContextFreeHeaderChecks , praosCheckCanForge + , reupdateChainDepStatePolyPraos + , updateChainDepStatePolyPraos + , tickChainDepStatePolyPraos + , 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, (⭒)) -import qualified Cardano.Ledger.BaseTypes as SL +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.Keys - ( DSIGN - , KeyHash - , VKey (VKey) - , coerceKeyRole - , hashKey - ) -import qualified Cardano.Ledger.Keys as SL -import Cardano.Ledger.Shelley (ShelleyEra) -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 Cardano.Protocol.Praos.VRF - ( InputVRF - , mkInputVRF - , vrfLeaderValue - , vrfNonceValue - ) +import qualified Cardano.Ledger.Shelley.API as SL +import Cardano.Protocol.Crypto (Crypto, StandardCrypto) +import qualified Cardano.Protocol.Praos.BlockHeader as PraosCodec 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 - , hoistEpochInfo - ) -import Cardano.Slotting.Slot - ( EpochNo (EpochNo) - , SlotNo (SlotNo) - , WithOrigin - , unSlotNo - ) -import qualified Codec.CBOR.Encoding as CBOR -import Codec.Serialise (Serialise (decode, encode)) -import Control.Exception (throw) -import Control.Monad (unless) -import Control.Monad.Except (Except, runExcept, throwError) +import Cardano.Slotting.EpochInfo (EpochInfo) +import Control.Monad.Except (Except) import Data.Coerce (coerce) -import Data.Functor.Identity (runIdentity) -import Data.Map.Strict (Map) +import Data.Kind (Type) import qualified Data.Map.Strict as Map -import Data.Proxy (Proxy (Proxy)) -import Data.Word (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 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.TPraos ( ConsensusConfig (TPraosConfig, tpraosEpochInfo, tpraosParams) , TPraos , TPraosState (tpraosStateChainDepState, tpraosStateLastSlot) ) -import Ouroboros.Consensus.Ticked (Ticked) -import Ouroboros.Consensus.Util.Versioned - ( VersionDecoder (Decode) - , decodeVersion - , encodeVersion - ) +{------------------------------------------------------------------------------- + The protocol +-------------------------------------------------------------------------------} + +type Praos :: Type -> Type data Praos c -class - ( Crypto c - , DSIGN.Signable DSIGN (OCertSignable c) - , KES.Signable (KES c) (HeaderBody c) - , VRF.Signable (VRF c) InputVRF - ) => - PraosCrypto 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 -{------------------------------------------------------------------------------- - Fields required by Praos in the header --------------------------------------------------------------------------------} +type PraosState c = PolyPraosState (Praos c) -data PraosFields c toSign = PraosFields - { praosSignature :: KES.SignedKES (KES c) toSign - , praosToSign :: toSign - } - deriving Generic +type PraosLedgerView c = Views.PolyPraosLedgerView (Praos c) -deriving instance - (NoThunks toSign, PraosCrypto c) => - NoThunks (PraosFields c toSign) - -deriving instance - (Show toSign, PraosCrypto 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 +type PraosValidateView c = Views.PolyPraosValidateView (Praos c) c -instance PraosCrypto c => NoThunks (PraosToSign c) - -deriving instance PraosCrypto c => Show (PraosToSign c) - -forgePraosFields :: - ( PraosCrypto c - , KES.Signable (KES c) toSign - , Monad m - ) => - HotKey c m -> - CanBeLeader (Praos c) -> - IsLeader (Praos 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 - } +type PraosValidationErr c = PolyPraosValidationErr (Praos c) c {------------------------------------------------------------------------------- - Protocol proper + The fields only this protocol has -------------------------------------------------------------------------------} --- | 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) +-- | Praos is not Leios, so it holds the left alternative. +newtype instance LeiosOnly (Praos c) a b = PraosLacksLeios a + deriving (Eq, Generic, Show) --- | 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 +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 PraosCrypto c => NoThunks (PraosIsLeader c) +instance TypeSwitch (LeiosOnly (Praos c)) where + typeSwitchL = PraosLacksLeios (PraosLacksLeios ()) + typeSwitchR = PraosLacksLeios () + +{------------------------------------------------------------------------------- + Configuration +-------------------------------------------------------------------------------} -- | Static configuration data instance ConsensusConfig (Praos c) = PraosConfig @@ -251,9 +154,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 @@ -262,490 +163,42 @@ 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 PraosState = 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 - } - deriving (Generic, Show, Eq) - -instance NoThunks PraosState - -instance ToCBOR PraosState where - toCBOR = encode - -instance FromCBOR PraosState where - fromCBOR = decode - -instance Serialise PraosState where - encode - PraosState - { praosStateLastSlot - , praosStateOCertCounters - , praosStateEvolvingNonce - , praosStateCandidateNonce - , praosStateEpochNonce - , praosStatePreviousEpochNonce - , praosStateLabNonce - , praosStateLastEpochBlockNonce - } = - encodeVersion 0 $ - mconcat - [ CBOR.encodeListLen 8 - , toCBOR praosStateLastSlot - , toCBOR praosStateOCertCounters - , toEraCBOR @ShelleyEra praosStateEvolvingNonce - , toEraCBOR @ShelleyEra praosStateCandidateNonce - , toEraCBOR @ShelleyEra praosStateEpochNonce - , toEraCBOR @ShelleyEra praosStatePreviousEpochNonce - , toEraCBOR @ShelleyEra praosStateLabNonce - , toEraCBOR @ShelleyEra praosStateLastEpochBlockNonce - ] - - decode = - decodeVersion - [(0, Decode decodePraosState)] - where - decodePraosState = do - enforceSize "PraosState" 8 - PraosState - <$> fromCBOR - <*> fromCBOR - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - <*> fromEraCBOR @ShelleyEra - -data instance Ticked PraosState = TickedPraosState - { tickedPraosStateChainDepState :: PraosState - , tickedPraosStateLedgerView :: Views.PraosLedgerView - } - --- | Errors which we might encounter -data PraosValidationErr 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 - deriving Generic - -deriving instance PraosCrypto c => Eq (PraosValidationErr c) - -deriving instance PraosCrypto c => NoThunks (PraosValidationErr c) - -deriving instance PraosCrypto c => Show (PraosValidationErr c) - -instance ChainDepStateSupportsPeras PraosState where - getEpochNonce = praosStateEpochNonce - -instance ChainDepStateSupportsPeras (Ticked PraosState) 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 - } - 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 - - -- 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 - --- | Check whether this node meets the leader threshold to issue a block. -meetsLeaderThreshold :: - forall c. - ConsensusConfig (Praos c) -> - LedgerView (Praos c) -> - SL.KeyHash SL.StakePool -> - VRF.CertifiedVRF (VRF c) InputVRF -> - Bool -meetsLeaderThreshold - PraosConfig{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 c. - PraosCrypto c => - Nonce -> - Views.PraosLedgerView -> - ActiveSlotCoeff -> - Views.HeaderView c -> - Except (PraosValidationErr 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 => - Nonce -> - Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> - ActiveSlotCoeff -> - Views.HeaderView c -> - Except (PraosValidationErr 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 :: - PraosCrypto c => - ConsensusConfig (Praos c) -> - LedgerView (Praos c) -> - Map (KeyHash SL.BlockIssuer) Word64 -> - Views.HeaderView c -> - Except (PraosValidationErr c) () -validateKESSignature - _cfg@( PraosConfig - PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} - _ei - ) - 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 :: - PraosCrypto c => - Word64 -> - Word64 -> - Map (KeyHash SL.StakePool) SL.IndividualPoolStake -> - Map (KeyHash SL.BlockIssuer) Word64 -> - Views.HeaderView c -> - Except (PraosValidationErr 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 + checkIsLeader = checkIsLeaderPolyPraos . praosParams -deriving instance PraosCrypto c => Show (PraosCannotForge c) - -praosCheckCanForge :: - ConsensusConfig (Praos c) -> - SlotNo -> - HotKey.KESInfo -> - Either (PraosCannotForge c) () -praosCheckCanForge - PraosConfig{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 + tickChainDepState = tickChainDepStatePolyPraos . praosEpochInfo -{------------------------------------------------------------------------------- - PraosProtocolSupportsNode --------------------------------------------------------------------------------} + updateChainDepState (PraosConfig prms ei) = updateChainDepStatePolyPraos prms ei -instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where - type PraosProtocolSupportsNodeCrypto (Praos c) = c + reupdateChainDepState (PraosConfig prms ei) = reupdateChainDepStatePolyPraos prms ei - getPraosNonces _prx cdst = - PraosNonces - { candidateNonce = praosStateCandidateNonce - , epochNonce = praosStateEpochNonce - , evolvingNonce = praosStateEvolvingNonce - , labNonce = praosStateLabNonce - , previousLabNonce = praosStateLastEpochBlockNonce +instance Views.ForecastToPolyPraosLedgerView (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 - PraosState - { praosStateCandidateNonce - , praosStateEpochNonce - , praosStateEvolvingNonce - , praosStateLabNonce - , praosStateLastEpochBlockNonce - } = cdst - - getOpCertCounters _prx cdst = - praosStateOCertCounters - where - PraosState - { praosStateOCertCounters - } = cdst + cc = SL.forecastChainChecks @t @era f {------------------------------------------------------------------------------- Translation from transitional Praos @@ -764,6 +217,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 +236,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} = @@ -785,17 +246,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 ?! +instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where + type PraosProtocolSupportsNodeCrypto (Praos c) = c -(?!:) :: Either e1 a -> (e1 -> e2) -> Except e2 () -(Right _) ?!: _ = pure () -(Left e1) ?!: f = throwError $ f e1 + getPraosNonces _prx = getPraosNoncesPolyPraos -infix 1 ?!: + getOpCertCounters _prx = getOpCertCountersPolyPraos 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..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 @@ -6,13 +6,20 @@ {-# 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 + , VoidUnlessLeios + , WhenLeios + , pureLeiosOnly + , TypeSwitch (..) + , ShelleyProtocolHeader + , MaxMajorProtVer (..) , HasMaxMajorProtVer (..) , PraosCanBeLeader (..) , PraosTiebreakerView (..) @@ -40,8 +47,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 +362,67 @@ 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: +-- +-- * @VoidUnlessLeios proto ()@ gates a constructor, since the protocols +-- without Leios cannot build it. +-- +-- * @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 (WhenLeios proto) => b -> WhenLeios 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.PolyPraos.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 ()) 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. +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..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 @@ -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 (..) + , ForecastToPolyPraosLedgerView (..) ) 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 (ShelleyProtocolHeader, WhenLeios) +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 :: !(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)) -- ^ 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,36 @@ data PraosLedgerView = PraosLedgerView -- ^ Maximum block body size , plvProtocolVersion :: !ProtVer -- ^ Current protocol version + , plvCommittee :: !(WhenLeios proto LeiosCommittee) + -- ^ Who may vote this epoch, and with what weight + , plvQuorumStakeThreshold :: !(WhenLeios proto UnitInterval) + -- ^ Weight a certificate must accumulate + , 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 :: !(WhenLeios proto Word32) + -- ^ Maximum size of an endorser block itself, not its closure + , plvMaxEbTxsSize :: !(WhenLeios 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 (WhenLeios proto LeiosCommittee) + , Show (WhenLeios proto UnitInterval) + , Show (WhenLeios proto Milliseconds32) + , Show (WhenLeios proto Word32) + ) => + Show (PolyPraosLedgerView proto) + +-- | 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 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 new file mode 100644 index 0000000000..b3b31596bb --- /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 . praosParams . leiosPraosConfig + + tickChainDepState = tickChainDepStatePolyPraos . praosEpochInfo . leiosPraosConfig + + -- The Leios header checks are cheap, so they run before the signature checks. + updateChainDepState (LeiosConfig (PraosConfig prms ei)) = updateChainDepStatePolyPraos prms ei + + reupdateChainDepState (LeiosConfig (PraosConfig prms ei)) = reupdateChainDepStatePolyPraos prms ei + +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 + , 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..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 @@ -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.WhenLeios proto) + , Traversable (Praos.WhenLeios 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..9b89ff5c2e 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, @@ -1175,10 +1175,13 @@ 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 + Ouroboros.Consensus.Protocol.Praos.Orphans Ouroboros.Consensus.Protocol.Praos.Views + Ouroboros.Consensus.Protocol.Praos2 Ouroboros.Consensus.Protocol.TPraos build-depends: @@ -1187,8 +1190,9 @@ library protocol cardano-crypto-class:cardano-crypto-class, cardano-ledger-binary, cardano-ledger-core, - cardano-ledger-shelley ^>=1.20, - cardano-protocol ^>=0.2, + cardano-ledger-dijkstra ^>=0.5, + cardano-ledger-shelley ^>=1.21, + cardano-protocol ^>=0.3, cardano-protocol-tpraos ^>=1.6, cardano-slotting, cborg, @@ -1601,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.4, - cardano-ledger-mary ^>=1.11, + cardano-ledger-dijkstra ^>=0.5, + 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, @@ -1800,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 @@ -1813,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, @@ -1930,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, 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