[WIP] Enrich block bodies to contain Peras certificates

cabal.project

@@ -16,7 +16,7 @@ index-state:
   -- Bump this if you need newer packages from Hackage
   , hackage.haskell.org 2025-07-22T09:13:54Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2025-08-21T09:41:03Z
+  , cardano-haskell-packages 2025-10-07T11:20:00Z
 
 packages:
   ouroboros-consensus
@@ -56,6 +56,17 @@ allow-newer:
     , fin:QuickCheck
     , bin:QuickCheck
 
+source-repository-package
+   type: git
+   location: https://github.com/IntersectMBO/ouroboros-network
+   tag: peras-staging/pr-5202
+   --sha256: sha256-nTbjunQaqt6/syzSKw24Lne50083dI2SZFirG2/1T9U=
+   subdir:
+     ouroboros-network
+     ouroboros-network-protocols
+     ouroboros-network-api
+     ouroboros-network
+
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/cardano-ledger

docs/website/contents/howtos/benchmarks.md

@@ -0,0 +1,32 @@
+# Consensus benchmarks
+
+We are in the process of adding component level microbenchmarks for Consensus.
+
+We check for regressions in performance on CI.
+
+## Mempool Benchmark
+
+We started with microbenchmarks for adding transactions to the mempool. The
+mempool benchmarks can be run using the following command.
+
+```sh
+cabal new-run ouroboros-consensus:mempool-bench
+```
+
+## ChainSync Client Benchmark
+
+To aid the refactoring of the ChainSync client, we added a benchmark for it in [PR#823](https://github.com/IntersectMBO/ouroboros-consensus/pull/823). The benchmark could be invoked as follows:
+
+```sh
+cabal new-run ouroboros-consensus:ChainSync-client-bench -- 10 10
+```
+
+## PerasCertDB Benchmark
+
+We have a microbenchmark for the boosted chain fragment weight calculation, which could be run as follows:
+
+```sh
+cabal run ouroboros-consensus:PerasCertDB-bench -- +RTS -T -A32m -RTS
+```
+
+We request GHC runtime system statistics with `-T` to get a memory usage estimate, and also request a large nursery with `-A32m` to minimise garbage collection. See `tasty-bench` [documentation](https://github.com/Bodigrim/tasty-bench?tab=readme-ov-file#troubleshooting) for more tips.

docs/website/contents/references/glossary.md

@@ -472,6 +472,19 @@ These kinds are maintained by the Networking layer:
 - [Public root peers](#public-root-peers).
 - [Shared peers](#shared-peers).
 
+## ;Peras ;weight ;boost
+
+Peras is an extension of Praos enabling faster settlement under optimistic conditions.
+To this end, Peras can result in a block `B` receiving a *boost*, which means that any chain containing `B` gets additional weight when being compared to other chains.
+
+Consider a chain fragment `F`:
+
+- Its ;*weight boost* is the sum of all boosts received by points on this fragment (excluding the anchor). Note that the same point can be boosted multiple times.
+
+- Its ;*total weight* is its tip block number plus its weight boost.
+
+Note that these notions are always relative to a particular anchor, so different chain fragments must have the same anchor when their total weight is to be compared.
+
 ## ;Phases
 
 Byron, Shelley, Goguen (current one as of August 2023), Basho, Voltaire.

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -333,6 +333,7 @@ byronEraParams genesis =
     , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis
     , eraSafeZone = HardFork.StandardSafeZone (2 * k)
     , eraGenesisWin = GenesisWindow (2 * k)
+    , eraPerasRoundLength = HardFork.NoPerasEnabled
     }
  where
   k = unNonZero $ maxRollbacks $ genesisSecurityParam genesis
@@ -345,6 +346,7 @@ byronEraParamsNeverHardForks genesis =
     , eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis
     , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone
     , eraGenesisWin = GenesisWindow (2 * Gen.unBlockCount (Gen.configK genesis))
+    , eraPerasRoundLength = HardFork.NoPerasEnabled
     }
 
 instance HasHardForkHistory ByronBlock where

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -432,6 +432,7 @@ instance
     Map.fromList $
       [ (NodeToNodeV_14, CardanoNodeToNodeVersion2)
       , (NodeToNodeV_15, CardanoNodeToNodeVersion2)
+      , (NodeToNodeV_16, CardanoNodeToNodeVersion2)
       ]
 
   supportedNodeToClientVersions _ =

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs

@@ -28,6 +28,7 @@ module Ouroboros.Consensus.Shelley.Eras
 
     -- * Convenience functions
   , isBeforeConway
+  , isBeforeDijkstra
 
     -- * Re-exports
   , StandardCrypto
@@ -140,6 +141,10 @@ isBeforeConway :: forall era. L.Era era => Proxy era -> Bool
 isBeforeConway _ =
   L.eraProtVerLow @era < L.eraProtVerLow @L.ConwayEra
 
+isBeforeDijkstra :: forall era. L.Era era => Proxy era -> Bool
+isBeforeDijkstra _ =
+  L.eraProtVerLow @era < L.eraProtVerLow @L.DijkstraEra
+
 -- | The default implementation of 'applyShelleyBasedTx', a thin wrapper around
 -- 'SL.applyTx'
 defaultApplyShelleyBasedTx ::

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
@@ -26,7 +27,10 @@ module Ouroboros.Consensus.Shelley.Ledger.Block
 
     -- * Shelley Compatibility
   , ShelleyCompatible
+  , fromShelleyBlock
+  , toShelleyBlock
   , mkShelleyBlock
+  , mkShelleyBlockWithPerasCert
   , mkShelleyHeader
 
     -- * Serialisation
@@ -46,22 +50,31 @@ import Cardano.Ledger.Binary
   ( Annotator (..)
   , DecCBOR (..)
   , EncCBOR (..)
+  , EncCBORGroup (..)
   , FullByteString (..)
+  , cborError
+  , decodeListLen
+  , encodeListLen
+  , fromPlainDecoder
   , serialize
   )
 import qualified Cardano.Ledger.Binary.Plain as Plain
 import Cardano.Ledger.Core as SL
-  ( eraDecoder
+  ( EraBlockBody (..)
+  , eraDecoder
   , eraProtVerLow
   , toEraCBOR
   )
-import qualified Cardano.Ledger.Core as SL (TranslationContext, hashBlockBody)
+import qualified Cardano.Ledger.Core as SL (TranslationContext)
 import Cardano.Ledger.Hashes (HASH)
 import qualified Cardano.Ledger.Shelley.API as SL
 import Cardano.Protocol.Crypto (Crypto)
 import qualified Cardano.Protocol.TPraos.BHeader as SL
+import Codec.Serialise (Serialise (..))
+import Control.Arrow (Arrow (..))
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Coerce (coerce)
+import Data.Maybe.Strict (StrictMaybe (..))
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
@@ -145,7 +158,9 @@ instance ShelleyCompatible proto era => ConvertRawHash (ShelleyBlock proto era)
 --
 -- This block is parametrised over both the (ledger) era and the protocol.
 data ShelleyBlock proto era = ShelleyBlock
-  { shelleyBlockRaw :: !(SL.Block (ShelleyProtocolHeader proto) era)
+  { shelleyBlockHeader :: !(ShelleyProtocolHeader proto)
+  , shelleyBlockBody :: !(SL.BlockBody era)
+  , shelleyBlockPerasCert :: !(StrictMaybe (PerasCert (ShelleyBlock proto era)))
   , shelleyBlockHeaderHash :: !ShelleyHash
   }
 
@@ -158,14 +173,46 @@ instance
 
 type instance HeaderHash (ShelleyBlock proto era) = ShelleyHash
 
+-- | Reconstruct a Shelley ledger block from a 'ShelleyBlock'.
+--
+-- TODO: we should be able to avoid this conversion in most cases
+fromShelleyBlock :: ShelleyBlock proto era -> SL.Block (ShelleyProtocolHeader proto) era
+fromShelleyBlock blk = SL.Block (shelleyBlockHeader blk) (shelleyBlockBody blk)
+
+-- | Construct a 'ShelleyBlock' from a Shelley ledger block.
+--
+-- TODO: we should be able to avoid this conversion in most cases
+toShelleyBlock ::
+  ShelleyCompatible proto era => SL.Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era
+toShelleyBlock (SL.Block hdr body) = mkShelleyBlock hdr body
+
 mkShelleyBlock ::
   ShelleyCompatible proto era =>
-  SL.Block (ShelleyProtocolHeader proto) era ->
+  ShelleyProtocolHeader proto ->
+  SL.BlockBody era ->
   ShelleyBlock proto era
-mkShelleyBlock raw =
+mkShelleyBlock = mkShelleyBlockGeneric SNothing
+
+mkShelleyBlockWithPerasCert ::
+  ShelleyCompatible proto era =>
+  PerasCert (ShelleyBlock proto era) ->
+  ShelleyProtocolHeader proto ->
+  SL.BlockBody era ->
+  ShelleyBlock proto era
+mkShelleyBlockWithPerasCert = mkShelleyBlockGeneric . SJust
+
+mkShelleyBlockGeneric ::
+  ShelleyCompatible proto era =>
+  StrictMaybe (PerasCert (ShelleyBlock proto era)) ->
+  ShelleyProtocolHeader proto ->
+  BlockBody era ->
+  ShelleyBlock proto era
+mkShelleyBlockGeneric cert header body =
   ShelleyBlock
-    { shelleyBlockRaw = raw
-    , shelleyBlockHeaderHash = pHeaderHash $ SL.bheader raw
+    { shelleyBlockHeader = header
+    , shelleyBlockBody = body
+    , shelleyBlockPerasCert = cert
+    , shelleyBlockHeaderHash = pHeaderHash header
     }
 
 class
@@ -198,10 +245,10 @@ instance
   ShowProxy (Header (ShelleyBlock proto era))
 
 instance ShelleyCompatible proto era => GetHeader (ShelleyBlock proto era) where
-  getHeader (ShelleyBlock rawBlk hdrHash) =
+  getHeader block =
     ShelleyHeader
-      { shelleyHeaderRaw = SL.bheader rawBlk
-      , shelleyHeaderHash = hdrHash
+      { shelleyHeaderRaw = shelleyBlockHeader block
+      , shelleyHeaderHash = shelleyBlockHeaderHash block
       }
 
   blockMatchesHeader hdr blk =
@@ -210,7 +257,7 @@ instance ShelleyCompatible proto era => GetHeader (ShelleyBlock proto era) where
     SL.hashBlockBody blockBody == pHeaderBodyHash shelleyHdr
    where
     ShelleyHeader{shelleyHeaderRaw = shelleyHdr} = hdr
-    ShelleyBlock{shelleyBlockRaw = SL.Block _ blockBody} = blk
+    ShelleyBlock{shelleyBlockBody = blockBody} = blk
 
   headerIsEBB = const Nothing
 
@@ -288,10 +335,35 @@ instance HasNestedContent f (ShelleyBlock proto era)
 
 instance ShelleyCompatible proto era => EncCBOR (ShelleyBlock proto era) where
   -- Don't encode the header hash, we recompute it during deserialisation
-  encCBOR = encCBOR . shelleyBlockRaw
+  encCBOR block = do
+    let header = shelleyBlockHeader block
+    let body = shelleyBlockBody block
+    let bodyLen = listLen body
+    case shelleyBlockPerasCert block of
+      SNothing ->
+        encodeListLen (1 + bodyLen)
+          <> encCBOR header
+          <> encCBORGroup body
+      SJust cert ->
+        encodeListLen (1 + bodyLen + 1)
+          <> encCBOR header
+          <> encCBORGroup body
+          <> encCBOR (encode cert)
 
 instance ShelleyCompatible proto era => DecCBOR (Annotator (ShelleyBlock proto era)) where
-  decCBOR = fmap mkShelleyBlock <$> decCBOR
+  decCBOR = do
+    len <- decodeListLen
+    header <- decCBOR
+    body <- decCBOR
+    cert <- decMaybeCertOrFail len
+    pure $ mkShelleyBlockGeneric <$> cert <*> header <*> body
+   where
+    bodyLen = fromIntegral (numSegComponents @era)
+
+    decMaybeCertOrFail len
+      | len == 1 + bodyLen = pure <$> pure SNothing
+      | len == 1 + bodyLen + 1 = pure <$> (SJust <$> fromPlainDecoder decode)
+      | otherwise = cborError $ Plain.DecoderErrorCustom "ShelleyBlock" "invalid number of elements"
 
 instance ShelleyCompatible proto era => EncCBOR (Header (ShelleyBlock proto era)) where
   -- Don't encode the header hash, we recompute it during deserialisation
@@ -342,7 +414,7 @@ decodeShelleyHeader = eraDecoder @era $ (. Full) . runAnnotator <$> decCBOR
 -------------------------------------------------------------------------------}
 
 instance ShelleyCompatible proto era => Condense (ShelleyBlock proto era) where
-  condense = show . shelleyBlockRaw
+  condense = show . ((shelleyBlockHeader &&& shelleyBlockBody) &&& shelleyBlockPerasCert)
 
 instance ShelleyCompatible proto era => Condense (Header (ShelleyBlock proto era)) where
   condense = show . shelleyHeaderRaw

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs

@@ -8,7 +8,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where
 
 import qualified Cardano.Ledger.Core as Core (Tx)
 import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL)
-import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
+import qualified Cardano.Ledger.Shelley.API as SL (extractTx)
 import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize)
 import qualified Cardano.Protocol.TPraos.BHeader as SL
 import Control.Exception
@@ -72,7 +72,7 @@ forgeShelleyBlock
         (SL.hashBlockBody @era body)
         actualBodySize
         protocolVersion
-    let blk = mkShelleyBlock $ SL.Block hdr body
+    let blk = mkShelleyBlock hdr body
     return $
       assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus cfg) blk) $
         blk

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -93,7 +93,7 @@ import qualified Codec.CBOR.Decoding as CBOR
 import Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import Codec.Serialise (decode, encode)
-import Control.Arrow (left, second)
+import Control.Arrow (Arrow (..), left, second)
 import qualified Control.Exception as Exception
 import Control.Monad.Except
 import qualified Control.State.Transition.Extended as STS
@@ -113,6 +113,7 @@ import Ouroboros.Consensus.Config
 import Ouroboros.Consensus.HardFork.Abstract
 import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import qualified Ouroboros.Consensus.HardFork.History as HardFork
+import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..))
 import Ouroboros.Consensus.HardFork.History.Util
 import Ouroboros.Consensus.HardFork.Simple
 import Ouroboros.Consensus.HeaderValidation
@@ -168,6 +169,8 @@ shelleyEraParams genesis =
     , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis
     , eraSafeZone = HardFork.StandardSafeZone stabilityWindow
     , eraGenesisWin = GenesisWindow stabilityWindow
+    , -- TODO(geo2a): enabled Peras conditionally in the Dijkstra era
+      eraPerasRoundLength = HardFork.NoPerasEnabled
     }
  where
   stabilityWindow =
@@ -183,6 +186,7 @@ shelleyEraParamsNeverHardForks genesis =
     , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis
     , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone
     , eraGenesisWin = GenesisWindow stabilityWindow
+    , eraPerasRoundLength = HardFork.NoPerasEnabled
     }
  where
   stabilityWindow =
@@ -584,7 +588,7 @@ instance
     LedgerTables
       . KeysMK
       . Core.neededTxInsForBlock
-      . shelleyBlockRaw
+      . fromShelleyBlock
 
 data ShelleyReapplyException
   = forall era.
@@ -628,10 +632,7 @@ applyHelper f cfg blk stBefore = do
     f
       globals
       tickedShelleyLedgerState
-      ( let b = shelleyBlockRaw blk
-            h' = mkHeaderView (SL.bheader b)
-         in SL.Block h' (SL.bbody b)
-      )
+      (SL.Block (mkHeaderView (shelleyBlockHeader blk)) (shelleyBlockBody blk))
 
   let track ::
         LedgerState (ShelleyBlock proto era) ValuesMK ->