From b27c72e9c18cfecfa79ded5d3613bc3292800b33 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 11 Sep 2025 11:34:38 +0200 Subject: [PATCH 01/35] Basic Peras types: `PerasCert`, `PerasWeightSnapshot` Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- docs/website/contents/references/glossary.md | 13 + ouroboros-consensus/ouroboros-consensus.cabal | 2 + .../Ouroboros/Consensus/Block.hs | 1 + .../Consensus/Block/SupportsPeras.hs | 185 +++++++++++ .../Ouroboros/Consensus/Peras/Weight.hs | 302 ++++++++++++++++++ .../Test/Util/Orphans/ToExpr.hs | 8 + 6 files changed, 511 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs diff --git a/docs/website/contents/references/glossary.md b/docs/website/contents/references/glossary.md index 3035ccae69..f547be3d1f 100644 --- a/docs/website/contents/references/glossary.md +++ b/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. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 0314c178bd..4736e3d96f 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -83,6 +83,7 @@ library Ouroboros.Consensus.Block.RealPoint Ouroboros.Consensus.Block.SupportsDiffusionPipelining Ouroboros.Consensus.Block.SupportsMetrics + Ouroboros.Consensus.Block.SupportsPeras Ouroboros.Consensus.Block.SupportsProtocol Ouroboros.Consensus.Block.SupportsSanityCheck Ouroboros.Consensus.BlockchainTime @@ -197,6 +198,7 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId + Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract Ouroboros.Consensus.Protocol.BFT Ouroboros.Consensus.Protocol.LeaderSchedule diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs index 0ee718be4a..7c8b020e33 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block.hs @@ -8,5 +8,6 @@ import Ouroboros.Consensus.Block.NestedContent as X import Ouroboros.Consensus.Block.RealPoint as X import Ouroboros.Consensus.Block.SupportsDiffusionPipelining as X import Ouroboros.Consensus.Block.SupportsMetrics as X +import Ouroboros.Consensus.Block.SupportsPeras as X import Ouroboros.Consensus.Block.SupportsProtocol as X import Ouroboros.Consensus.Block.SupportsSanityCheck as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs new file mode 100644 index 0000000000..bdfd9c826c --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.Block.SupportsPeras + ( PerasRoundNo (..) + , PerasWeight (..) + , boostPerCert + , BlockSupportsPeras (..) + , PerasCert (..) + , ValidatedPerasCert (..) + , makePerasCfg + , HasPerasCert (..) + , getPerasCertRound + , getPerasCertBoostedBlock + , getPerasCertBoost + + -- * Ouroboros Peras round length + , PerasRoundLength (..) + , defaultPerasRoundLength + ) where + +import Codec.Serialise (Serialise (..)) +import Codec.Serialise.Decoding (decodeListLenOf) +import Codec.Serialise.Encoding (encodeListLen) +import Data.Monoid (Sum (..)) +import Data.Proxy (Proxy (..)) +import Data.Word (Word64) +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Util.Condense +import Quiet (Quiet (..)) + +newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} + deriving Show via Quiet PerasRoundNo + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Serialise) + +instance Condense PerasRoundNo where + condense = show . unPerasRoundNo + +instance ShowProxy PerasRoundNo where + showProxy _ = "PerasRoundNo" + +newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} + deriving Show via Quiet PerasWeight + deriving stock Generic + deriving newtype (Eq, Ord, NoThunks) + deriving (Semigroup, Monoid) via Sum Word64 + +instance Condense PerasWeight where + condense = show . unPerasWeight + +-- | TODO: this will become a Ledger protocol parameter +-- see https://github.com/tweag/cardano-peras/issues/119 +boostPerCert :: PerasWeight +boostPerCert = PerasWeight 15 + +-- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module? +data ValidatedPerasCert blk = ValidatedPerasCert + { vpcCert :: !(PerasCert blk) + , vpcCertBoost :: !PerasWeight + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + +{------------------------------------------------------------------------------- + Ouroboros Peras round length +-------------------------------------------------------------------------------} + +newtype PerasRoundLength = PerasRoundLength {unPerasRoundLength :: Word64} + deriving stock (Show, Eq, Ord) + deriving newtype (NoThunks, Num) + +-- | See the Protocol parameters section of the Peras design report: +-- https://tweag.github.io/cardano-peras/peras-design.pdf#section.2.1 +-- TODO: this will become a Ledger protocol parameter +-- see https://github.com/tweag/cardano-peras/issues/119 +defaultPerasRoundLength :: PerasRoundLength +defaultPerasRoundLength = 90 + +class + ( Show (PerasCfg blk) + , NoThunks (PerasCert blk) + ) => + BlockSupportsPeras blk + where + data PerasCfg blk + + data PerasCert blk + + data PerasValidationErr blk + + validatePerasCert :: + PerasCfg blk -> + PerasCert blk -> + Either (PerasValidationErr blk) (ValidatedPerasCert blk) + +-- TODO: degenerate instance for all blks to get things to compile +-- see https://github.com/tweag/cardano-peras/issues/73 +instance StandardHash blk => BlockSupportsPeras blk where + newtype PerasCfg blk = PerasCfg + { -- TODO: eventually, this will come from the + -- protocol parameters from the ledger state + -- see https://github.com/tweag/cardano-peras/issues/119 + perasCfgWeightBoost :: PerasWeight + } + deriving stock (Show, Eq) + + data PerasCert blk = PerasCert + { pcCertRound :: PerasRoundNo + , pcCertBoostedBlock :: Point blk + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + + -- TODO: enrich with actual error types + -- see https://github.com/tweag/cardano-peras/issues/120 + data PerasValidationErr blk + = PerasValidationErr + deriving stock (Show, Eq) + + -- TODO: perform actual validation against all + -- possible 'PerasValidationErr' variants + -- see https://github.com/tweag/cardano-peras/issues/120 + validatePerasCert cfg cert = + Right + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasCfgWeightBoost cfg + } + +instance ShowProxy blk => ShowProxy (PerasCert blk) where + showProxy _ = "PerasCert " <> showProxy (Proxy @blk) + +instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where + encode PerasCert{pcCertRound, pcCertBoostedBlock} = + encodeListLen 2 + <> encode pcCertRound + <> encode pcCertBoostedBlock + decode = do + decodeListLenOf 2 + pcCertRound <- decode + pcCertBoostedBlock <- decode + pure $ PerasCert{pcCertRound, pcCertBoostedBlock} + +-- | Derive a 'PerasCfg' from a 'BlockConfig' +-- +-- TODO: this currently doesn't depend on 'BlockConfig' at all, but likely will +-- depend on it in the future +-- see https://github.com/tweag/cardano-peras/issues/73 +makePerasCfg :: Maybe (BlockConfig blk) -> PerasCfg blk +makePerasCfg _ = + PerasCfg + { perasCfgWeightBoost = boostPerCert + } + +class StandardHash blk => HasPerasCert cert blk where + getPerasCert :: cert blk -> PerasCert blk + +instance StandardHash blk => HasPerasCert PerasCert blk where + getPerasCert = id + +instance StandardHash blk => HasPerasCert ValidatedPerasCert blk where + getPerasCert = vpcCert + +getPerasCertRound :: HasPerasCert cert blk => cert blk -> PerasRoundNo +getPerasCertRound = pcCertRound . getPerasCert + +getPerasCertBoostedBlock :: HasPerasCert cert blk => cert blk -> Point blk +getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert + +getPerasCertBoost :: ValidatedPerasCert blk -> PerasWeight +getPerasCertBoost = vpcCertBoost diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs new file mode 100644 index 0000000000..5e2da40bb7 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Data structure for tracking the weight of blocks due to Peras boosts. +module Ouroboros.Consensus.Peras.Weight + ( -- * 'PerasWeightSnapshot' type + PerasWeightSnapshot + + -- * Construction + , emptyPerasWeightSnapshot + , mkPerasWeightSnapshot + + -- * Conversion + , perasWeightSnapshotToList + + -- * Insertion + , addToPerasWeightSnapshot + + -- * Pruning + , prunePerasWeightSnapshot + + -- * Query + , weightBoostOfPoint + , weightBoostOfFragment + , totalWeightOfFragment + ) where + +import Data.Foldable as Foldable (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF + +-- | Data structure for tracking the weight of blocks due to Peras boosts. +newtype PerasWeightSnapshot blk = PerasWeightSnapshot + { getPerasWeightSnapshot :: Map (Point blk) PerasWeight + } + deriving stock Eq + deriving Generic + deriving newtype NoThunks + +instance StandardHash blk => Show (PerasWeightSnapshot blk) where + show = show . perasWeightSnapshotToList + +-- | An empty 'PerasWeightSnapshot' not containing any boosted blocks. +emptyPerasWeightSnapshot :: PerasWeightSnapshot blk +emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty + +-- | Create a weight snapshot from a list of boosted points with an associated +-- weight. In case of duplicate points, their weights are combined. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- >>> snap +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +mkPerasWeightSnapshot :: + StandardHash blk => + [(Point blk, PerasWeight)] -> + PerasWeightSnapshot blk +mkPerasWeightSnapshot = + Foldable.foldl' + (\s (pt, weight) -> addToPerasWeightSnapshot pt weight s) + emptyPerasWeightSnapshot + +-- | Return the list of boosted points with their associated weight, sorted +-- based on their point. Does not contain duplicate points. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- >>> perasWeightSnapshotToList snap +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)] +perasWeightSnapshotToList = Map.toAscList . getPerasWeightSnapshot + +-- | Add weight for the given point to the 'PerasWeightSnapshot'. If the point +-- already has some weight, it is added on top. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- ] +-- :} +-- +-- >>> snap0 = mkPerasWeightSnapshot weights +-- >>> snap0 +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2)] +-- +-- >>> snap1 = addToPerasWeightSnapshot (BlockPoint 3 "bar") (PerasWeight 2) snap0 +-- >>> snap1 +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +-- +-- >>> snap2 = addToPerasWeightSnapshot (BlockPoint 2 "foo") (PerasWeight 2) snap1 +-- >>> snap2 +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +addToPerasWeightSnapshot :: + StandardHash blk => + Point blk -> + PerasWeight -> + PerasWeightSnapshot blk -> + PerasWeightSnapshot blk +addToPerasWeightSnapshot pt weight = + PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot + +-- | Prune the given 'PerasWeightSnapshot' by removing the weight of all blocks +-- strictly older than the given slot. +-- +-- This function is used to get garbage-collect boosted blocks blocks which are +-- older than our immutable tip as we will never adopt a chain containing them. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- +-- >>> prunePerasWeightSnapshot (SlotNo 2) snap +-- [(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +-- +-- >>> prunePerasWeightSnapshot (SlotNo 3) snap +-- [(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] +prunePerasWeightSnapshot :: + SlotNo -> + PerasWeightSnapshot blk -> + PerasWeightSnapshot blk +prunePerasWeightSnapshot slot = + PerasWeightSnapshot . Map.dropWhileAntitone isTooOld . getPerasWeightSnapshot + where + isTooOld :: Point blk -> Bool + isTooOld pt = pointSlot pt < NotOrigin slot + +-- | Get the weight boost for a point, or @'mempty' :: 'PerasWeight'@ otherwise. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> snap = mkPerasWeightSnapshot weights +-- +-- >>> weightBoostOfPoint snap (BlockPoint 2 "foo") +-- PerasWeight 4 +-- +-- >>> weightBoostOfPoint snap (BlockPoint 2 "baz") +-- PerasWeight 0 +weightBoostOfPoint :: + forall blk. + StandardHash blk => + PerasWeightSnapshot blk -> Point blk -> PerasWeight +weightBoostOfPoint (PerasWeightSnapshot weightByPoint) pt = + Map.findWithDefault mempty pt weightByPoint + +-- | Get the weight boost for a fragment, ie the sum of all +-- 'weightBoostOfPoint' for all points on the fragment (excluding the anchor). +-- +-- Note that this quantity is relative to the anchor of the fragment, so it +-- should only be compared against other fragments with the same anchor. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> :{ +-- snap = mkPerasWeightSnapshot weights +-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo" +-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar" +-- frag0 :: AnchoredFragment (HeaderFields Blk) +-- frag0 = Empty AnchorGenesis :> foo :> bar +-- :} +-- +-- >>> weightBoostOfFragment snap frag0 +-- PerasWeight 6 +-- +-- Only keeping the last block from @frag0@: +-- +-- >>> frag1 = AF.anchorNewest 1 frag0 +-- >>> weightBoostOfFragment snap frag1 +-- PerasWeight 2 +-- +-- Dropping the head from @frag0@, and instead adding an unboosted point: +-- +-- >>> frag2 = AF.dropNewest 1 frag0 :> HeaderFields (SlotNo 4) (BlockNo 2) "baz" +-- >>> weightBoostOfFragment snap frag2 +-- PerasWeight 4 +weightBoostOfFragment :: + forall blk h. + (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => + PerasWeightSnapshot blk -> + AnchoredFragment h -> + PerasWeight +weightBoostOfFragment weightSnap frag + | Map.null $ getPerasWeightSnapshot weightSnap = + mempty + | otherwise = + -- TODO: think about whether this could be done in sublinear complexity + -- see https://github.com/IntersectMBO/ouroboros-consensus/pull/1613 + foldMap + (weightBoostOfPoint weightSnap . castPoint . blockPoint) + (AF.toOldestFirst frag) + +-- | Get the total weight for a fragment, ie the length plus the weight boost +-- ('weightBoostOfFragment') of the fragment. +-- +-- Note that this quantity is relative to the anchor of the fragment, so it +-- should only be compared against other fragments with the same anchor. +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- :} +-- +-- >>> :{ +-- snap = mkPerasWeightSnapshot weights +-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo" +-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar" +-- frag0 :: AnchoredFragment (HeaderFields Blk) +-- frag0 = Empty AnchorGenesis :> foo :> bar +-- :} +-- +-- >>> totalWeightOfFragment snap frag0 +-- PerasWeight 8 +-- +-- Only keeping the last block from @frag0@: +-- +-- >>> frag1 = AF.anchorNewest 1 frag0 +-- >>> totalWeightOfFragment snap frag1 +-- PerasWeight 3 +-- +-- Dropping the head from @frag0@, and instead adding an unboosted point: +-- +-- >>> frag2 = AF.dropNewest 1 frag0 :> HeaderFields (SlotNo 4) (BlockNo 2) "baz" +-- >>> totalWeightOfFragment snap frag2 +-- PerasWeight 6 +totalWeightOfFragment :: + forall blk h. + (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => + PerasWeightSnapshot blk -> + AnchoredFragment h -> + PerasWeight +totalWeightOfFragment weightSnap frag = + weightLength <> weightBoost + where + weightLength = PerasWeight $ fromIntegral $ AF.length frag + weightBoost = weightBoostOfFragment weightSnap frag + +-- $setup +-- >>> import Cardano.Ledger.BaseTypes +-- >>> import Ouroboros.Consensus.Block +-- >>> import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq(..), Anchor(..)) +-- >>> import qualified Ouroboros.Network.AnchoredFragment as AF +-- >>> :set -XDataKinds -XTypeApplications -XTypeFamilies +-- >>> data Blk = Blk +-- >>> type instance HeaderHash Blk = String +-- >>> instance StandardHash Blk diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 6830141290..e5560f70f8 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -119,6 +119,14 @@ instance ToExpr FsError where deriving instance ToExpr a => ToExpr (LoE a) +deriving anyclass instance ToExpr PerasRoundNo + +deriving anyclass instance ToExpr PerasWeight + +deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk) + +deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk) + {------------------------------------------------------------------------------- si-timers --------------------------------------------------------------------------------} From c723d721d43e3336e1f05672f5fc25f5264ab9b1 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 11 Sep 2025 11:42:39 +0200 Subject: [PATCH 02/35] Add tests for `PerasWeightSnapshot` Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../test/consensus-test/Main.hs | 2 + .../Test/Consensus/Peras/WeightSnapshot.hs | 139 ++++++++++++++++++ 3 files changed, 142 insertions(+) create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 4736e3d96f..0cb678f240 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -598,6 +598,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ChainSync.CSJ Test.Consensus.MiniProtocol.ChainSync.Client Test.Consensus.MiniProtocol.LocalStateQuery.Server + Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.Versioned diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 88681b82fa..beddd1f7d2 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -16,6 +16,7 @@ import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests) import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests) +import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.Versioned (tests) import Test.Tasty @@ -43,6 +44,7 @@ tests = , Test.Consensus.Mempool.Fairness.tests , Test.Consensus.Mempool.StateMachine.tests ] + , Test.Consensus.Peras.WeightSnapshot.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , testGroup diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs new file mode 100644 index 0000000000..f192cd8f18 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +#if __GLASGOW_HASKELL__ >= 910 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif + +-- | Test that 'PerasWeightSnapshot' can correctly compute the weight of points +-- and fragments. +module Test.Consensus.Peras.WeightSnapshot (tests) where + +import Data.Containers.ListUtils (nubOrd) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Traversable (for) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Util.Condense +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF +import qualified Ouroboros.Network.Mock.Chain as Chain +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util.Orphans.Arbitrary () +import Test.Util.QuickCheck +import Test.Util.TestBlock + +tests :: TestTree +tests = + testGroup + "PerasWeightSnapshot" + [ testProperty "correctness" prop_perasWeightSnapshot + ] + +prop_perasWeightSnapshot :: TestSetup -> Property +prop_perasWeightSnapshot testSetup = + tabulate "logâ‚‚ # of points" [show $ round @Double @Int $ logBase 2 (fromIntegral (length tsPoints))] + . counterexample ("PerasWeightSnapshot: " <> show snap) + $ conjoin + [ conjoin + [ counterexample ("Incorrect weight for " <> condense pt) $ + weightBoostOfPointReference pt =:= weightBoostOfPoint snap pt + | pt <- tsPoints + ] + , conjoin + [ counterexample ("Incorrect weight for " <> condense frag) $ + weightBoostOfFragmentReference frag =:= weightBoostOfFragment snap frag + | frag <- tsFragments + ] + ] + where + TestSetup + { tsWeights + , tsPoints + , tsFragments + } = testSetup + + snap = mkPerasWeightSnapshot $ Map.toList tsWeights + + weightBoostOfPointReference :: Point TestBlock -> PerasWeight + weightBoostOfPointReference pt = Map.findWithDefault mempty pt tsWeights + + weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight + weightBoostOfFragmentReference frag = + foldMap + (weightBoostOfPointReference . blockPoint) + (AF.toOldestFirst frag) + +data TestSetup = TestSetup + { tsWeights :: Map (Point TestBlock) PerasWeight + , tsPoints :: [Point TestBlock] + -- ^ Check the weight of these points. + , tsFragments :: [AnchoredFragment TestBlock] + -- ^ Check the weight of these fragments. + } + deriving stock Show + +instance Arbitrary TestSetup where + arbitrary = do + tree :: BlockTree <- arbitrary + let tsPoints = nubOrd $ GenesisPoint : (blockPoint <$> treeToBlocks tree) + treeChains = treeToChains tree + tsWeights <- do + boostedChain <- elements treeChains + let boostablePts = + GenesisPoint : (blockPoint <$> Chain.toOldestFirst boostedChain) + Map.fromList . catMaybes <$> for boostablePts \pt -> do + weight <- + frequency + [ (3, pure Nothing) + , (1, Just . PerasWeight <$> choose (1, 10)) + ] + pure $ (pt,) <$> weight + tsFragments <- for treeChains \chain -> do + let lenChain = Chain.length chain + fullFrag = Chain.toAnchoredFragment chain + nTakeNewest <- choose (0, lenChain) + nDropNewest <- choose (0, nTakeNewest) + pure $ + AF.dropNewest nDropNewest $ + AF.anchorNewest (fromIntegral nTakeNewest) fullFrag + pure + TestSetup + { tsWeights + , tsPoints + , tsFragments + } + + shrink ts = + concat + [ [ ts{tsWeights = Map.fromList tsWeights'} + | tsWeights' <- + shrinkList + -- Shrink boosted points to have weight 1. + (\(pt, w) -> [(pt, w1) | w1 /= w]) + $ Map.toList tsWeights + ] + , [ ts{tsPoints = tsPoints'} + | tsPoints' <- shrinkList (\_pt -> []) tsPoints + ] + , [ ts{tsFragments = tsFragments'} + | tsFragments' <- shrinkList (\_frag -> []) tsFragments + ] + ] + where + w1 = PerasWeight 1 + + TestSetup + { tsWeights + , tsPoints + , tsFragments + } = ts From 5a9665550923e9e6943135e8b2cb8b01f2cfbdf9 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 11 Sep 2025 12:06:17 +0200 Subject: [PATCH 03/35] Add microbenchmarks for `PerasWeightSnapshot` Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- docs/website/contents/howtos/benchmarks.md | 32 ++++++ .../bench/PerasCertDB-bench/Main.hs | 102 ++++++++++++++++++ ouroboros-consensus/ouroboros-consensus.cabal | 13 +++ 3 files changed, 147 insertions(+) create mode 100644 docs/website/contents/howtos/benchmarks.md create mode 100644 ouroboros-consensus/bench/PerasCertDB-bench/Main.hs diff --git a/docs/website/contents/howtos/benchmarks.md b/docs/website/contents/howtos/benchmarks.md new file mode 100644 index 0000000000..94ce7fc0c7 --- /dev/null +++ b/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. diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs new file mode 100644 index 0000000000..40642021d4 --- /dev/null +++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +-- | This module contains benchmarks for Peras chain weight calculation as +-- implemented by the by the +-- 'Ouroboros.Consensus.Peras.Weight.weightBoostOfFragment' function. +-- +-- We benchmark the calculation on a static sequence of chain fragments of increasing +-- length, ranging from 0 to around 8640, with a sampling rate of 100. The chain fragments +-- are instantiated with 'TestBlock', and every 5 blocks there is a booster block with +-- weight 15. All parameters are set in 'benchmarkParams'. +module Main (main) where + +import Data.List (iterate') +import Numeric.Natural (Natural) +import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..)) +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , mkPerasWeightSnapshot + , weightBoostOfFragment + ) +import Ouroboros.Network.AnchoredFragment qualified as AF +import Test.Ouroboros.Storage.TestBlock (TestBlock (..), TestBody (..), TestHeader (..)) +import Test.Ouroboros.Storage.TestBlock qualified as TestBlock +import Test.Tasty.Bench + +data BenchmarkParams = BenchmarkParams + { blockRate :: SlotNo + -- ^ How often the fragments will contain blocks, in slots + , fragmentLenghtSamplingRate :: Natural + -- ^ The rate of length increase for generate chain fragments + , fragmentMaxLenght :: Natural + -- ^ the maximum length of a fragment + , boostedBlockRate :: Natural + -- ^ How often boosted blocks occur, in blocks + , boostWeight :: PerasWeight + -- ^ The weight of the boost + } + +benchmarkParams :: BenchmarkParams +benchmarkParams = + BenchmarkParams + { blockRate = 20 + , fragmentLenghtSamplingRate = 100 + , fragmentMaxLenght = 2160 + 3 * 2160 + , boostedBlockRate = 5 + , boostWeight = PerasWeight 15 + } + +main :: IO () +main = + Test.Tasty.Bench.defaultMain $ map benchWeightBoostOfFragment inputs + where + -- NOTE: we do not use the 'env' combinator to set up the test data since + -- it requires 'NFData' for 'AF.AnchoredFragment'. While the necessary + -- instances could be provided, we do not think is necessary for this + -- benchmark, as the input data is rather small. + inputs :: [(Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock))] + inputs = + getEveryN (fragmentLenghtSamplingRate benchmarkParams) $ + take (fromIntegral $ fragmentMaxLenght benchmarkParams) $ + zip [0 ..] $ + zip (map uniformWeightSnapshot fragments) fragments + +benchWeightBoostOfFragment :: + (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark +benchWeightBoostOfFragment (i, (weightSnapshot, fragment)) = + bench ("weightBoostOfFragment of length " <> show i) $ + whnf (weightBoostOfFragment weightSnapshot) fragment + +-- | An infinite list of chain fragments +fragments :: [AF.AnchoredFragment TestBlock] +fragments = iterate' addSuccessorBlock genesisFragment + where + genesisFragment :: AF.AnchoredFragment TestBlock + genesisFragment = AF.Empty AF.AnchorGenesis + + addSuccessorBlock :: AF.AnchoredFragment TestBlock -> AF.AnchoredFragment TestBlock + addSuccessorBlock = \case + AF.Empty _ -> (AF.Empty AF.AnchorGenesis) AF.:> (TestBlock.firstBlock 0 dummyBody) + (xs AF.:> x) -> + let nextBlockSlot = blockRate benchmarkParams + (thSlotNo . testHeader $ x) + in (xs AF.:> x) AF.:> TestBlock.mkNextBlock x nextBlockSlot dummyBody + + dummyBody :: TestBody + dummyBody = TestBody{tbForkNo = 0, tbIsValid = True} + +-- | Given a chain fragment, construct a weight snapshot where there's a boosted block every 90 slots +uniformWeightSnapshot :: AF.AnchoredFragment TestBlock -> PerasWeightSnapshot TestBlock +uniformWeightSnapshot fragment = + let pointsToBoost = + map snd + . getEveryN (boostedBlockRate benchmarkParams) + . zip [0 ..] + . map AF.blockPoint + . AF.toOldestFirst + $ fragment + weights = repeat (boostWeight benchmarkParams) + in mkPerasWeightSnapshot $ pointsToBoost `zip` weights + +getEveryN :: Natural -> [(Natural, a)] -> [(Natural, a)] +getEveryN n = filter (\(i, _) -> (i `mod` n) == 0) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 0cb678f240..b8097608ed 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -830,6 +830,19 @@ benchmark ChainSync-client-bench unstable-consensus-testlib, with-utf8, +benchmark PerasCertDB-bench + import: common-bench + type: exitcode-stdio-1.0 + hs-source-dirs: bench/PerasCertDB-bench + main-is: Main.hs + other-modules: + build-depends: + base, + ouroboros-consensus, + ouroboros-network-api, + tasty-bench, + unstable-consensus-testlib, + test-suite doctest import: common-test main-is: doctest.hs From 01e1c69198841d0d55811dce56085b79dde4585a Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 16 Sep 2025 10:55:37 +0200 Subject: [PATCH 04/35] Add changelog entry Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ..._104805_thomas.bagrel_basic_peras_types.md | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 ouroboros-consensus/changelog.d/20250916_104805_thomas.bagrel_basic_peras_types.md diff --git a/ouroboros-consensus/changelog.d/20250916_104805_thomas.bagrel_basic_peras_types.md b/ouroboros-consensus/changelog.d/20250916_104805_thomas.bagrel_basic_peras_types.md new file mode 100644 index 0000000000..c78b957eef --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250916_104805_thomas.bagrel_basic_peras_types.md @@ -0,0 +1,19 @@ + + +### Breaking + +- Introduce `Ouroboros.Consensus.Block.SupportsPeras` with types related to Peras. + - All new types are re-exported through `Ouroboros.Consensus.Block`. +- Introduce `Ouroboros.Consensus.Peras.Weight` with weight computation related types and functions for chains and fragments. +- Introduce a new benchmark suite `PerasCertDB-bench` +- Add property tests and benchmarks for weight computation on chain and fragments From 13c6bcc88b39813ecba116363f45fb702d38033d Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 11 Sep 2025 12:13:55 +0200 Subject: [PATCH 05/35] Introduce `PerasCertDB` and related types Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 3 + .../Consensus/Storage/PerasCertDB.hs | 4 + .../Consensus/Storage/PerasCertDB/API.hs | 56 ++++ .../Consensus/Storage/PerasCertDB/Impl.hs | 297 ++++++++++++++++++ 4 files changed, 360 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index b8097608ed..552c154d1e 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -264,6 +264,9 @@ library Ouroboros.Consensus.Storage.LedgerDB.V2.Forker Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq + Ouroboros.Consensus.Storage.PerasCertDB + Ouroboros.Consensus.Storage.PerasCertDB.API + Ouroboros.Consensus.Storage.PerasCertDB.Impl Ouroboros.Consensus.Storage.Serialisation Ouroboros.Consensus.Storage.VolatileDB Ouroboros.Consensus.Storage.VolatileDB.API diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs new file mode 100644 index 0000000000..288039b30c --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB.hs @@ -0,0 +1,4 @@ +module Ouroboros.Consensus.Storage.PerasCertDB (module X) where + +import Ouroboros.Consensus.Storage.PerasCertDB.API as X +import Ouroboros.Consensus.Storage.PerasCertDB.Impl as X diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs new file mode 100644 index 0000000000..2d136af38d --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.Storage.PerasCertDB.API + ( PerasCertDB (..) + , AddPerasCertResult (..) + + -- * 'PerasCertSnapshot' + , PerasCertSnapshot (..) + , PerasCertTicketNo + , zeroPerasCertTicketNo + ) where + +import Data.Word (Word64) +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) + +data PerasCertDB m blk = PerasCertDB + { addCert :: ValidatedPerasCert blk -> m AddPerasCertResult + -- ^ Add a Peras certificate to the database. The result indicates whether + -- the certificate was actually added, or if it was already present. + , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) + -- ^ Return the Peras weights in order compare the current selection against + -- potential candidate chains, namely the weights for blocks not older than + -- the current immutable tip. It might contain weights for even older blocks + -- if they have not yet been garbage-collected. + -- + -- The 'Fingerprint' is updated every time a new certificate is added, but it + -- stays the same when certificates are garbage-collected. + , getCertSnapshot :: STM m (PerasCertSnapshot blk) + , garbageCollect :: SlotNo -> m () + -- ^ Garbage-collect state older than the given slot number. + , closeDB :: m () + } + deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk) + +data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB + deriving stock (Show, Eq) + +data PerasCertSnapshot blk = PerasCertSnapshot + { containsCert :: PerasRoundNo -> Bool + -- ^ Do we have the certificate for this round? + , getCertsAfter :: PerasCertTicketNo -> [(ValidatedPerasCert blk, PerasCertTicketNo)] + } + +newtype PerasCertTicketNo = PerasCertTicketNo Word64 + deriving stock Show + deriving newtype (Eq, Ord, Enum, NoThunks) + +zeroPerasCertTicketNo :: PerasCertTicketNo +zeroPerasCertTicketNo = PerasCertTicketNo 0 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs new file mode 100644 index 0000000000..1837900fef --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module Ouroboros.Consensus.Storage.PerasCertDB.Impl + ( -- * Opening + PerasCertDbArgs (..) + , defaultArgs + , openDB + + -- * Trace types + , TraceEvent (..) + + -- * Exceptions + , PerasCertDbError (..) + ) where + +import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Functor ((<&>)) +import Data.Kind (Type) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Storage.PerasCertDB.API +import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Util.CallStack +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.STM + +{------------------------------------------------------------------------------ + Opening the database +------------------------------------------------------------------------------} + +type PerasCertDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type +data PerasCertDbArgs f m blk = PerasCertDbArgs + { pcdbaTracer :: Tracer m (TraceEvent blk) + } + +defaultArgs :: Applicative m => Incomplete PerasCertDbArgs m blk +defaultArgs = + PerasCertDbArgs + { pcdbaTracer = nullTracer + } + +openDB :: + forall m blk. + ( IOLike m + , StandardHash blk + ) => + Complete PerasCertDbArgs m blk -> + m (PerasCertDB m blk) +openDB args = do + pcdbVolatileState <- newTVarIO initialPerasVolatileCertState + let env = + PerasCertDbEnv + { pcdbTracer + , pcdbVolatileState + } + h <- PerasCertDbHandle <$> newTVarIO (PerasCertDbOpen env) + traceWith pcdbTracer OpenedPerasCertDB + pure + PerasCertDB + { addCert = getEnv1 h implAddCert + , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot + , getCertSnapshot = getEnvSTM h implGetCertSnapshot + , garbageCollect = getEnv1 h implGarbageCollect + , closeDB = implCloseDB h + } + where + PerasCertDbArgs + { pcdbaTracer = pcdbTracer + } = args + +{------------------------------------------------------------------------------- + Database state +-------------------------------------------------------------------------------} + +newtype PerasCertDbHandle m blk = PerasCertDbHandle (StrictTVar m (PerasCertDbState m blk)) + +data PerasCertDbState m blk + = PerasCertDbOpen !(PerasCertDbEnv m blk) + | PerasCertDbClosed + deriving stock Generic + deriving anyclass NoThunks + +data PerasCertDbEnv m blk = PerasCertDbEnv + { pcdbTracer :: !(Tracer m (TraceEvent blk)) + , pcdbVolatileState :: !(StrictTVar m (WithFingerprint (PerasVolatileCertState blk))) + -- ^ The 'RoundNo's of all certificates currently in the db. + } + deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDbEnv" (PerasCertDbEnv m blk) + +getEnv :: + (IOLike m, HasCallStack) => + PerasCertDbHandle m blk -> + (PerasCertDbEnv m blk -> m r) -> + m r +getEnv (PerasCertDbHandle varState) f = + readTVarIO varState >>= \case + PerasCertDbOpen env -> f env + PerasCertDbClosed -> throwIO $ ClosedDBError prettyCallStack + +getEnv1 :: + (IOLike m, HasCallStack) => + PerasCertDbHandle m blk -> + (PerasCertDbEnv m blk -> a -> m r) -> + a -> + m r +getEnv1 h f a = getEnv h (\env -> f env a) + +getEnvSTM :: + (IOLike m, HasCallStack) => + PerasCertDbHandle m blk -> + (PerasCertDbEnv m blk -> STM m r) -> + STM m r +getEnvSTM (PerasCertDbHandle varState) f = + readTVar varState >>= \case + PerasCertDbOpen env -> f env + PerasCertDbClosed -> throwIO $ ClosedDBError prettyCallStack + +{------------------------------------------------------------------------------- + API implementation +-------------------------------------------------------------------------------} + +implCloseDB :: IOLike m => PerasCertDbHandle m blk -> m () +implCloseDB (PerasCertDbHandle varState) = + atomically (swapTVar varState PerasCertDbClosed) >>= \case + PerasCertDbOpen PerasCertDbEnv{pcdbTracer} -> do + traceWith pcdbTracer ClosedPerasCertDB + -- DB was already closed. + PerasCertDbClosed -> pure () + +-- TODO: we will need to update this method with non-trivial validation logic +-- see https://github.com/tweag/cardano-peras/issues/120 +implAddCert :: + ( IOLike m + , StandardHash blk + ) => + PerasCertDbEnv m blk -> + ValidatedPerasCert blk -> + m AddPerasCertResult +implAddCert env cert = do + traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt + res <- atomically $ do + WithFingerprint + PerasVolatileCertState + { pvcsCerts + , pvcsWeightByPoint + , pvcsCertsByTicket + , pvcsLastTicketNo + } + fp <- + readTVar pcdbVolatileState + if Map.member roundNo pvcsCerts + then pure PerasCertAlreadyInDB + else do + let pvcsLastTicketNo' = succ pvcsLastTicketNo + writeTVar pcdbVolatileState $ + WithFingerprint + PerasVolatileCertState + { pvcsCerts = + Map.insert roundNo cert pvcsCerts + , -- Note that the same block might be boosted by multiple points. + pvcsWeightByPoint = + addToPerasWeightSnapshot boostedPt (getPerasCertBoost cert) pvcsWeightByPoint + , pvcsCertsByTicket = + Map.insert pvcsLastTicketNo' cert pvcsCertsByTicket + , pvcsLastTicketNo = pvcsLastTicketNo' + } + (succ fp) + pure AddedPerasCertToDB + traceWith pcdbTracer $ case res of + AddedPerasCertToDB -> AddedPerasCert roundNo boostedPt + PerasCertAlreadyInDB -> IgnoredCertAlreadyInDB roundNo boostedPt + pure res + where + PerasCertDbEnv + { pcdbTracer + , pcdbVolatileState + } = env + + boostedPt = getPerasCertBoostedBlock cert + roundNo = getPerasCertRound cert + +implGetWeightSnapshot :: + IOLike m => + PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) +implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} = + fmap pvcsWeightByPoint <$> readTVar pcdbVolatileState + +implGetCertSnapshot :: + IOLike m => + PerasCertDbEnv m blk -> STM m (PerasCertSnapshot blk) +implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} = + readTVar pcdbVolatileState + <&> forgetFingerprint + <&> \PerasVolatileCertState + { pvcsCerts + , pvcsCertsByTicket + } -> + PerasCertSnapshot + { containsCert = \r -> Map.member r pvcsCerts + , getCertsAfter = \ticketNo -> + let (_, certs) = Map.split ticketNo pvcsCertsByTicket + in [(cert, tno) | (tno, cert) <- Map.toAscList certs] + } + +implGarbageCollect :: + forall m blk. + (IOLike m, StandardHash blk) => + PerasCertDbEnv m blk -> SlotNo -> m () +implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = + -- No need to update the 'Fingerprint' as we only remove certificates that do + -- not matter for comparing interesting chains. + atomically $ modifyTVar pcdbVolatileState (fmap gc) + where + gc :: PerasVolatileCertState blk -> PerasVolatileCertState blk + gc + PerasVolatileCertState + { pvcsCerts + , pvcsWeightByPoint + , pvcsLastTicketNo + , pvcsCertsByTicket + } = + PerasVolatileCertState + { pvcsCerts = Map.filter keepCert pvcsCerts + , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint + , pvcsCertsByTicket = Map.filter keepCert pvcsCertsByTicket + , pvcsLastTicketNo = pvcsLastTicketNo + } + where + keepCert cert = + pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slot + +{------------------------------------------------------------------------------- + Implementation-internal types +-------------------------------------------------------------------------------} + +-- | Volatile Peras certificate state, i.e. certificates that could influence +-- chain selection by boosting a volatile block. +data PerasVolatileCertState blk = PerasVolatileCertState + { pvcsCerts :: !(Map PerasRoundNo (ValidatedPerasCert blk)) + -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db. + , pvcsWeightByPoint :: !(PerasWeightSnapshot blk) + -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db. + -- + -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk)) + -- ^ The certificates by 'PerasCertTicketNo'. + -- + -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsLastTicketNo :: !PerasCertTicketNo + -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' + -- otherwise). + } + deriving stock (Show, Generic) + deriving anyclass NoThunks + +initialPerasVolatileCertState :: WithFingerprint (PerasVolatileCertState blk) +initialPerasVolatileCertState = + WithFingerprint + PerasVolatileCertState + { pvcsCerts = Map.empty + , pvcsWeightByPoint = emptyPerasWeightSnapshot + , pvcsCertsByTicket = Map.empty + , pvcsLastTicketNo = zeroPerasCertTicketNo + } + (Fingerprint 0) + +{------------------------------------------------------------------------------- + Trace types +-------------------------------------------------------------------------------} + +data TraceEvent blk + = OpenedPerasCertDB + | ClosedPerasCertDB + | AddingPerasCert PerasRoundNo (Point blk) + | AddedPerasCert PerasRoundNo (Point blk) + | IgnoredCertAlreadyInDB PerasRoundNo (Point blk) + deriving stock (Show, Eq, Generic) + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +data PerasCertDbError + = ClosedDBError PrettyCallStack + deriving stock Show + deriving anyclass Exception From 042378eccef26fef0d7ab531822c99cb1b883c62 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 11 Sep 2025 12:26:34 +0200 Subject: [PATCH 06/35] Add q-s-m tests for `PerasCertDB` Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 3 + .../storage-test/Test/Ouroboros/Storage.hs | 2 + .../Test/Ouroboros/Storage/PerasCertDB.hs | 17 ++ .../Ouroboros/Storage/PerasCertDB/Model.hs | 62 ++++++++ .../Storage/PerasCertDB/StateMachine.hs | 147 ++++++++++++++++++ 5 files changed, 231 insertions(+) create mode 100644 ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs create mode 100644 ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs create mode 100644 ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 552c154d1e..f66cd91d93 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -723,6 +723,9 @@ test-suite storage-test Test.Ouroboros.Storage.LedgerDB.V1.DbChangelog Test.Ouroboros.Storage.LedgerDB.V1.LMDB Test.Ouroboros.Storage.Orphans + Test.Ouroboros.Storage.PerasCertDB + Test.Ouroboros.Storage.PerasCertDB.Model + Test.Ouroboros.Storage.PerasCertDB.StateMachine Test.Ouroboros.Storage.VolatileDB Test.Ouroboros.Storage.VolatileDB.Mock Test.Ouroboros.Storage.VolatileDB.Model diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs index 419d8872a7..1153457c70 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs @@ -5,6 +5,7 @@ module Test.Ouroboros.Storage (tests) where import qualified Test.Ouroboros.Storage.ChainDB as ChainDB import qualified Test.Ouroboros.Storage.ImmutableDB as ImmutableDB import qualified Test.Ouroboros.Storage.LedgerDB as LedgerDB +import qualified Test.Ouroboros.Storage.PerasCertDB as PerasCertDB import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB import Test.Tasty (TestTree, testGroup) @@ -20,4 +21,5 @@ tests = , VolatileDB.tests , LedgerDB.tests , ChainDB.tests + , PerasCertDB.tests ] diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs new file mode 100644 index 0000000000..6a3f06bf90 --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} + +module Test.Ouroboros.Storage.PerasCertDB (tests) where + +import qualified Test.Ouroboros.Storage.PerasCertDB.StateMachine as StateMachine +import Test.Tasty (TestTree, testGroup) + +-- +-- The list of all PerasCertDB tests +-- + +tests :: TestTree +tests = + testGroup + "PerasCertDB" + [ StateMachine.tests + ] diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs new file mode 100644 index 0000000000..f6e7f5cb27 --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Ouroboros.Storage.PerasCertDB.Model + ( Model (..) + , initModel + , openDB + , closeDB + , addCert + , getWeightSnapshot + , garbageCollect + ) where + +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , mkPerasWeightSnapshot + ) + +data Model blk = Model + { certs :: Set (ValidatedPerasCert blk) + , open :: Bool + } + deriving Generic + +deriving instance StandardHash blk => Show (Model blk) + +initModel :: Model blk +initModel = Model{open = False, certs = Set.empty} + +openDB :: Model blk -> Model blk +openDB model = model{open = True} + +closeDB :: Model blk -> Model blk +closeDB _ = Model{open = False, certs = Set.empty} + +addCert :: + StandardHash blk => + Model blk -> ValidatedPerasCert blk -> Model blk +addCert model@Model{certs} cert = + model{certs = Set.insert cert certs} + +getWeightSnapshot :: + StandardHash blk => + Model blk -> PerasWeightSnapshot blk +getWeightSnapshot Model{certs} = + mkPerasWeightSnapshot + [ (getPerasCertBoostedBlock cert, getPerasCertBoost cert) + | cert <- Set.toList certs + ] + +garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk +garbageCollect slot model@Model{certs} = + model{certs = Set.filter keepCert certs} + where + keepCert cert = pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slot diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs new file mode 100644 index 0000000000..cba3925c47 --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where + +import Control.Monad.State +import Control.Tracer (nullTracer) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB +import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), PerasCertDB) +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.STM +import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model +import Test.QuickCheck +import qualified Test.QuickCheck.Monadic as QC +import Test.QuickCheck.StateModel +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util.TestBlock (TestBlock, TestHash (..)) +import Test.Util.TestEnv (adjustQuickCheckTests) + +tests :: TestTree +tests = + testGroup + "PerasCertDB" + [ adjustQuickCheckTests (* 100) $ testProperty "q-d" $ prop_qd + ] + +prop_qd :: Actions Model -> Property +prop_qd actions = QC.monadic f $ property () <$ runActions actions + where + f :: StateT (PerasCertDB IO TestBlock) IO Property -> Property + f = ioProperty . flip evalStateT (error "unreachable") + +newtype Model = Model (Model.Model TestBlock) deriving (Show, Generic) + +instance StateModel Model where + data Action Model a where + OpenDB :: Action Model () + CloseDB :: Action Model () + AddCert :: ValidatedPerasCert TestBlock -> Action Model AddPerasCertResult + GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) + GarbageCollect :: SlotNo -> Action Model () + + arbitraryAction _ (Model model) + | model.open = + frequency + [ (1, pure $ Some CloseDB) + , (20, Some <$> genAddCert) + , (20, pure $ Some GetWeightSnapshot) + , (5, Some . GarbageCollect . SlotNo <$> arbitrary) + ] + | otherwise = pure $ Some OpenDB + where + genAddCert = do + roundNo <- PerasRoundNo <$> arbitrary + boostedBlock <- genPoint + pure $ + AddCert + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = boostedBlock + } + , vpcCertBoost = boostPerCert + } + + genPoint :: Gen (Point TestBlock) + genPoint = + oneof + [ return GenesisPoint + , BlockPoint <$> (SlotNo <$> arbitrary) <*> genHash + ] + where + genHash = TestHash . NE.fromList . getNonEmpty <$> arbitrary + + initialState = Model Model.initModel + + nextState (Model model) action _ = Model $ case action of + OpenDB -> Model.openDB model + CloseDB -> Model.closeDB model + AddCert cert -> Model.addCert model cert + GetWeightSnapshot -> model + GarbageCollect slot -> Model.garbageCollect slot model + + precondition (Model model) = \case + OpenDB -> not model.open + action -> + model.open && case action of + CloseDB -> True + -- Do not add equivocating certificates. + AddCert cert -> all p model.certs + where + p cert' = getPerasCertRound cert /= getPerasCertRound cert' || cert == cert' + GetWeightSnapshot -> True + GarbageCollect _slot -> True + +deriving stock instance Show (Action Model a) +deriving stock instance Eq (Action Model a) + +instance HasVariables (Action Model a) where + getAllVariables _ = mempty + +instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where + perform _ action _ = case action of + OpenDB -> do + perasCertDB <- lift $ PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs nullTracer) + put perasCertDB + CloseDB -> do + perasCertDB <- get + lift $ PerasCertDB.closeDB perasCertDB + AddCert cert -> do + perasCertDB <- get + lift $ PerasCertDB.addCert perasCertDB cert + GetWeightSnapshot -> do + perasCertDB <- get + lift $ atomically $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB + GarbageCollect slot -> do + perasCertDB <- get + lift $ PerasCertDB.garbageCollect perasCertDB slot + + postcondition (Model model, _) (AddCert cert) _ actual = do + let expected + | cert `Set.member` model.certs = PerasCertAlreadyInDB + | otherwise = AddedPerasCertToDB + counterexamplePost $ show expected <> " /= " <> show actual + pure $ expected == actual + postcondition (Model model, _) GetWeightSnapshot _ actual = do + let expected = Model.getWeightSnapshot model + counterexamplePost $ "Model: " <> show expected + counterexamplePost $ "SUT: " <> show actual + pure $ expected == actual + postcondition _ _ _ _ = pure True From 6649e719b5375786f506f0f903e5e40ee09eb82e Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 17 Sep 2025 10:22:52 +0200 Subject: [PATCH 07/35] Add changelog entry Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ...0917_101832_thomas.bagrel_peras_cert_db.md | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 ouroboros-consensus/changelog.d/20250917_101832_thomas.bagrel_peras_cert_db.md diff --git a/ouroboros-consensus/changelog.d/20250917_101832_thomas.bagrel_peras_cert_db.md b/ouroboros-consensus/changelog.d/20250917_101832_thomas.bagrel_peras_cert_db.md new file mode 100644 index 0000000000..8d348d4575 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250917_101832_thomas.bagrel_peras_cert_db.md @@ -0,0 +1,24 @@ + + + + + +### Breaking + +- Added modules `Ouroboros.Consensus.Storage.PerasCertDB{,.API,.Impl}`, notably defining the types`PerasCertDB`, `PerasCertSnapshot` (read-only snapshot of certs contained in the DB), and `AddPerasCertResult`; alongside their respectives methods +- Added modules `Test.Ouroboros.Storage.PerasCertDB{,.StateMachine,.Model}` for q-s-m testing of the `PerasCertDB` datatype. The corresponding tests have been included in the test suite defined by `Test.Ouroboros.Storage` From 03f4f2f99925a07887a8a3128a905b03c16c92c7 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 12:13:24 +0200 Subject: [PATCH 08/35] ChainDB: expose PerasCertDB functionality Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Storage/ChainDB/API.hs | 5 +++++ .../Ouroboros/Consensus/Storage/ChainDB/Impl.hs | 5 +++++ .../Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs | 6 ++++++ 3 files changed, 16 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 303fbcf78e..3631292a7d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -90,6 +90,7 @@ import Ouroboros.Consensus.Storage.LedgerDB , ReadOnlyForker' , Statistics ) +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike @@ -386,6 +387,10 @@ data ChainDB m blk = ChainDB , getStatistics :: m (Maybe Statistics) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. + , addPerasCert :: PerasCert blk -> m () + -- ^ TODO + , getPerasWeightSnapshot :: STM m (PerasWeightSnapshot blk) + -- ^ TODO , closeDB :: m () -- ^ Close the ChainDB -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index e5f7b21014..845bffaa16 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -280,6 +280,11 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , getHeaderStateHistory = getEnvSTM h Query.getHeaderStateHistory , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint , getStatistics = getEnv h Query.getStatistics + , addPerasCert = getEnv1 h $ \cdb@CDB{..} cert -> do + PerasCertDB.addCert cdbPerasCertDB cert + -- TODO trigger chain selection in a more efficient way + waitChainSelectionPromise =<< ChainSel.triggerChainSelectionAsync cdb + , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot } addBlockTestFuse <- newFuse "test chain selection" copyTestFuse <- newFuse "test copy to immutable db" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 821586f745..3fcaf2ab3f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -18,6 +18,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getIsValid , getMaxSlotNo , getPastLedger + , getPerasWeightSnapshot , getReadOnlyForkerAtPoint , getStatistics , getTipBlock @@ -52,6 +53,8 @@ import Ouroboros.Consensus.Storage.ChainDB.Impl.Types import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (eitherToMaybe) @@ -262,6 +265,9 @@ getReadOnlyForkerAtPoint CDB{..} = LedgerDB.getReadOnlyForker cdbLedgerDB getStatistics :: IOLike m => ChainDbEnv m blk -> m (Maybe LedgerDB.Statistics) getStatistics CDB{..} = LedgerDB.getTipStatistics cdbLedgerDB +getPerasWeightSnapshot :: ChainDbEnv m blk -> STM m (PerasWeightSnapshot blk) +getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB + {------------------------------------------------------------------------------- Unifying interface over the immutable DB and volatile DB, but independent of the ledger DB. These functions therefore do not require the entire From dc340fcd84ea301b169b2625270279f8e3183bb9 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 12:13:45 +0200 Subject: [PATCH 09/35] ChainDB: invoke PerasCertDB GC Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 37cfd65e27..273ecd6c53 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -71,6 +71,7 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Query as Query import Ouroboros.Consensus.Storage.ChainDB.Impl.Types import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense @@ -399,6 +400,7 @@ garbageCollectBlocks CDB{..} slotNo = do VolatileDB.garbageCollect cdbVolatileDB slotNo atomically $ do modifyTVar cdbInvalid $ fmap $ Map.filter ((>= slotNo) . invalidBlockSlotNo) + PerasCertDB.garbageCollect cdbPerasCertDB slotNo traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo {------------------------------------------------------------------------------- From 3c74a90360260b5fb4dcb3e09bad34269a5b5384 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 18:37:18 +0200 Subject: [PATCH 10/35] `SecurityParam`: mention weighted nature Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Consensus/Config/SecurityParam.hs | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs index bebe022e8d..2aade1eeb9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Config/SecurityParam.hs @@ -3,24 +3,39 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) where +module Ouroboros.Consensus.Config.SecurityParam + ( SecurityParam (..) + , maxRollbackWeight + ) where import Cardano.Binary import Cardano.Ledger.BaseTypes.NonZero import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.SupportsPeras (PerasWeight (..)) import Quiet -- | Protocol security parameter -- --- We interpret this as the number of rollbacks we support. +-- In longest-chain protocols, we interpret this as the number of rollbacks we +-- support. -- -- i.e., k == 1: we can roll back at most one block -- k == 2: we can roll back at most two blocks, etc -- -- NOTE: This talks about the number of /blocks/ we can roll back, not -- the number of /slots/. +-- +-- In weightiest-chain protocols (Ouroboros Peras), we interpret this as the +-- maximum amount of weight we can roll back. +-- +-- i.e. k == 30: we can roll back at most 30 unweighted blocks, or two blocks +-- each having additional weight 14. newtype SecurityParam = SecurityParam {maxRollbacks :: NonZero Word64} deriving (Eq, Generic, NoThunks, ToCBOR, FromCBOR) deriving Show via Quiet SecurityParam + +-- | The maximum amount of weight we can roll back. +maxRollbackWeight :: SecurityParam -> PerasWeight +maxRollbackWeight = PerasWeight . unNonZero . maxRollbacks From 24aba2bfd8e788bc75a5c09b17a05d2a611c6560 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 15:15:35 +0200 Subject: [PATCH 11/35] O.C.Peras.Weight: add `takeVolatileSuffix` Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Peras/Weight.hs | 81 +++++++++++++++++++ 1 file changed, 81 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs index 5e2da40bb7..eca48344a0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -27,14 +27,17 @@ module Ouroboros.Consensus.Peras.Weight , weightBoostOfPoint , weightBoostOfFragment , totalWeightOfFragment + , takeVolatileSuffix ) where import Data.Foldable as Foldable (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF @@ -291,9 +294,87 @@ totalWeightOfFragment weightSnap frag = weightLength = PerasWeight $ fromIntegral $ AF.length frag weightBoost = weightBoostOfFragment weightSnap frag +-- | Take the longest suffix of the given fragment with total weight +-- ('totalWeightOfFragment') at most @k@. This is the volatile suffix of blocks +-- which are subject to rollback. +-- +-- If the total weight of the input fragment is at least @k@, then the anchor of +-- the output fragment is the most recent point on the input fragment that is +-- buried under at least weight @k@ (also counting the weight boost of that +-- point). +-- +-- >>> :{ +-- weights :: [(Point Blk, PerasWeight)] +-- weights = +-- [ (BlockPoint 2 "foo", PerasWeight 2) +-- , (GenesisPoint, PerasWeight 3) +-- , (BlockPoint 3 "bar", PerasWeight 2) +-- , (BlockPoint 2 "foo", PerasWeight 2) +-- ] +-- snap = mkPerasWeightSnapshot weights +-- foo = HeaderFields (SlotNo 2) (BlockNo 1) "foo" +-- bar = HeaderFields (SlotNo 3) (BlockNo 2) "bar" +-- frag :: AnchoredFragment (HeaderFields Blk) +-- frag = Empty AnchorGenesis :> foo :> bar +-- :} +-- +-- >>> k1 = SecurityParam $ knownNonZeroBounded @1 +-- >>> k3 = SecurityParam $ knownNonZeroBounded @3 +-- >>> k6 = SecurityParam $ knownNonZeroBounded @6 +-- >>> k9 = SecurityParam $ knownNonZeroBounded @9 +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k1 frag +-- [] +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k3 frag +-- [HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}] +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k6 frag +-- [HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}] +-- +-- >>> AF.toOldestFirst $ takeVolatileSuffix snap k9 frag +-- [HeaderFields {headerFieldSlot = SlotNo 2, headerFieldBlockNo = BlockNo 1, headerFieldHash = "foo"},HeaderFields {headerFieldSlot = SlotNo 3, headerFieldBlockNo = BlockNo 2, headerFieldHash = "bar"}] +takeVolatileSuffix :: + forall blk h. + (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => + PerasWeightSnapshot blk -> + -- | The security parameter @k@ is interpreted as a weight. + SecurityParam -> + AnchoredFragment h -> + AnchoredFragment h +takeVolatileSuffix snap secParam frag + | Map.null $ getPerasWeightSnapshot snap = + -- Optimize the case where Peras is disabled. + AF.anchorNewest (unPerasWeight k) frag + | hasAtMostWeightK frag = frag + | otherwise = go 0 lenFrag (AF.Empty $ AF.headAnchor frag) + where + k :: PerasWeight + k = maxRollbackWeight secParam + + hasAtMostWeightK :: AnchoredFragment h -> Bool + hasAtMostWeightK f = totalWeightOfFragment snap f <= k + + lenFrag = fromIntegral $ AF.length frag + + -- Binary search for the longest suffix of @frag@ which 'hasAtMostWeightK'. + go :: + Word64 -> -- lb. The length lb suffix satisfies 'hasAtMostWeightK'. + Word64 -> -- ub. The length ub suffix does not satisfy 'hasAtMostWeightK'. + AnchoredFragment h -> -- The length lb suffix. + AnchoredFragment h + go lb ub lbFrag + | lb + 1 == ub = lbFrag + | hasAtMostWeightK midFrag = go mid ub midFrag + | otherwise = go lb mid lbFrag + where + mid = (lb + ub) `div` 2 + midFrag = AF.anchorNewest mid frag + -- $setup -- >>> import Cardano.Ledger.BaseTypes -- >>> import Ouroboros.Consensus.Block +-- >>> import Ouroboros.Consensus.Config.SecurityParam -- >>> import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq(..), Anchor(..)) -- >>> import qualified Ouroboros.Network.AnchoredFragment as AF -- >>> :set -XDataKinds -XTypeApplications -XTypeFamilies From 40c1756d3761af9c7ecdd00362ee439b0a5e18fc Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 30 Jul 2025 18:33:51 +0200 Subject: [PATCH 12/35] ChainDB.StateMachine: check immutable tip monotonicity Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 21 +++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 4e97810d90..c55fcaadf6 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -1232,16 +1232,33 @@ invariant cfg Model{..} = postcondition :: TestConstraints blk => + TopLevelConfig blk -> Model blk m Concrete -> At Cmd blk m Concrete -> At Resp blk m Concrete -> Logic -postcondition model cmd resp = +postcondition cfg model cmd resp = (toMock (eventAfter ev) resp .== eventMockResp ev) .// "real response didn't match model response" + .&& immutableTipMonotonicity where ev = lockstep model cmd resp + immutableTipMonotonicity = case unAt cmd of + -- When we wipe the VolatileDB (and haven't persisted all immutable blocks), + -- the immutable tip can recede. + WipeVolatileDB -> Top + _ -> + Annotate ("Immutable tip non-monotonicity: " <> show before <> " > " <> show after) $ + Boolean (before <= after) + where + before = immTipBlockNo $ eventBefore ev + after = immTipBlockNo $ eventAfter ev + immTipBlockNo = + Chain.headBlockNo + . Model.immutableChain (configSecurityParam cfg) + . dbModel + semantics :: forall blk. TestConstraints blk => @@ -1271,7 +1288,7 @@ sm loe env genBlock cfg initLedger = { initModel = initModel loe cfg initLedger , transition = transition , precondition = precondition - , postcondition = postcondition + , postcondition = postcondition cfg , generator = Just . generator loe genBlock , shrinker = shrinker , semantics = semantics cfg env From 392eb5dd32e5ab1699238f8da1b15d95b03a2851 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 15:30:09 +0200 Subject: [PATCH 13/35] ChainDB: define `getCurrentChain` in terms of weight Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Consensus/Storage/ChainDB/Impl/Query.hs | 35 ++++++++++++++----- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 3fcaf2ab3f..46ce86beda 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | Queries module Ouroboros.Consensus.Storage.ChainDB.Impl.Query @@ -32,7 +33,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getChainSelStarvation ) where -import Cardano.Ledger.BaseTypes (unNonZero) import Control.ResourceRegistry (ResourceRegistry) import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -44,6 +44,10 @@ import Ouroboros.Consensus.HeaderStateHistory import Ouroboros.Consensus.HeaderValidation (HeaderWithTime) import Ouroboros.Consensus.Ledger.Abstract (EmptyMK) import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , takeVolatileSuffix + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( BlockComponent (..) @@ -86,29 +90,44 @@ import Ouroboros.Network.Protocol.LocalStateQuery.Type getCurrentChain :: forall m blk. ( IOLike m + , StandardHash blk , HasHeader (Header blk) , ConsensusProtocol (BlockProtocol blk) ) => ChainDbEnv m blk -> STM m (AnchoredFragment (Header blk)) -getCurrentChain CDB{..} = - AF.anchorNewest (unNonZero k) . icWithoutTime <$> readTVar cdbChain - where - SecurityParam k = configSecurityParam cdbTopLevelConfig +getCurrentChain cdb@CDB{..} = + getCurrentChainLike cdb $ icWithoutTime <$> readTVar cdbChain -- | Same as 'getCurrentChain', /mutatis mutandi/. getCurrentChainWithTime :: forall m blk. ( IOLike m + , StandardHash blk , HasHeader (HeaderWithTime blk) , ConsensusProtocol (BlockProtocol blk) ) => ChainDbEnv m blk -> STM m (AnchoredFragment (HeaderWithTime blk)) -getCurrentChainWithTime CDB{..} = - AF.anchorNewest (unNonZero k) . icWithTime <$> readTVar cdbChain +getCurrentChainWithTime cdb@CDB{..} = + getCurrentChainLike cdb $ icWithTime <$> readTVar cdbChain + +getCurrentChainLike :: + forall m blk h. + ( IOLike m + , StandardHash blk + , HasHeader h + , HeaderHash blk ~ HeaderHash h + , ConsensusProtocol (BlockProtocol blk) + ) => + ChainDbEnv m blk -> + STM m (AnchoredFragment h) -> + STM m (AnchoredFragment h) +getCurrentChainLike cdb@CDB{..} getCurChain = do + weights <- forgetFingerprint <$> getPerasWeightSnapshot cdb + takeVolatileSuffix weights k <$> getCurChain where - SecurityParam k = configSecurityParam cdbTopLevelConfig + k = configSecurityParam cdbTopLevelConfig -- | Get a 'HeaderStateHistory' populated with the 'HeaderState's of the -- last @k@ blocks of the current chain. From 717f13077a7f5baa23c2a3181dd534bb470d4cce Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 14:36:47 +0200 Subject: [PATCH 14/35] GSM: allow `candidateOverSelection` to be stateful This is in preparation for weighted chain comparisons. Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Node/GSM.hs | 17 ++++++++++++----- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- .../test/consensus-test/Test/Consensus/GSM.hs | 3 ++- .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 2 +- 4 files changed, 16 insertions(+), 8 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs index aa9733d360..780602118b 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs @@ -104,10 +104,16 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView -- thundering herd phenomenon. -- -- 'Nothing' should only be used for testing. - , candidateOverSelection :: - selection -> - chainSyncState -> - CandidateVersusSelection + , getCandidateOverSelection :: + STM + m + ( selection -> + chainSyncState -> + CandidateVersusSelection + ) + -- ^ Whether the candidate from the @chainSyncState@ is preferable to the + -- selection. This can depend on external state (Peras certificates boosting + -- blocks). , peerIsIdle :: chainSyncState -> Bool , durationUntilTooOld :: Maybe (selection -> m DurationFromNow) -- ^ How long from now until the selection will be so old that the node @@ -234,7 +240,7 @@ realGsmEntryPoints tracerArgs gsmView = GsmView { antiThunderingHerd - , candidateOverSelection + , getCandidateOverSelection , peerIsIdle , durationUntilTooOld , equivalent @@ -383,6 +389,7 @@ realGsmEntryPoints tracerArgs gsmView = -- long. selection <- getCurrentSelection candidates <- traverse StrictSTM.readTVar varsState + candidateOverSelection <- getCandidateOverSelection let ok candidate = WhetherCandidateIsBetter False == candidateOverSelection selection candidate diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index f962a1b6ca..e7e57758ee 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -271,7 +271,7 @@ initNodeKernel gsmTracerArgs GSM.GsmView { GSM.antiThunderingHerd = Just gsmAntiThunderingHerd - , GSM.candidateOverSelection = \(headers, _lst) state -> + , GSM.getCandidateOverSelection = pure $ \(headers, _lst) state -> case AF.intersectionPoint headers (csCandidate state) of Nothing -> GSM.CandidateDoesNotIntersect Just{} -> diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs index 4f223c42e1..44a57f4c32 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs @@ -137,7 +137,8 @@ setupGsm isHaaSatisfied vars = do (id, tracer) GSM.GsmView { GSM.antiThunderingHerd = Nothing - , GSM.candidateOverSelection = \s (PeerState c _) -> candidateOverSelection s c + , GSM.getCandidateOverSelection = pure $ \s (PeerState c _) -> + candidateOverSelection s c , GSM.peerIsIdle = isIdling , GSM.durationUntilTooOld = Just durationUntilTooOld , GSM.equivalent = (==) -- unsound, but harmless in this test diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs index fe7383c0f4..63f5e8bea7 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs @@ -279,7 +279,7 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState = GSM.realGsmEntryPoints (id, nullTracer) GSM.GsmView - { GSM.candidateOverSelection + { GSM.getCandidateOverSelection = pure candidateOverSelection , GSM.peerIsIdle = csIdling , GSM.equivalent = (==) `on` AF.headPoint , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles From 1f75990a66a1af6d61901cc4d749ca4903fdc353 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 23 Jul 2025 19:26:54 +0200 Subject: [PATCH 15/35] ChainSel: make `rollbackExceedsSuffix` weight-aware Also remove the version for `ValidatedChainDiff` as it is unused. Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Fragment/Diff.hs | 32 +++++++++++++++---- .../Consensus/Fragment/ValidatedDiff.hs | 4 --- .../Storage/ChainDB/Impl/ChainSel.hs | 12 ++++--- 3 files changed, 34 insertions(+), 14 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs index 1521969d44..1cd42db9de 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs @@ -35,6 +35,7 @@ module Ouroboros.Consensus.Fragment.Diff import Data.Word (Word64) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Network.AnchoredFragment ( AnchoredFragment , AnchoredSeq (..) @@ -73,12 +74,31 @@ getTip = castPoint . AF.headPoint . getSuffix getAnchorPoint :: ChainDiff b -> Point b getAnchorPoint = castPoint . AF.anchorPoint . getSuffix --- | Return 'True' iff applying the 'ChainDiff' to a chain @C@ will result in --- a chain shorter than @C@, i.e., the number of blocks to roll back is --- greater than the length of the new elements in the suffix to add. -rollbackExceedsSuffix :: HasHeader b => ChainDiff b -> Bool -rollbackExceedsSuffix (ChainDiff nbRollback suffix) = - nbRollback > fromIntegral (AF.length suffix) +-- | Return 'True' iff applying the 'ChainDiff' to the given chain @C@ will +-- result in a chain with less weight than @C@, i.e., the suffix of @C@ to roll +-- back has more weight than suffix is adding. +rollbackExceedsSuffix :: + forall b0 b1 b2. + ( HasHeader b0 + , HasHeader b1 + , HasHeader b2 + , HeaderHash b0 ~ HeaderHash b1 + , HeaderHash b0 ~ HeaderHash b2 + ) => + PerasWeightSnapshot b0 -> + -- | The chain @C@ the diff is applied to. + AnchoredFragment b1 -> + ChainDiff b2 -> + Bool +rollbackExceedsSuffix weights curChain (ChainDiff nbRollback suffix) = + weightOf suffixToRollBack > weightOf suffix + where + suffixToRollBack = AF.anchorNewest nbRollback curChain + + weightOf :: + (HasHeader b, HeaderHash b ~ HeaderHash b0) => + AnchoredFragment b -> PerasWeight + weightOf = totalWeightOfFragment weights {------------------------------------------------------------------------------- Constructors diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs index 0d31d8f3fe..0a18a54308 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/ValidatedDiff.hs @@ -13,7 +13,6 @@ module Ouroboros.Consensus.Fragment.ValidatedDiff , getChainDiff , getLedger , new - , rollbackExceedsSuffix , toValidatedFragment -- * Monadic @@ -96,9 +95,6 @@ toValidatedFragment :: toValidatedFragment (UnsafeValidatedChainDiff cs l) = VF.ValidatedFragment (Diff.getSuffix cs) l -rollbackExceedsSuffix :: HasHeader b => ValidatedChainDiff b l -> Bool -rollbackExceedsSuffix = Diff.rollbackExceedsSuffix . getChainDiff - {------------------------------------------------------------------------------- Monadic -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index a16e674b3d..a132da0b67 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -63,6 +63,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) , AddBlockResult (..) @@ -666,10 +667,10 @@ constructPreferableCandidates CDB{..} curChain hdrCache p = do -- Translate the 'HeaderFields' to 'Header' by reading the headers -- from disk. mapM translateToHeaders - -- Filter out candidates that are shorter than the current chain. - -- We don't want to needlessly read the headers from disk for - -- those candidates. - . NE.filter (not . Diff.rollbackExceedsSuffix) + -- Filter out candidates that have less weight than the current + -- chain. We don't want to needlessly read the headers from disk + -- for those candidates. + . NE.filter (not . Diff.rollbackExceedsSuffix weights curChain) -- Extend the diff with candidates fitting on @p@ . Paths.extendWithSuccessors succsOf lookupBlockInfo $ diff @@ -686,6 +687,9 @@ constructPreferableCandidates CDB{..} curChain hdrCache p = do bcfg = configBlock cdbTopLevelConfig k = unNonZero $ maxRollbacks $ configSecurityParam cdbTopLevelConfig + -- TODO use actual weights + weights = emptyPerasWeightSnapshot :: PerasWeightSnapshot blk + curHead = AF.castAnchor $ AF.headAnchor curChain addBlockTracer :: Tracer m (TraceAddBlockEvent blk) From 5f40179da0ae8785efe0ec07466824cd4999715c Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 14:49:11 +0200 Subject: [PATCH 16/35] Introduce weighted chain comparisons Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/NodeKernel.hs | 21 +-- .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 6 +- .../BlockFetch/ClientInterface.hs | 50 +++---- .../MiniProtocol/ChainSync/Client.hs | 8 +- .../Consensus/Storage/ChainDB/Impl.hs | 2 + .../Storage/ChainDB/Impl/ChainSel.hs | 122 ++++++++++++------ .../Consensus/Storage/ChainDB/Impl/Types.hs | 21 +-- .../Consensus/Util/AnchoredFragment.hs | 101 ++++----------- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 6 +- .../Ouroboros/Storage/ChainDB/Model/Test.hs | 7 +- 10 files changed, 171 insertions(+), 173 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index e7e57758ee..1c45c68155 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -271,15 +271,18 @@ initNodeKernel gsmTracerArgs GSM.GsmView { GSM.antiThunderingHerd = Just gsmAntiThunderingHerd - , GSM.getCandidateOverSelection = pure $ \(headers, _lst) state -> - case AF.intersectionPoint headers (csCandidate state) of - Nothing -> GSM.CandidateDoesNotIntersect - Just{} -> - GSM.WhetherCandidateIsBetter $ -- precondition requires intersection - preferAnchoredCandidate - (configBlock cfg) - headers - (csCandidate state) + , GSM.getCandidateOverSelection = do + weights <- ChainDB.getPerasWeightSnapshot chainDB + pure $ \(headers, _lst) state -> + case AF.intersectionPoint headers (csCandidate state) of + Nothing -> GSM.CandidateDoesNotIntersect + Just{} -> + GSM.WhetherCandidateIsBetter $ -- precondition requires intersection + preferAnchoredCandidate + (configBlock cfg) + (forgetFingerprint weights) + headers + (csCandidate state) , GSM.peerIsIdle = csIdling , GSM.durationUntilTooOld = gsmDurationUntilTooOld diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs index 63f5e8bea7..a58923bd60 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE/CaughtUp.hs @@ -58,6 +58,7 @@ import qualified Ouroboros.Consensus.Node.GSM as GSM import Ouroboros.Consensus.Node.Genesis (setGetLoEFragment) import Ouroboros.Consensus.Node.GsmState import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment @@ -301,10 +302,13 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState = Just{} -> -- precondition requires intersection GSM.WhetherCandidateIsBetter $ - preferAnchoredCandidate (configBlock cfg) selection candFrag + preferAnchoredCandidate (configBlock cfg) weights selection candFrag where candFrag = csCandidate candidateState + -- TODO https://github.com/tweag/cardano-peras/issues/67 + weights = emptyPerasWeightSnapshot + forkGDD :: forall m. IOLike m => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index bdf45723e0..89e9f102af 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -33,6 +33,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping +import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise , ChainDB @@ -244,7 +245,7 @@ mkBlockFetchConsensusInterface AnchoredFragment (HeaderWithTime blk) -> AnchoredFragment (HeaderWithTime blk) -> Bool - plausibleCandidateChain ours cand + plausibleCandidateChain ours cand = -- 1. The ChainDB maintains the invariant that the anchor of our fragment -- corresponds to the immutable tip. -- @@ -258,45 +259,24 @@ mkBlockFetchConsensusInterface -- point. This means that we are no longer guaranteed that the -- precondition holds. -- - -- 4. Our chain's anchor can only move forward. We can detect this by - -- looking at the block/slot numbers of the anchors: When the anchor - -- advances, either the block number increases (usual case), or the - -- block number stays the same, but the slot number increases (EBB - -- case). - -- - | anchorBlockNoAndSlot cand < anchorBlockNoAndSlot ours -- (4) - = - case (AF.null ours, AF.null cand) of - -- Both are non-empty, the precondition trivially holds. - (False, False) -> preferAnchoredCandidate bcfg ours cand - -- The candidate is shorter than our chain and, worse, we'd have to - -- roll back past our immutable tip (the anchor of @cand@). - (_, True) -> False - -- As argued above we can only reach this case when our chain's anchor - -- has changed (4). - -- - -- It is impossible for our chain to change /and/ still be empty: the - -- anchor of our chain only changes when a new block becomes - -- immutable. For a new block to become immutable, we must have - -- extended our chain with at least @k + 1@ blocks. Which means our - -- fragment can't be empty. - (True, _) -> error "impossible" - | otherwise = - preferAnchoredCandidate bcfg ours cand - where - anchorBlockNoAndSlot :: - AnchoredFragment (HeaderWithTime blk) -> - (WithOrigin BlockNo, WithOrigin SlotNo) - anchorBlockNoAndSlot frag = - (AF.anchorToBlockNo a, AF.anchorToSlotNo a) - where - a = AF.anchor frag + -- 4. Therefore, we check whether the candidate fragments still intersects + -- with our fragment; if not, then it is only a matter of time until the + -- ChainSync client disconnects from that peer. + case AF.intersectionPoint ours cand of + -- REVIEW: Hmm, maybe we want to change 'preferAnchoredCandidates' to + -- also just return 'False' in this case (and we remove the + -- precondition). + Nothing -> False + Just _ -> preferAnchoredCandidate bcfg weights ours cand compareCandidateChains :: AnchoredFragment (HeaderWithTime blk) -> AnchoredFragment (HeaderWithTime blk) -> Ordering - compareCandidateChains = compareAnchoredFragments bcfg + compareCandidateChains = compareAnchoredFragments bcfg weights + + -- TODO requires https://github.com/IntersectMBO/ouroboros-network/pull/5161 + weights = emptyPerasWeightSnapshot headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime headerForgeUTCTime = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index ec16c91eca..fcb0e25388 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -124,6 +124,7 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Ju import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State import Ouroboros.Consensus.Node.GsmState (GsmState (..)) import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -1833,7 +1834,12 @@ checkTime cfgEnv dynEnv intEnv = checkPreferTheirsOverOurs kis | -- Precondition is fulfilled as ourFrag and theirFrag intersect by -- construction. - preferAnchoredCandidate (configBlock cfg) ourFrag theirFrag = + preferAnchoredCandidate + (configBlock cfg) + -- TODO: remove this entire check, see https://github.com/tweag/cardano-peras/issues/64 + emptyPerasWeightSnapshot + ourFrag + theirFrag = pure () | otherwise = throwSTM $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 845bffaa16..3a3238d906 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -179,6 +179,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do traceWith initChainSelTracer StartedInitChainSelection initialLoE <- Args.cdbsLoE cdbSpecificArgs + initialWeights <- atomically $ PerasCertDB.getWeightSnapshot perasCertDB chain <- withRegistry $ \rr -> do chainAndLedger <- ChainSel.initialChainSelection @@ -190,6 +191,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do (Args.cdbsTopLevelConfig cdbSpecificArgs) varInvalid (void initialLoE) + (forgetFingerprint initialWeights) traceWith initChainSelTracer InitialChainSelected let chain = VF.validatedFragment chainAndLedger diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index a132da0b67..00b2204c73 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -37,7 +37,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Maybe.Strict (StrictMaybe (..), strictMaybeToMaybe) import Data.Set (Set) import qualified Data.Set as Set @@ -63,6 +63,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) @@ -119,6 +120,7 @@ initialChainSelection :: TopLevelConfig blk -> StrictTVar m (WithFingerprint (InvalidBlocks blk)) -> LoE () -> + PerasWeightSnapshot blk -> m (ChainAndLedger m blk) initialChainSelection immutableDB @@ -128,7 +130,8 @@ initialChainSelection tracer cfg varInvalid - loE = do + loE + weights = do -- TODO: Improve the user experience by trimming any potential -- blocks from the future from the VolatileDB. -- @@ -173,7 +176,7 @@ initialChainSelection let curChain = Empty (AF.castAnchor i) curChainAndLedger <- VF.newM curChain curForker - case NE.nonEmpty (filter (preferAnchoredCandidate bcfg curChain) chains) of + case NE.nonEmpty (filter (preferAnchoredCandidate bcfg weights curChain) chains) of -- If there are no candidates, no chain selection is needed Nothing -> return curChainAndLedger Just chains' -> @@ -255,7 +258,7 @@ initialChainSelection chainSelection' curChainAndLedger candidates = atomically (forkerCurrentPoint ledger) >>= \curpt -> assert (all ((curpt ==) . castPoint . AF.anchorPoint) candidates) $ - assert (all (preferAnchoredCandidate bcfg curChain) candidates) $ do + assert (all (preferAnchoredCandidate bcfg weights curChain) candidates) $ do cse <- chainSelEnv chainSelection cse rr (Diff.extend <$> candidates) where @@ -270,6 +273,7 @@ initialChainSelection , bcfg , varInvalid , blockCache = BlockCache.empty + , weights , curChain , validationTracer = InitChainSelValidation >$< tracer , -- initial chain selection is not concerned about pipelining @@ -359,14 +363,15 @@ chainSelSync :: -- blocks that were originally postponed by the LoE, but can be adopted once we -- conclude that we are caught-up (and hence are longer bound by the LoE). chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = lift $ do - (succsOf, lookupBlockInfo, curChain) <- atomically $ do + (succsOf, lookupBlockInfo, curChain, weights) <- atomically $ do invalid <- forgetFingerprint <$> readTVar cdbInvalid - (,,) + (,,,) <$> ( ignoreInvalidSuc cdbVolatileDB invalid <$> VolatileDB.filterByPredecessor cdbVolatileDB ) <*> VolatileDB.getBlockInfo cdbVolatileDB <*> Query.getCurrentChain cdb + <*> (forgetFingerprint <$> Query.getPerasWeightSnapshot cdb) let -- All immediate successor blocks of blocks on the current chain (including -- the anchor), excluding those on the current chain. @@ -381,10 +386,10 @@ chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = lift $ do , not $ AF.pointOnFragment (realPointToPoint loePt) curChain ] - chainSelEnv = mkChainSelEnv cdb BlockCache.empty curChain Nothing + chainSelEnv = mkChainSelEnv cdb BlockCache.empty weights curChain Nothing chainDiffs :: [[ChainDiff (Header blk)]] <- - for loePoints $ constructPreferableCandidates cdb curChain Map.empty + for loePoints $ constructPreferableCandidates cdb weights curChain Map.empty -- Consider all candidates at once, to avoid transient chain switches. case NE.nonEmpty $ concat chainDiffs of @@ -393,7 +398,7 @@ chainSelSync cdb@CDB{..} (ChainSelReprocessLoEBlocks varProcessed) = lift $ do chainSelection chainSelEnv rr chainDiffs' >>= \case Just validatedChainDiff -> -- Switch to the new better chain. - switchTo cdb Nothing validatedChainDiff + switchTo cdb weights Nothing validatedChainDiff Nothing -> pure () Nothing -> pure () @@ -540,11 +545,12 @@ chainSelectionForBlock :: InvalidBlockPunishment m -> Electric m () chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegistry $ \rr -> do - (invalid, curChain) <- + (invalid, curChain, weights) <- atomically $ - (,) + (,,) <$> (forgetFingerprint <$> readTVar cdbInvalid) <*> Query.getCurrentChain cdb + <*> (forgetFingerprint <$> Query.getPerasWeightSnapshot cdb) -- The current chain we're working with here is not longer than @k@ blocks -- (see 'getCurrentChain' and 'cdbChain'), which is easier to reason about @@ -577,13 +583,14 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist chainDiffs <- constructPreferableCandidates cdb + weights curChain (Map.singleton (headerHash hdr) hdr) (headerRealPoint hdr) let noChange = traceWith addBlockTracer $ StoreButDontChange p - chainSelEnv = mkChainSelEnv cdb blockCache curChain (Just (p, punish)) + chainSelEnv = mkChainSelEnv cdb blockCache weights curChain (Just (p, punish)) case NE.nonEmpty chainDiffs of Just chainDiffs' -> do @@ -591,7 +598,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = electric $ withRegist chainSelection chainSelEnv rr chainDiffs' >>= \case Just validatedChainDiff -> -- Switch to the new better chain. - switchTo cdb (Just p) validatedChainDiff + switchTo cdb weights (Just p) validatedChainDiff -- No valid candidate better than our chain. Nothing -> noChange -- No candidate better than our chain. @@ -618,6 +625,7 @@ constructPreferableCandidates :: , BlockSupportsProtocol blk ) => ChainDbEnv m blk -> + PerasWeightSnapshot blk -> -- | The current chain. AnchoredFragment (Header blk) -> -- | Headers already in memory (to avoid loading them from disk). @@ -627,7 +635,7 @@ constructPreferableCandidates :: -- | All candidates involving @p@ (ie containing @p@ in 'getSuffix') which are -- preferable to the current chain. m [ChainDiff (Header blk)] -constructPreferableCandidates CDB{..} curChain hdrCache p = do +constructPreferableCandidates CDB{..} weights curChain hdrCache p = do (succsOf, lookupBlockInfo) <- atomically $ do invalid <- forgetFingerprint <$> readTVar cdbInvalid (,) @@ -678,7 +686,7 @@ constructPreferableCandidates CDB{..} curChain hdrCache p = do | otherwise -> pure [] pure -- Only keep candidates preferable to the current chain. - . filter (preferAnchoredCandidate bcfg curChain . Diff.getSuffix) + . filter (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix) -- Trim fragments so that they follow the LoE, that is, they extend the LoE -- by at most @k@ blocks or are extended by the LoE. . fmap (trimToLoE loeFrag) @@ -687,9 +695,6 @@ constructPreferableCandidates CDB{..} curChain hdrCache p = do bcfg = configBlock cdbTopLevelConfig k = unNonZero $ maxRollbacks $ configSecurityParam cdbTopLevelConfig - -- TODO use actual weights - weights = emptyPerasWeightSnapshot :: PerasWeightSnapshot blk - curHead = AF.castAnchor $ AF.headAnchor curChain addBlockTracer :: Tracer m (TraceAddBlockEvent blk) @@ -796,6 +801,7 @@ switchTo :: , HasCallStack ) => ChainDbEnv m blk -> + PerasWeightSnapshot blk -> -- | Which block we performed chain selection for (if any). This is 'Nothing' -- when reprocessing blocks that were postponed due to the Limit on Eagerness -- (cf 'ChainSelReprocessLoEBlocks'). @@ -803,7 +809,7 @@ switchTo :: -- | Chain and ledger to switch to ValidatedChainDiff (Header blk) (Forker' m blk) -> m () -switchTo CDB{..} triggerPt vChainDiff = do +switchTo CDB{..} weights triggerPt vChainDiff = do traceWith addBlockTracer $ ChangingSelection $ castPoint $ @@ -864,7 +870,11 @@ switchTo CDB{..} triggerPt vChainDiff = do let mkTraceEvent | getRollback (getChainDiff vChainDiff) == 0 = AddedToCurrentChain | otherwise = SwitchedToAFork - selChangedInfo = mkSelectionChangedInfo curChain newChain newLedger + selChangedInfo = + mkSelectionChangedInfo + curChain + (getChainDiff vChainDiff) + newLedger traceWith addBlockTracer $ mkTraceEvent events selChangedInfo curChain newChain whenJust (strictMaybeToMaybe prevTentativeHeader) $ @@ -879,28 +889,29 @@ switchTo CDB{..} triggerPt vChainDiff = do addBlockTracer = TraceAddBlockEvent >$< cdbTracer mkSelectionChangedInfo :: - AnchoredFragment (Header blk) -> - -- \^ old chain - AnchoredFragment (Header blk) -> - -- \^ new chain - ExtLedgerState blk EmptyMK -> - -- \^ new tip + AnchoredFragment (Header blk) -> -- old selection + ChainDiff (Header blk) -> -- diff we are adopting + ExtLedgerState blk EmptyMK -> -- new tip SelectionChangedInfo blk - mkSelectionChangedInfo oldChain newChain newTip = + mkSelectionChangedInfo oldChain diff newTip = SelectionChangedInfo { newTipPoint = castRealPoint tipPoint , newTipEpoch = tipEpoch , newTipSlotInEpoch = tipSlotInEpoch , newTipTrigger = triggerPt - , newTipSelectView - , oldTipSelectView = - selectView (configBlock cfg) - <$> eitherToMaybe (AF.head oldChain) + , newSuffixSelectView + , oldSuffixSelectView = + withEmptyFragmentToMaybe $ + weightedSelectView (configBlock cfg) weights oldSuffix } where cfg :: TopLevelConfig blk cfg = cdbTopLevelConfig + oldSuffix, newSuffix :: AnchoredFragment (Header blk) + oldSuffix = AF.anchorNewest (getRollback diff) oldChain + newSuffix = getSuffix diff + ledger :: LedgerState blk EmptyMK ledger = ledgerState newTip @@ -910,14 +921,13 @@ switchTo CDB{..} triggerPt vChainDiff = do (configLedger cfg) ledger - (tipPoint, (tipEpoch, tipSlotInEpoch), newTipSelectView) = - case AF.head newChain of - Left _anchor -> error "cannot have switched to an empty chain" - Right tipHdr -> + (tipPoint, (tipEpoch, tipSlotInEpoch), newSuffixSelectView) = + case (AF.head newSuffix, weightedSelectView (configBlock cfg) weights newSuffix) of + (Right tipHdr, NonEmptyFragment wsv) -> let query = History.slotToEpoch' (blockSlot tipHdr) tipEpochData = History.runQueryPure query summary - sv = selectView (configBlock cfg) tipHdr - in (blockRealPoint tipHdr, tipEpochData, sv) + in (blockRealPoint tipHdr, tipEpochData, wsv) + _ -> error "cannot have switched via a diff with an empty suffix" -- | Check whether the header for the hash is in the cache, if not, get -- the corresponding header from the VolatileDB and store it in the cache. @@ -947,6 +957,7 @@ data ChainSelEnv m blk = ChainSelEnv , varTentativeHeader :: StrictTVar m (StrictMaybe (Header blk)) , getTentativeFollowers :: STM m [FollowerHandle m blk] , blockCache :: BlockCache blk + , weights :: PerasWeightSnapshot blk , curChain :: AnchoredFragment (Header blk) , punish :: Maybe (RealPoint blk, InvalidBlockPunishment m) -- ^ The block that this chain selection invocation is processing, and the @@ -972,12 +983,14 @@ mkChainSelEnv :: ChainDbEnv m blk -> -- | See 'blockCache' BlockCache blk -> + -- | See 'weights' + PerasWeightSnapshot blk -> -- | See 'curChain' AnchoredFragment (Header blk) -> -- | See 'punish'. Maybe (RealPoint blk, InvalidBlockPunishment m) -> ChainSelEnv m blk -mkChainSelEnv CDB{..} blockCache curChain punish = +mkChainSelEnv CDB{..} blockCache weights curChain punish = ChainSelEnv { lgrDB = cdbLedgerDB , bcfg = configBlock cdbTopLevelConfig @@ -988,6 +1001,7 @@ mkChainSelEnv CDB{..} blockCache curChain punish = filter ((TentativeChain ==) . fhChainType) . Map.elems <$> readTVar cdbFollowers , blockCache + , weights , curChain , validationTracer = TraceAddBlockEvent . AddBlockValidation >$< cdbTracer @@ -1021,7 +1035,7 @@ chainSelection :: chainSelection chainSelEnv rr chainDiffs = assert ( all - (preferAnchoredCandidate bcfg curChain . Diff.getSuffix) + (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix) chainDiffs ) $ assert @@ -1034,8 +1048,7 @@ chainSelection chainSelEnv rr chainDiffs = ChainSelEnv{..} = chainSelEnv sortCandidates :: [ChainDiff (Header blk)] -> [ChainDiff (Header blk)] - sortCandidates = - sortBy (flip (compareAnchoredFragments bcfg) `on` Diff.getSuffix) + sortCandidates = sortBy (flip $ compareChainDiffs bcfg weights curChain) -- 1. Take the first candidate from the list of sorted candidates -- 2. Validate it @@ -1071,7 +1084,7 @@ chainSelection chainSelEnv rr chainDiffs = -- it will be dropped here, as it will not be preferred over the -- current chain. let candidates2 - | preferAnchoredCandidate bcfg curChain (Diff.getSuffix candidate') = + | preferAnchoredCandidate bcfg weights curChain (Diff.getSuffix candidate') = candidate' : candidates1 | otherwise = candidates1 @@ -1129,7 +1142,7 @@ chainSelection chainSelEnv rr chainDiffs = let isRejected hdr = Map.member (headerHash hdr) (forgetFingerprint invalid) return $ - filter (preferAnchoredCandidate bcfg curChain . Diff.getSuffix) $ + filter (preferAnchoredCandidate bcfg weights curChain . Diff.getSuffix) $ map (Diff.takeWhileOldest (not . isRejected)) cands -- [Ouroboros] @@ -1337,3 +1350,26 @@ ignoreInvalidSuc :: (ChainHash blk -> Set (HeaderHash blk)) ignoreInvalidSuc _ invalid succsOf = Set.filter (`Map.notMember` invalid) . succsOf + +-- | Compare two 'ChainDiff's w.r.t. the chain order. +-- +-- PRECONDITION: Both 'ChainDiff's fit onto the given current chain. +compareChainDiffs :: + forall blk. + BlockSupportsProtocol blk => + BlockConfig blk -> + PerasWeightSnapshot blk -> + -- | Current chain. + AnchoredFragment (Header blk) -> + ChainDiff (Header blk) -> + ChainDiff (Header blk) -> + Ordering +compareChainDiffs bcfg weights curChain = + -- The precondition of 'compareAnchoredFragment's is satisfied as the result + -- of @mkCand@ has the same anchor as @curChain@, and so any two fragments + -- returned by @mkCand@ do intersect. + compareAnchoredFragments bcfg weights `on` mkCand + where + mkCand = + fromMaybe (error "compareChainDiffs: precondition violated") + . Diff.apply curChain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 30193ba314..d79c2a179e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -99,6 +99,7 @@ import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Extended (ExtValidationError) import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) @@ -797,21 +798,23 @@ data SelectionChangedInfo blk = SelectionChangedInfo -- Due to the Ouroboros Genesis (Limit on Eagerness), chain selection can also -- be triggered without any particular trigger block, in which case this is -- 'Nothing'. - , newTipSelectView :: SelectView (BlockProtocol blk) - -- ^ The 'SelectView' of the new tip. It is guaranteed that + , newSuffixSelectView :: WeightedSelectView (BlockProtocol blk) + -- ^ The 'WeightedSelectView' of the suffix of our new selection that was not + -- already present in the old selection. It is guaranteed that -- - -- > Just newTipSelectView > oldTipSelectView - -- True - , oldTipSelectView :: Maybe (SelectView (BlockProtocol blk)) - -- ^ The 'SelectView' of the old, previous tip. This can be 'Nothing' when - -- the previous chain/tip was Genesis. + -- > preferCandidate cfg + -- > (withEmptyFragmentFromMaybe oldSuffixSelectView) + -- > newSuffixSelectView + , oldSuffixSelectView :: Maybe (WeightedSelectView (BlockProtocol blk)) + -- ^ The 'WeightedSelectView' of the orphaned suffix of our old selection. + -- This is 'Nothing' when we extended our selection. } deriving Generic deriving stock instance - (Show (SelectView (BlockProtocol blk)), StandardHash blk) => Show (SelectionChangedInfo blk) + (Show (TiebreakerView (BlockProtocol blk)), StandardHash blk) => Show (SelectionChangedInfo blk) deriving stock instance - (Eq (SelectView (BlockProtocol blk)), StandardHash blk) => Eq (SelectionChangedInfo blk) + (Eq (TiebreakerView (BlockProtocol blk)), StandardHash blk) => Eq (SelectionChangedInfo blk) -- | Trace type for the various events that occur when adding a block. data TraceAddBlockEvent blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs index cfcb5c3050..a3020f767f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs @@ -15,21 +15,17 @@ module Ouroboros.Consensus.Util.AnchoredFragment , stripCommonPrefix ) where -import Control.Monad.Except (throwError) import Data.Foldable (toList) import qualified Data.Foldable1 as F1 import Data.Function (on) import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust) import Data.Word (Word64) import GHC.Stack import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.SelectView +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Util.Assert -import Ouroboros.Network.AnchoredFragment - ( AnchoredFragment - , AnchoredSeq (Empty, (:>)) - ) +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF {------------------------------------------------------------------------------- @@ -76,59 +72,38 @@ forksAtMostKBlocks k ours theirs = case ours `AF.intersect` theirs of -- | Compare two (potentially empty!) 'AnchoredFragment's. -- --- PRECONDITION: Either both fragments are non-empty or they intersect. --- --- For a detailed discussion of this precondition, and a justification for the --- definition of this function, please refer to the Consensus Report. +-- PRECONDITION: The fragments must intersect. -- -- Usage note: the primary user of this function is the chain database when -- sorting fragments that are preferred over our selection. It establishes the -- precondition in the following way: It will only compare candidate fragments --- that it has previously verified are preferable to our current chain. --- Therefore, they are non-empty, as an empty fragment anchored in our chain can --- never be preferable to our chain. +-- that it has previously verified are preferable to our current chain. Since +-- these fragments intersect with our current chain, we can enlarge them to all +-- be anchored in the immutable tip. Therefore, they intersect pairwise. compareAnchoredFragments :: forall blk h. ( BlockSupportsProtocol blk , HasCallStack , GetHeader1 h , HasHeader (h blk) + , HeaderHash (h blk) ~ HeaderHash blk ) => BlockConfig blk -> + PerasWeightSnapshot blk -> AnchoredFragment (h blk) -> AnchoredFragment (h blk) -> Ordering -compareAnchoredFragments cfg frag1 frag2 = - assertWithMsg (precondition frag1 frag2) $ - case (frag1, frag2) of - (Empty _, Empty _) -> - -- The fragments intersect but are equal: their anchors must be equal, - -- and hence the fragments represent the same chain. They are therefore - -- equally preferable. - EQ - (Empty anchor, _ :> tip') -> - -- Since the fragments intersect, but the first one is empty, its anchor - -- must lie somewhere along the the second. If it is the tip, the two - -- fragments represent the same chain and are equally preferable. If - -- not, the second chain is a strict extension of the first and is - -- therefore strictly preferable. - if blockPoint tip' == AF.castPoint (AF.anchorToPoint anchor) - then EQ - else LT - (_ :> tip, Empty anchor') -> - -- This case is symmetric to the previous - if blockPoint tip == AF.castPoint (AF.anchorToPoint anchor') - then EQ - else GT - (_ :> tip, _ :> tip') -> - -- Case 4 - compare - (selectView cfg (getHeader1 tip)) - (selectView cfg (getHeader1 tip')) +compareAnchoredFragments cfg weights frag1 frag2 = + case AF.intersect frag1 frag2 of + Nothing -> error "precondition violated: fragments must intersect" + Just (_oursPrefix, _candPrefix, oursSuffix, candSuffix) -> + compare + (weightedSelectView cfg weights oursSuffix) + (weightedSelectView cfg weights candSuffix) -- | Lift 'preferCandidate' to 'AnchoredFragment' -- --- PRECONDITION: Either both fragments are non-empty or they intersect. +-- PRECONDITION: The fragments must intersect. -- -- Usage note: the primary user of this function is the chain database. It -- establishes the precondition when comparing a candidate fragment to our @@ -142,47 +117,27 @@ preferAnchoredCandidate :: , HasCallStack , GetHeader1 h , GetHeader1 h' + , HeaderHash (h blk) ~ HeaderHash blk , HeaderHash (h blk) ~ HeaderHash (h' blk) , HasHeader (h blk) , HasHeader (h' blk) ) => BlockConfig blk -> + -- | Peras weights used to judge this chain. + PerasWeightSnapshot blk -> -- | Our chain AnchoredFragment (h blk) -> -- | Candidate AnchoredFragment (h' blk) -> Bool -preferAnchoredCandidate cfg ours cand = - assertWithMsg (precondition ours cand) $ - case (ours, cand) of - (_, Empty _) -> False - (Empty ourAnchor, _ :> theirTip) -> - blockPoint theirTip /= castPoint (AF.anchorToPoint ourAnchor) - (_ :> ourTip, _ :> theirTip) -> - preferCandidate - (projectChainOrderConfig cfg) - (selectView cfg (getHeader1 ourTip)) - (selectView cfg (getHeader1 theirTip)) - --- For 'compareAnchoredFragment' and 'preferAnchoredCandidate'. -precondition :: - ( HeaderHash (h blk) ~ HeaderHash (h' blk) - , HasHeader (h blk) - , HasHeader (h' blk) - ) => - AnchoredFragment (h blk) -> - AnchoredFragment (h' blk) -> - Either String () -precondition frag1 frag2 - | not (AF.null frag1) - , not (AF.null frag2) = - return () - | isJust (AF.intersectionPoint frag1 frag2) = - return () - | otherwise = - throwError - "precondition violated: fragments should both be non-empty or they \ - \should intersect" +preferAnchoredCandidate cfg weights ours cand = + case AF.intersect ours cand of + Nothing -> error "precondition violated: fragments must intersect" + Just (_oursPrefix, _candPrefix, oursSuffix, candSuffix) -> + preferCandidate + (projectChainOrderConfig cfg) + (weightedSelectView cfg weights oursSuffix) + (weightedSelectView cfg weights candSuffix) -- | If the two fragments `c1` and `c2` intersect, return the intersection -- point and join the prefix of `c1` before the intersection with the suffix diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index d8cbf1acb0..2ee8a755a3 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -108,6 +108,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.MockChainSel import Ouroboros.Consensus.Storage.ChainDB.API @@ -863,9 +864,12 @@ validChains cfg m bs = sortChains = sortBy $ flip - ( Fragment.compareAnchoredFragments (configBlock cfg) + ( Fragment.compareAnchoredFragments (configBlock cfg) weights `on` (Chain.toAnchoredFragment . fmap getHeader) ) + where + -- TODO enrich with Peras weights/certs + weights = emptyPerasWeightSnapshot classify :: ValidatedChain blk -> diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs index 6293e11968..bcb76e088d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs @@ -27,6 +27,7 @@ import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Tables +import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.ChainDB.API ( LoE (..) , StreamFrom (..) @@ -101,11 +102,15 @@ prop_alwaysPickPreferredChain bt p = bcfg = configBlock singleNodeTestConfig preferCandidate' candidate = - AF.preferAnchoredCandidate bcfg curFragment candFragment + AF.preferAnchoredCandidate bcfg weights curFragment candFragment && AF.forksAtMostKBlocks (unNonZero k) curFragment candFragment where candFragment = Chain.toAnchoredFragment (getHeader <$> candidate) + -- TODO test with non-trivial weights + weights :: PerasWeightSnapshot TestBlock + weights = emptyPerasWeightSnapshot + -- TODO add properties about forks too prop_between_currentChain :: LoE () -> BlockTree -> Property prop_between_currentChain loe bt = From 206fbefb4b8abe627a37afb17afca6b0533dfb4b Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 21 Jul 2025 11:58:14 +0200 Subject: [PATCH 17/35] Integrate weighted BlockFetch decision logic Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- cabal.project | 15 +++++++++ .../BlockFetch/ClientInterface.hs | 32 ++++++++++++------- .../Ouroboros/Consensus/Util/STM.hs | 24 +++----------- .../MiniProtocol/BlockFetch/Client.hs | 1 + .../Storage/PerasCertDB/StateMachine.hs | 4 +-- 5 files changed, 43 insertions(+), 33 deletions(-) diff --git a/cabal.project b/cabal.project index 7c7dfffc43..42c8cafd79 100644 --- a/cabal.project +++ b/cabal.project @@ -49,3 +49,18 @@ if impl (ghc >= 9.12) allow-newer: -- https://github.com/kapralVV/Unique/issues/11 , Unique:hashable + +allow-newer: + -- https://github.com/phadej/vec/issues/121 + , ral:QuickCheck + , fin:QuickCheck + , bin:QuickCheck + +source-repository-package + type: git + location: https://github.com/IntersectMBO/ouroboros-network + tag: b07a86ed853b63881b5a83e57508902f1562ac01 + --sha256: sha256-n/XX0+cQegq2a1cAfmGx30T64eix4oEXzpVEFCKqmg0= + subdir: + ouroboros-network-api + ouroboros-network diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs index 89e9f102af..a630e3d104 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/ClientInterface.hs @@ -33,7 +33,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as CSJumping -import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise , ChainDB @@ -46,14 +46,15 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunis import Ouroboros.Consensus.Util.AnchoredFragment import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () +import Ouroboros.Consensus.Util.STM import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (MaxSlotNo) import Ouroboros.Network.BlockFetch.ConsensusInterface ( BlockFetchConsensusInterface (..) + , ChainComparison (..) , ChainSelStarvation , FetchMode (..) - , FromConsensus (..) , PraosFetchMode (..) , mkReadFetchMode ) @@ -67,6 +68,7 @@ data ChainDbView m blk = ChainDbView , getMaxSlotNo :: STM m MaxSlotNo , addBlockAsync :: InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk) , getChainSelStarvation :: STM m ChainSelStarvation + , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) } defaultChainDbView :: ChainDB m blk -> ChainDbView m blk @@ -78,6 +80,7 @@ defaultChainDbView chainDB = , getMaxSlotNo = ChainDB.getMaxSlotNo chainDB , addBlockAsync = ChainDB.addBlockAsync chainDB , getChainSelStarvation = ChainDB.getChainSelStarvation chainDB + , getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB } readFetchModeDefault :: @@ -227,6 +230,16 @@ mkBlockFetchConsensusInterface readFetchedMaxSlotNo :: STM m MaxSlotNo readFetchedMaxSlotNo = getMaxSlotNo chainDB + readChainComparison :: STM m (WithFingerprint (ChainComparison (HeaderWithTime blk))) + readChainComparison = + fmap mkChainComparison <$> getPerasWeightSnapshot chainDB + where + mkChainComparison weights = + ChainComparison + { plausibleCandidateChain = plausibleCandidateChain weights + , compareCandidateChains = compareCandidateChains weights + } + -- Note that @ours@ comes from the ChainDB and @cand@ from the ChainSync -- client. -- @@ -242,10 +255,11 @@ mkBlockFetchConsensusInterface -- fragment, our current chain might have changed. plausibleCandidateChain :: HasCallStack => + PerasWeightSnapshot blk -> AnchoredFragment (HeaderWithTime blk) -> AnchoredFragment (HeaderWithTime blk) -> Bool - plausibleCandidateChain ours cand = + plausibleCandidateChain weights ours cand = -- 1. The ChainDB maintains the invariant that the anchor of our fragment -- corresponds to the immutable tip. -- @@ -270,20 +284,16 @@ mkBlockFetchConsensusInterface Just _ -> preferAnchoredCandidate bcfg weights ours cand compareCandidateChains :: + PerasWeightSnapshot blk -> AnchoredFragment (HeaderWithTime blk) -> AnchoredFragment (HeaderWithTime blk) -> Ordering - compareCandidateChains = compareAnchoredFragments bcfg weights - - -- TODO requires https://github.com/IntersectMBO/ouroboros-network/pull/5161 - weights = emptyPerasWeightSnapshot + compareCandidateChains = compareAnchoredFragments bcfg - headerForgeUTCTime :: FromConsensus (HeaderWithTime blk) -> STM m UTCTime + headerForgeUTCTime :: HeaderWithTime blk -> UTCTime headerForgeUTCTime = - pure - . fromRelativeTime (SupportsNode.getSystemStart bcfg) + fromRelativeTime (SupportsNode.getSystemStart bcfg) . hwtSlotRelativeTime - . unFromConsensus readChainSelStarvation = getChainSelStarvation chainDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs index ebbfe8bef7..e3f23eace8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -38,10 +34,12 @@ import Control.Monad (void) import Control.Monad.State (StateT (..)) import Control.ResourceRegistry import Data.Void -import Data.Word (Word64) -import GHC.Generics (Generic) import GHC.Stack import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.BlockFetch.ConsensusInterface + ( Fingerprint (..) + , WithFingerprint (..) + ) {------------------------------------------------------------------------------- Misc @@ -85,20 +83,6 @@ blockUntilJust getMaybeA = do blockUntilAllJust :: MonadSTM m => [STM m (Maybe a)] -> STM m [a] blockUntilAllJust = mapM blockUntilJust --- | Simple type that can be used to indicate something in a @TVar@ is --- changed. -newtype Fingerprint = Fingerprint Word64 - deriving stock (Show, Eq, Generic) - deriving newtype Enum - deriving anyclass NoThunks - --- | Store a value together with its fingerprint. -data WithFingerprint a = WithFingerprint - { forgetFingerprint :: !a - , getFingerprint :: !Fingerprint - } - deriving (Show, Eq, Functor, Generic, NoThunks) - {------------------------------------------------------------------------------- Simulate monad stacks -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index e45c89ab65..1a440370e7 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -306,6 +306,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do getMaxSlotNo = ChainDB.getMaxSlotNo chainDB addBlockAsync = ChainDB.addBlockAsync chainDB getChainSelStarvation = ChainDB.getChainSelStarvation chainDB + getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB pure BlockFetchClientInterface.ChainDbView{..} where cdbTracer = Tracer \case diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index cba3925c47..756fcf967d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -24,11 +24,11 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), Per import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model -import Test.QuickCheck +import Test.QuickCheck hiding (Some (..)) import qualified Test.QuickCheck.Monadic as QC import Test.QuickCheck.StateModel import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Tasty.QuickCheck hiding (Some (..)) import Test.Util.TestBlock (TestBlock, TestHash (..)) import Test.Util.TestEnv (adjustQuickCheckTests) From 23288cc6ab7413b61a6fb80a696204070dcd7df9 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 21 Jul 2025 11:58:18 +0200 Subject: [PATCH 18/35] ChainDB: implement chain selection for certificates Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Consensus/Storage/ChainDB/API.hs | 23 +++++- .../Consensus/Storage/ChainDB/Impl.hs | 6 +- .../Storage/ChainDB/Impl/Background.hs | 6 ++ .../Storage/ChainDB/Impl/ChainSel.hs | 73 ++++++++++++++++++ .../Consensus/Storage/ChainDB/Impl/Types.hs | 77 ++++++++++++++++--- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 3 + 6 files changed, 171 insertions(+), 17 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 3631292a7d..4121015fc2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -25,6 +25,10 @@ module Ouroboros.Consensus.Storage.ChainDB.API , addBlockWaitWrittenToDisk , addBlock_ + -- * Adding a Peras certificate + , AddPerasCertPromise (..) + , addPerasCertSync + -- * Trigger chain selection , ChainSelectionPromise (..) , triggerChainSelection @@ -387,7 +391,7 @@ data ChainDB m blk = ChainDB , getStatistics :: m (Maybe Statistics) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. - , addPerasCert :: PerasCert blk -> m () + , addPerasCertAsync :: PerasCert blk -> m (AddPerasCertPromise m) -- ^ TODO , getPerasWeightSnapshot :: STM m (PerasWeightSnapshot blk) -- ^ TODO @@ -510,6 +514,23 @@ triggerChainSelection :: IOLike m => ChainDB m blk -> m () triggerChainSelection chainDB = waitChainSelectionPromise =<< chainSelAsync chainDB +{------------------------------------------------------------------------------- + Adding a Peras certificate +-------------------------------------------------------------------------------} + +newtype AddPerasCertPromise m = AddPerasCertPromise + { waitPerasCertProcessed :: m () + -- ^ Wait until the Peras certificate has been processed (which potentially + -- includes switching to a different chain). If the PerasCertDB did already + -- contain a certificate for this round, the certificate is ignored (as the + -- two certificates must be identical because certificate equivocation is + -- impossible). + } + +addPerasCertSync :: IOLike m => ChainDB m blk -> PerasCert blk -> m () +addPerasCertSync chainDB cert = + waitPerasCertProcessed =<< addPerasCertAsync chainDB cert + {------------------------------------------------------------------------------- Serialised block/header with its point -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 3a3238d906..d9e508593d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -16,6 +16,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl -- * Trace types , SelectionChangedInfo (..) , TraceAddBlockEvent (..) + , TraceAddPerasCertEvent (..) , TraceChainSelStarvationEvent (..) , TraceCopyToImmutableDBEvent (..) , TraceEvent (..) @@ -282,10 +283,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , getHeaderStateHistory = getEnvSTM h Query.getHeaderStateHistory , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint , getStatistics = getEnv h Query.getStatistics - , addPerasCert = getEnv1 h $ \cdb@CDB{..} cert -> do - PerasCertDB.addCert cdbPerasCertDB cert - -- TODO trigger chain selection in a more efficient way - waitChainSelectionPromise =<< ChainSel.triggerChainSelectionAsync cdb + , addPerasCertAsync = getEnv1 h ChainSel.addPerasCertAsync , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot } addBlockTestFuse <- newFuse "test chain selection" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 273ecd6c53..6cbffb5483 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -634,6 +634,8 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do varBlockProcessed (FailedToAddBlock "Failed to add block synchronously") pure () + ChainSelAddPerasCert _cert varProcessed -> + void $ tryPutTMVar varProcessed () closeChainSelQueue cdbChainSelQueue ) ( \message -> do @@ -642,6 +644,10 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do trace PoppedReprocessLoEBlocksFromQueue ChainSelAddBlock BlockToAdd{blockToAdd} -> trace $ PoppedBlockFromQueue $ blockRealPoint blockToAdd + ChainSelAddPerasCert cert _varProcessed -> + traceWith cdbTracer $ + TraceAddPerasCertEvent $ + PoppedPerasCertFromQueue (perasCertRound cert) (perasCertBoostedBlock cert) chainSelSync cdb message lift $ atomically $ processedChainSelMessage cdbChainSelQueue message ) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 00b2204c73..8fd3f6d799 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -13,6 +13,7 @@ -- adding a block. module Ouroboros.Consensus.Storage.ChainDB.Impl.ChainSel ( addBlockAsync + , addPerasCertAsync , chainSelSync , chainSelectionForBlock , initialChainSelection @@ -68,12 +69,14 @@ import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) , AddBlockResult (..) + , AddPerasCertPromise , BlockComponent (..) , ChainType (..) , LoE (..) ) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment ( InvalidBlockPunishment + , noPunishment ) import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache @@ -87,10 +90,12 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.AnchoredFragment +import Ouroboros.Consensus.Util.EarlyExit (exitEarly, withEarlyExit_) import Ouroboros.Consensus.Util.Enclose (encloseWith) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) @@ -319,6 +324,15 @@ addBlockAsync :: addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addBlockToAdd (TraceAddBlockEvent >$< cdbTracer) cdbChainSelQueue +addPerasCertAsync :: + forall m blk. + (IOLike m, HasHeader blk) => + ChainDbEnv m blk -> + PerasCert blk -> + m (AddPerasCertPromise m) +addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = + addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue + -- | Schedule reprocessing of blocks postponed by the LoE. triggerChainSelectionAsync :: forall m blk. @@ -469,6 +483,65 @@ chainSelSync cdb@CDB{..} (ChainSelAddBlock BlockToAdd{blockToAdd = b, ..}) = do deliverProcessed tip = atomically $ putTMVar varBlockProcessed (SuccesfullyAddedBlock tip) +-- Process a Peras certificate by adding it to the PerasCertDB and potentially +-- performing chain selection if a candidate is now better than our selection. +chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do + curChain <- lift $ atomically $ Query.getCurrentChain cdb + let immTip = castPoint $ AF.anchorPoint curChain + + withEarlyExit_ $ do + -- Ignore the certificate if it boosts a block that is so old that it can't + -- influence our selection. + when (pointSlot boostedBlock < pointSlot immTip) $ do + lift $ lift $ traceWith tracer $ IgnorePerasCertTooOld certRound boostedBlock immTip + exitEarly + + -- Add the certificate to the PerasCertDB. + lift (lift $ PerasCertDB.addCert cdbPerasCertDB cert) >>= \case + PerasCertDB.AddedPerasCertToDB -> pure () + -- If it already is in the PerasCertDB, we are done. + PerasCertDB.PerasCertAlreadyInDB -> exitEarly + + -- If the certificate boosts a block on our current chain (including the + -- anchor), then it just makes our selection even stronger. + when (AF.withinFragmentBounds (castPoint boostedBlock) curChain) $ do + lift $ lift $ traceWith tracer $ PerasCertBoostsCurrentChain certRound boostedBlock + exitEarly + + boostedHash <- case pointHash boostedBlock of + -- If the certificate boosts the Genesis point, then it can not influence + -- chain selection as all chains contain it. + GenesisHash -> do + lift $ lift $ traceWith tracer $ PerasCertBoostsGenesis certRound + exitEarly + -- Otherwise, the certificate boosts a block potentially on a (future) + -- candidate. + BlockHash boostedHash -> pure boostedHash + boostedHdr <- + lift (lift $ VolatileDB.getBlockComponent cdbVolatileDB GetHeader boostedHash) >>= \case + -- If we have not (yet) received the boosted block, we don't need to do + -- anything further for now regarding chain selection. Once we receive + -- it, the additional weight of the certificate is taken into account. + Nothing -> do + lift $ lift $ traceWith tracer $ PerasCertBoostsBlockNotYetReceived certRound boostedBlock + exitEarly + Just boostedHdr -> pure boostedHdr + + -- Trigger chain selection for the boosted block. + lift $ lift $ traceWith tracer $ ChainSelectionForBoostedBlock certRound boostedBlock + lift $ chainSelectionForBlock cdb BlockCache.empty boostedHdr noPunishment + + -- Deliver promise indicating that we processed the cert. + lift $ atomically $ putTMVar varProcessed () + where + tracer :: Tracer m (TraceAddPerasCertEvent blk) + tracer = TraceAddPerasCertEvent >$< cdbTracer + + certRound :: PerasRoundNo + certRound = perasCertRound cert + + boostedBlock :: Point blk + boostedBlock = perasCertBoostedBlock cert -- | Return 'True' when the given header should be ignored when adding it -- because it is too old, i.e., we wouldn't be able to switch to a chain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index d79c2a179e..ade3907a56 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -55,6 +55,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types , ChainSelMessage (..) , ChainSelQueue -- opaque , addBlockToAdd + , addPerasCertToQueue , addReprocessLoEBlocks , closeChainSelQueue , getChainSelMessage @@ -66,6 +67,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types -- * Trace types , SelectionChangedInfo (..) , TraceAddBlockEvent (..) + , TraceAddPerasCertEvent (..) , TraceChainSelStarvationEvent (..) , TraceCopyToImmutableDBEvent (..) , TraceEvent (..) @@ -83,7 +85,6 @@ import Control.ResourceRegistry import Control.Tracer import Data.Foldable (traverse_) import Data.Map.Strict (Map) -import Data.Maybe (mapMaybe) import Data.Maybe.Strict (StrictMaybe (..)) import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet @@ -104,6 +105,7 @@ import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( AddBlockPromise (..) , AddBlockResult (..) + , AddPerasCertPromise (..) , ChainDbError (..) , ChainSelectionPromise (..) , ChainType @@ -546,6 +548,11 @@ data BlockToAdd m blk = BlockToAdd data ChainSelMessage m blk = -- | Add a new block ChainSelAddBlock !(BlockToAdd m blk) + | -- | Add a Peras certificate + ChainSelAddPerasCert + !(PerasCert blk) + -- | Used for 'AddPerasCertPromise'. + !(StrictTMVar m ()) | -- | Reprocess blocks that have been postponed by the LoE. ChainSelReprocessLoEBlocks -- | Used for 'ChainSelectionPromise'. @@ -594,6 +601,28 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish , blockProcessed = readTMVar varBlockProcessed } +-- | Add a Peras certificate to the background queue. +addPerasCertToQueue :: + (IOLike m, StandardHash blk) => + Tracer m (TraceAddPerasCertEvent blk) -> + ChainSelQueue m blk -> + PerasCert blk -> + m (AddPerasCertPromise m) +addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do + varProcessed <- newEmptyTMVarIO + traceWith tracer $ addedToQueue RisingEdge + queueSize <- atomically $ do + writeTBQueue varChainSelQueue $ ChainSelAddPerasCert cert varProcessed + lengthTBQueue varChainSelQueue + traceWith tracer $ addedToQueue $ FallingEdgeWith $ fromIntegral queueSize + pure + AddPerasCertPromise + { waitPerasCertProcessed = atomically $ takeTMVar varProcessed + } + where + addedToQueue = + AddedPerasCertToQueue (perasCertRound cert) (perasCertBoostedBlock cert) + -- | Try to add blocks again that were postponed due to the LoE. addReprocessLoEBlocks :: IOLike m => @@ -648,23 +677,21 @@ getChainSelMessage starvationTracer starvationVar chainSelQueue = let pt = blockRealPoint block traceWith starvationTracer $ ChainSelStarvation (FallingEdgeWith pt) atomically . writeTVar starvationVar . ChainSelStarvationEndedAt =<< getMonotonicTime + ChainSelAddPerasCert{} -> pure () ChainSelReprocessLoEBlocks{} -> pure () -- | Flush the 'ChainSelQueue' queue and notify the waiting threads. closeChainSelQueue :: IOLike m => ChainSelQueue m blk -> STM m () closeChainSelQueue ChainSelQueue{varChainSelQueue = queue} = do - as <- mapMaybe blockAdd <$> flushTBQueue queue - traverse_ - ( \a -> - tryPutTMVar - (varBlockProcessed a) - (FailedToAddBlock "Queue flushed") - ) - as + traverse_ deliverPromise =<< flushTBQueue queue where - blockAdd = \case - ChainSelAddBlock ab -> Just ab - ChainSelReprocessLoEBlocks _ -> Nothing + deliverPromise = \case + ChainSelAddBlock ab -> + tryPutTMVar (varBlockProcessed ab) (FailedToAddBlock "Queue flushed") + ChainSelAddPerasCert _cert varProcessed -> + tryPutTMVar varProcessed () + ChainSelReprocessLoEBlocks varProcessed -> + tryPutTMVar varProcessed () -- | To invoke when the given 'ChainSelMessage' has been processed by ChainSel. -- This is used to remove the respective point from the multiset of points in @@ -677,6 +704,8 @@ processedChainSelMessage :: processedChainSelMessage ChainSelQueue{varChainSelPoints} = \case ChainSelAddBlock BlockToAdd{blockToAdd = blk} -> modifyTVar varChainSelPoints $ MultiSet.delete (blockRealPoint blk) + ChainSelAddPerasCert{} -> + pure () ChainSelReprocessLoEBlocks{} -> pure () @@ -720,6 +749,7 @@ data TraceEvent blk | TraceVolatileDBEvent (VolatileDB.TraceEvent blk) | TraceLastShutdownUnclean | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk) + | TraceAddPerasCertEvent (TraceAddPerasCertEvent blk) deriving Generic deriving instance @@ -1030,3 +1060,26 @@ data TraceIteratorEvent blk newtype TraceChainSelStarvationEvent blk = ChainSelStarvation (Enclosing' (RealPoint blk)) deriving (Generic, Eq, Show) + +data TraceAddPerasCertEvent blk + = -- | The Peras certificate from the given round boosting the given block was + -- added to the queue. The size of the queue is included. + AddedPerasCertToQueue PerasRoundNo (Point blk) (Enclosing' Word) + | -- | The Peras certificate from the given round boosting the given block was + -- popped from the queue. + PoppedPerasCertFromQueue PerasRoundNo (Point blk) + | -- | The Peras certificate from the given round boosting the given block was + -- too old, ie its slot was older than the current immutable slot (the third + -- argument). + IgnorePerasCertTooOld PerasRoundNo (Point blk) (Point blk) + | -- | The Peras certificate from the given round boosts a block on the + -- current selection. + PerasCertBoostsCurrentChain PerasRoundNo (Point blk) + | -- | The Peras certificate from the given round boosts the Genesis point. + PerasCertBoostsGenesis PerasRoundNo + | -- | The Peras certificate from the given round boosts a block that we have + -- not (yet) received. + PerasCertBoostsBlockNotYetReceived PerasRoundNo (Point blk) + | -- | Perform chain selection for a block boosted by a Peras certificate. + ChainSelectionForBoostedBlock PerasRoundNo (Point blk) + deriving (Generic, Eq, Show) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index c55fcaadf6..4d53c99b0f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -1348,6 +1348,8 @@ deriving instance SOP.Generic (VolatileDB.TraceEvent blk) deriving instance SOP.HasDatatypeInfo (VolatileDB.TraceEvent blk) deriving anyclass instance SOP.Generic (TraceChainSelStarvationEvent blk) deriving anyclass instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk) +deriving anyclass instance SOP.Generic (TraceAddPerasCertEvent blk) +deriving anyclass instance SOP.HasDatatypeInfo (TraceAddPerasCertEvent blk) data Tag = TagGetIsValidJust @@ -1774,6 +1776,7 @@ traceEventName = \case TraceVolatileDBEvent ev -> "VolatileDB." <> constrName ev TraceLastShutdownUnclean -> "LastShutdownUnclean" TraceChainSelStarvationEvent ev -> "ChainSelStarvation." <> constrName ev + TraceAddPerasCertEvent ev -> "AddPerasCert." <> constrName ev mkArgs :: IOLike m => From daf4de32048f6d235c8ede004c1547f5a3fba98c Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 24 Jul 2025 14:39:00 +0200 Subject: [PATCH 19/35] MockChainSel: switch to weighted chain selection Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Consensus/Protocol/MockChainSel.hs | 28 ++++++++----------- .../Test/Util/TestBlock.hs | 14 ++++++++-- .../MiniProtocol/LocalStateQuery/Server.hs | 3 +- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 15 ++++++++-- 4 files changed, 38 insertions(+), 22 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs index 341a916495..676f01f023 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/MockChainSel.hs @@ -9,9 +9,9 @@ module Ouroboros.Consensus.Protocol.MockChainSel import Data.List (sortOn) import Data.Maybe (listToMaybe, mapMaybe) import Data.Ord (Down (..)) +import Ouroboros.Consensus.Peras.SelectView (WeightedSelectView (..), WithEmptyFragment (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Network.Mock.Chain (Chain) -import qualified Ouroboros.Network.Mock.Chain as Chain {------------------------------------------------------------------------------- Chain selection @@ -33,8 +33,9 @@ selectChain :: forall proxy p hdr l. ConsensusProtocol p => proxy p -> - ChainOrderConfig (SelectView p) -> - (hdr -> SelectView p) -> + ChainOrderConfig (WeightedSelectView p) -> + -- | Compute the 'WeightedSelectView' of a chain. + (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) -> -- | Our chain Chain hdr -> -- | Upstream chains @@ -51,24 +52,19 @@ selectChain _ cfg view ours = -- extract the 'SelectView' of the tip of the candidate. selectPreferredCandidate :: (Chain hdr, l) -> - Maybe (SelectView p, (Chain hdr, l)) - selectPreferredCandidate x@(cand, _) = - case (Chain.head ours, Chain.head cand) of - (Nothing, Just candTip) -> - Just (view candTip, x) - (Just ourTip, Just candTip) - | let candView = view candTip - , preferCandidate cfg (view ourTip) candView -> - Just (candView, x) - _otherwise -> - Nothing + Maybe (WithEmptyFragment (WeightedSelectView p), (Chain hdr, l)) + selectPreferredCandidate x@(cand, _) + | let candView = view cand + , preferCandidate cfg (view ours) candView = + Just (candView, x) + | otherwise = Nothing -- | Chain selection on unvalidated chains selectUnvalidatedChain :: ConsensusProtocol p => proxy p -> - ChainOrderConfig (SelectView p) -> - (hdr -> SelectView p) -> + ChainOrderConfig (WeightedSelectView p) -> + (Chain hdr -> WithEmptyFragment (WeightedSelectView p)) -> Chain hdr -> [Chain hdr] -> Maybe (Chain hdr) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index f1f397011b..27a8d0c641 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -139,6 +139,8 @@ import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.SelectView (weightedSelectView) +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.BFT import Ouroboros.Consensus.Protocol.MockChainSel @@ -859,15 +861,21 @@ treeToBlocks = Tree.flatten . blockTree treeToChains :: BlockTree -> [Chain TestBlock] treeToChains = map Chain.fromOldestFirst . allPaths . blockTree -treePreferredChain :: BlockTree -> Chain TestBlock -treePreferredChain = +treePreferredChain :: + PerasWeightSnapshot TestBlock -> + BlockTree -> + Chain TestBlock +treePreferredChain weights = fromMaybe Genesis . selectUnvalidatedChain (Proxy @(BlockProtocol TestBlock)) (() :: ChainOrderConfig (SelectView (BlockProtocol TestBlock))) - (\hdr -> SelectView (blockNo hdr) NoTiebreaker) + (weightedSelectView bcfg weights . Chain.toAnchoredFragment . fmap getHeader) Genesis . treeToChains + where + -- inconsequential for this function + bcfg = TestBlockConfig (NumCoreNodes 0) instance Show BlockTree where show (BlockTree t) = Tree.drawTree (fmap show t) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index efafdc18aa..d0c8b4adbc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -37,6 +37,7 @@ import Ouroboros.Consensus.Ledger.Query (Query (..)) import Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) import Ouroboros.Consensus.Protocol.BFT import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache import Ouroboros.Consensus.Storage.ImmutableDB.Stream hiding @@ -100,7 +101,7 @@ prop_localStateQueryServer :: prop_localStateQueryServer k bt p (Positive (Small n)) = checkOutcome k chain actualOutcome where chain :: Chain TestBlock - chain = treePreferredChain bt + chain = treePreferredChain emptyPerasWeightSnapshot bt points :: [Target (Point TestBlock)] points = diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 2ee8a755a3..76c0df6992 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -108,6 +108,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsProtocol +import Ouroboros.Consensus.Peras.SelectView import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.MockChainSel @@ -532,9 +533,15 @@ chainSelection cfg m = . selectChain (Proxy @(BlockProtocol blk)) (projectChainOrderConfig (configBlock cfg)) - (selectView (configBlock cfg) . getHeader) + ( weightedSelectView (configBlock cfg) weights + . Chain.toAnchoredFragment + . fmap getHeader + ) (currentChain m) $ consideredCandidates + where + -- TODO enrich with Peras weights/certs + weights = emptyPerasWeightSnapshot -- We update the set of valid blocks with all valid blocks on all candidate -- chains that are considered by the modeled chain selection. This ensures @@ -1112,7 +1119,11 @@ wipeVolatileDB cfg m = $ selectChain (Proxy @(BlockProtocol blk)) (projectChainOrderConfig (configBlock cfg)) - (selectView (configBlock cfg) . getHeader) + -- Weight is inconsequential as there is only a single candidate. + ( weightedSelectView (configBlock cfg) emptyPerasWeightSnapshot + . Chain.toAnchoredFragment + . fmap getHeader + ) Chain.genesis $ snd $ validChains cfg m (immutableDbBlocks m) From 4c847379f04492d0284d3fd0bd40b17fcbf3e1bd Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 24 Jul 2025 15:52:56 +0200 Subject: [PATCH 20/35] ChainDB q-s-m: test weighted chain selection Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Consensus/Util/AnchoredFragment.hs | 37 ++++-- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 121 ++++++++++++------ .../Ouroboros/Storage/ChainDB/Model/Test.hs | 5 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 41 +++++- 4 files changed, 149 insertions(+), 55 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs index a3020f767f..0eca5b8e03 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs @@ -10,7 +10,7 @@ module Ouroboros.Consensus.Util.AnchoredFragment ( compareAnchoredFragments , compareHeadBlockNo , cross - , forksAtMostKBlocks + , forksAtMostKWeight , preferAnchoredCandidate , stripCommonPrefix ) where @@ -19,7 +19,6 @@ import Data.Foldable (toList) import qualified Data.Foldable1 as F1 import Data.Function (on) import qualified Data.List.NonEmpty as NE -import Data.Word (Word64) import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Peras.SelectView @@ -55,20 +54,32 @@ compareHeadBlockNo :: Ordering compareHeadBlockNo = compare `on` AF.headBlockNo -forksAtMostKBlocks :: - HasHeader b => - -- | How many blocks can it fork? - Word64 -> - -- | Our chain. +-- | Check that we can switch from @ours@ to @theirs@ by rolling back our chain +-- by at most @k@ weight. +-- +-- If @ours@ and @cand@ do not intersect, this returns 'False'. If they do +-- intersect, then we check that the suffix of @ours@ after the intersection has +-- total weight at most @k@. +forksAtMostKWeight :: + ( StandardHash blk + , HasHeader b + , HeaderHash blk ~ HeaderHash b + ) => + PerasWeightSnapshot blk -> + -- | By how much weight can we roll back our chain at most? + PerasWeight -> + -- | Our chain @ours@. AnchoredFragment b -> - -- | Their chain + -- | Their chain @theirs@. AnchoredFragment b -> - -- | Indicates whether their chain forks at most the - -- specified number of blocks. + -- | Indicates whether their chain forks at most the given the amount of + -- weight. Returns 'False' if the two fragments do not intersect. Bool -forksAtMostKBlocks k ours theirs = case ours `AF.intersect` theirs of - Nothing -> False - Just (_, _, ourSuffix, _) -> fromIntegral (AF.length ourSuffix) <= k +forksAtMostKWeight weights maxWeight ours theirs = + case ours `AF.intersect` theirs of + Nothing -> False + Just (_, _, ourSuffix, _) -> + totalWeightOfFragment weights ourSuffix <= maxWeight -- | Compare two (potentially empty!) 'AnchoredFragment's. -- diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 76c0df6992..37bfa49085 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -25,6 +25,7 @@ module Test.Ouroboros.Storage.ChainDB.Model , addBlock , addBlockPromise , addBlocks + , addPerasCert , empty -- * Queries @@ -44,7 +45,7 @@ module Test.Ouroboros.Storage.ChainDB.Model , invalid , isOpen , isValid - , lastK + , maxPerasRoundNo , tipBlock , tipPoint , volatileChain @@ -90,6 +91,7 @@ import Control.Monad.Except (runExcept) import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as Lazy import Data.Containers.ListUtils (nubOrdOn) +import Data.Foldable (foldMap') import Data.Function (on, (&)) import Data.Functor (($>), (<&>)) import Data.List (isInfixOf, isPrefixOf, sortBy) @@ -100,7 +102,6 @@ import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import Data.TreeDiff -import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -147,6 +148,7 @@ data Model blk = Model -- ^ The VolatileDB , immutableDbChain :: Chain blk -- ^ The ImmutableDB + , perasCerts :: Map PerasRoundNo (PerasCert blk) , cps :: CPS.ChainProducerState blk , currentLedger :: ExtLedgerState blk EmptyMK , initLedger :: ExtLedgerState blk EmptyMK @@ -233,72 +235,78 @@ tipPoint = maybe GenesisPoint blockPoint . tipBlock getMaxSlotNo :: HasHeader blk => Model blk -> MaxSlotNo getMaxSlotNo = foldMap (MaxSlotNo . blockSlot) . blocks -lastK :: - HasHeader a => - SecurityParam -> - -- | Provided since `AnchoredFragment` is not a functor - (blk -> a) -> - Model blk -> - AnchoredFragment a -lastK (SecurityParam k) f = - Fragment.anchorNewest (unNonZero k) - . Chain.toAnchoredFragment - . fmap f - . currentChain - --- | Actual number of blocks that can be rolled back. Equal to @k@, except --- when: +-- | Actual amount of weight that can be rolled back. This can non-trivially +-- smaller than @k@ in the following cases: -- --- * Near genesis, the chain might not be @k@ blocks long yet. --- * After VolatileDB corruption, the whole chain might be >= @k@ blocks, but --- the tip of the ImmutableDB might be closer than @k@ blocks away from the --- current chain's tip. -maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> Word64 +-- * Near genesis, the chain might not have grown sufficiently yet. +-- * After VolatileDB corruption, the whole chain might have more than weight +-- @k@, but the tip of the ImmutableDB might be buried under significantly +-- less than weight @k@ worth of blocks. +maxActualRollback :: HasHeader blk => SecurityParam -> Model blk -> PerasWeight maxActualRollback k m = - fromIntegral - . length + foldMap' (weightBoostOfPoint weights) . takeWhile (/= immutableTipPoint) . map blockPoint . Chain.toNewestFirst . currentChain $ m where + weights = perasWeights m + immutableTipPoint = Chain.headPoint (immutableChain k m) -- | Return the immutable prefix of the current chain. -- -- This is the longest of the given two chains: -- --- 1. The current chain with the last @k@ blocks dropped. +-- 1. The current chain with the longest suffix of weight at most @k@ dropped. -- 2. The chain formed by the blocks in 'immutableDbChain', i.e., the -- \"ImmutableDB\". We need to take this case in consideration because the -- VolatileDB might have been wiped. -- --- We need this because we do not allow rolling back more than @k@ blocks, but +-- We need this because we do not allow rolling back more than weight @k@, but -- the background thread copying blocks from the VolatileDB to the ImmutableDB -- might not have caught up yet. This means we cannot use the tip of the -- ImmutableDB to know the most recent \"immutable\" block. immutableChain :: + forall blk. + HasHeader blk => SecurityParam -> Model blk -> Chain blk -immutableChain (SecurityParam k) m = +immutableChain k m = maxBy + -- As one of the two chains is a prefix of the other, Peras weight doesn't + -- matter here. Chain.length - (Chain.drop (fromIntegral $ unNonZero k) (currentChain m)) + (dropAtMostWeight (maxRollbackWeight k) (currentChain m)) (immutableDbChain m) where maxBy f a b | f a >= f b = a | otherwise = b + weights = perasWeights m + + -- Drop the longest suffix with at most the given weight. + dropAtMostWeight :: PerasWeight -> Chain blk -> Chain blk + dropAtMostWeight budget = go mempty + where + go w = \case + Genesis -> Genesis + c@(c' :> b) + | w' <= budget -> go w' c' + | otherwise -> c + where + w' = w <> PerasWeight 1 <> weightBoostOfPoint weights (blockPoint b) + -- | Return the volatile suffix of the current chain. -- -- The opposite of 'immutableChain'. -- -- This is the shortest of the given two chain fragments: -- --- 1. The last @k@ blocks of the current chain. +-- 1. The longest suffix of the current chain with weight at most @k@. -- 2. The suffix of the current chain not part of the 'immutableDbChain', i.e., -- the \"ImmutableDB\". volatileChain :: @@ -370,6 +378,17 @@ isValid = flip getIsValid getLoEFragment :: Model blk -> LoE (AnchoredFragment blk) getLoEFragment = loeFragment +perasWeights :: StandardHash blk => Model blk -> PerasWeightSnapshot blk +perasWeights = + mkPerasWeightSnapshot + -- TODO make boost per cert configurable + . fmap (\c -> (perasCertBoostedBlock c, boostPerCert)) + . Map.elems + . perasCerts + +maxPerasRoundNo :: Model blk -> Maybe PerasRoundNo +maxPerasRoundNo m = fst <$> Map.lookupMax (perasCerts m) + {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} @@ -383,6 +402,7 @@ empty loe initLedger = Model { volatileDbBlocks = Map.empty , immutableDbChain = Chain.Genesis + , perasCerts = Map.empty , cps = CPS.initChainProducerState Chain.Genesis , currentLedger = initLedger , initLedger = initLedger @@ -422,6 +442,23 @@ addBlock cfg blk m -- If it's an invalid block we've seen before, ignore it. Map.member (blockHash blk) (invalid m) +addPerasCert :: + forall blk. + (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) => + TopLevelConfig blk -> + PerasCert blk -> + Model blk -> + Model blk +addPerasCert cfg cert m + -- Do not alter the model when a certificate for that round already exists. + | Map.member certRound (perasCerts m) = m + | otherwise = + chainSelection + cfg + m{perasCerts = Map.insert certRound cert (perasCerts m)} + where + certRound = perasCertRound cert + chainSelection :: forall blk. ( LedgerTablesAreTrivial (ExtLedgerState blk) @@ -434,6 +471,7 @@ chainSelection cfg m = Model { volatileDbBlocks = volatileDbBlocks m , immutableDbChain = immutableDbChain m + , perasCerts = perasCerts m , cps = CPS.switchFork newChain (cps m) , currentLedger = newLedger , initLedger = initLedger m @@ -533,15 +571,12 @@ chainSelection cfg m = . selectChain (Proxy @(BlockProtocol blk)) (projectChainOrderConfig (configBlock cfg)) - ( weightedSelectView (configBlock cfg) weights + ( weightedSelectView (configBlock cfg) (perasWeights m) . Chain.toAnchoredFragment . fmap getHeader ) (currentChain m) $ consideredCandidates - where - -- TODO enrich with Peras weights/certs - weights = emptyPerasWeightSnapshot -- We update the set of valid blocks with all valid blocks on all candidate -- chains that are considered by the modeled chain selection. This ensures @@ -871,12 +906,9 @@ validChains cfg m bs = sortChains = sortBy $ flip - ( Fragment.compareAnchoredFragments (configBlock cfg) weights + ( Fragment.compareAnchoredFragments (configBlock cfg) (perasWeights m) `on` (Chain.toAnchoredFragment . fmap getHeader) ) - where - -- TODO enrich with Peras weights/certs - weights = emptyPerasWeightSnapshot classify :: ValidatedChain blk -> @@ -910,7 +942,11 @@ between k from to m = do fork <- errFork -- See #871. if partOfCurrentChain fork - || Fragment.forksAtMostKBlocks (maxActualRollback k m) currentFrag fork + || Fragment.forksAtMostKWeight + (perasWeights m) + (maxActualRollback k m) + currentFrag + fork then return $ Fragment.toOldestFirst fork -- We cannot stream from an old fork else Left $ ForkTooOld from @@ -1050,6 +1086,7 @@ garbageCollect :: garbageCollect secParam m@Model{..} = m { volatileDbBlocks = Map.filter (not . collectable) volatileDbBlocks + -- TODO garbage collection Peras certs? } where -- TODO what about iterators that will stream garbage collected blocks? @@ -1101,6 +1138,14 @@ wipeVolatileDB cfg m = m' = (closeDB m) { volatileDbBlocks = Map.empty + , -- TODO: Currently, the SUT has no persistence of Peras certs across + -- restarts, but this will change. There are at least two options: + -- + -- * Change this command to mean "wipe volatile state" (including + -- volatile certificates) + -- + -- * Add a separate "Wipe volatile certs". + perasCerts = Map.empty , cps = CPS.switchFork newChain (cps m) , currentLedger = newLedger , invalid = Map.empty diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs index bcb76e088d..0b2410f68f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs @@ -22,7 +22,6 @@ -- chain DB, we always pick the most preferred chain. module Test.Ouroboros.Storage.ChainDB.Model.Test (tests) where -import Cardano.Ledger.BaseTypes (unNonZero) import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -97,13 +96,13 @@ prop_alwaysPickPreferredChain bt p = curFragment = Chain.toAnchoredFragment (getHeader <$> current) - SecurityParam k = configSecurityParam singleNodeTestConfig + k = configSecurityParam singleNodeTestConfig bcfg = configBlock singleNodeTestConfig preferCandidate' candidate = AF.preferAnchoredCandidate bcfg weights curFragment candFragment - && AF.forksAtMostKBlocks (unNonZero k) curFragment candFragment + && AF.forksAtMostKWeight weights (maxRollbackWeight k) curFragment candFragment where candFragment = Chain.toAnchoredFragment (getHeader <$> candidate) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 4d53c99b0f..46c6d9c3c5 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -178,6 +178,7 @@ import Test.Util.WithEq -- | Commands data Cmd blk it flr = AddBlock blk + | AddPerasCert (PerasCert blk) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -402,8 +403,9 @@ run :: Cmd blk (TestIterator m blk) (TestFollower m blk) -> m (Success blk (TestIterator m blk) (TestFollower m blk)) run cfg env@ChainDBEnv{varDB, ..} cmd = - readTVarIO varDB >>= \st@ChainDBState{chainDB = ChainDB{..}, internal} -> case cmd of + readTVarIO varDB >>= \st@ChainDBState{chainDB = chainDB@ChainDB{..}, internal} -> case cmd of AddBlock blk -> Point <$> advanceAndAdd st blk + AddPerasCert cert -> Unit <$> addPerasCertSync chainDB cert GetCurrentChain -> Chain <$> atomically getCurrentChain GetTipBlock -> MbBlock <$> getTipBlock GetTipHeader -> MbHeader <$> getTipHeader @@ -638,6 +640,7 @@ runPure :: (Resp blk IteratorId FollowerId, DBModel blk) runPure cfg = \case AddBlock blk -> ok Point $ update (add blk) + AddPerasCert cert -> ok Unit $ ((),) . update (Model.addPerasCert cfg cert) GetCurrentChain -> ok Chain $ query (Model.volatileChain k getHeader) GetTipBlock -> ok MbBlock $ query Model.tipBlock GetTipHeader -> ok MbHeader $ query (fmap getHeader . Model.tipBlock) @@ -909,6 +912,11 @@ generator loe genBlock m@Model{..} = At <$> frequency [ (30, genAddBlock) + , let freq = case loe of + LoEDisabled -> 10 + -- The LoE does not yet support Peras. + LoEEnabled () -> 0 + in (freq, AddPerasCert <$> genAddPerasCert) , (if empty then 1 else 10, return GetCurrentChain) , -- , (if empty then 1 else 10, return GetLedgerDB) (if empty then 1 else 10, return GetTipBlock) @@ -1034,6 +1042,20 @@ generator loe genBlock m@Model{..} = genAddBlock = AddBlock <$> genBlock m + genAddPerasCert :: Gen (PerasCert blk) + genAddPerasCert = do + -- TODO chain condition? + blk <- genBlock m + let pcCertRound = case Model.maxPerasRoundNo dbModel of + Nothing -> PerasRoundNo 0 + Just (PerasRoundNo r) -> PerasRoundNo (r + 1) + cert = + PerasCert + { pcCertRound + , pcCertBoostedBlock = blockPoint blk + } + pure cert + genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = frequency @@ -1356,6 +1378,7 @@ data Tag | TagGetIsValidNothing | TagChainSelReprocessChangedSelection | TagChainSelReprocessKeptSelection + | TagSwitchedToShorterChain deriving (Show, Eq) -- | Predicate on events @@ -1382,6 +1405,7 @@ tag = , tagGetIsValidNothing , tagChainSelReprocess TagChainSelReprocessChangedSelection (/=) , tagChainSelReprocess TagChainSelReprocessKeptSelection (==) + , tagSwitchedToShorterChain ] where tagGetIsValidJust :: EventPred m @@ -1406,6 +1430,21 @@ tag = Left t _ -> Right $ tagChainSelReprocess t test + -- Tag this test case if we ever switch from a longer to a shorter chain in a + -- non-degenerate case. + tagSwitchedToShorterChain :: EventPred m + tagSwitchedToShorterChain = C.predicate $ \case + ev + | case unAt $ eventCmd ev of + -- Wiping the VolatileDB is not interesting here. + WipeVolatileDB{} -> False + _ -> True + , ((>) `on` curChainLength) (eventBefore ev) (eventAfter ev) -> + Left TagSwitchedToShorterChain + | otherwise -> Right tagSwitchedToShorterChain + where + curChainLength = Chain.length . Model.currentChain . dbModel + -- | Step the model using a 'QSM.Command' (i.e., a command associated with -- an explicit set of variables) execCmd :: From bc163282b867efe4f37c00e937a4875dc22ac934 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 6 Aug 2025 18:37:51 +0200 Subject: [PATCH 21/35] Modify PerasCertDB (and to some extent, ChainDB) to allow snapshot of PerasCerts Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Storage/ChainDB/API.hs | 3 +++ .../Ouroboros/Consensus/Storage/ChainDB/Impl.hs | 1 + .../Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs | 6 ++++++ 3 files changed, 10 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 4121015fc2..94cc8870eb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -95,6 +95,7 @@ import Ouroboros.Consensus.Storage.LedgerDB , Statistics ) import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertSnapshot) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike @@ -395,6 +396,8 @@ data ChainDB m blk = ChainDB -- ^ TODO , getPerasWeightSnapshot :: STM m (PerasWeightSnapshot blk) -- ^ TODO + , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk) + -- ^ TODO , closeDB :: m () -- ^ Close the ChainDB -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index d9e508593d..1f59a5dee4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -285,6 +285,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , getStatistics = getEnv h Query.getStatistics , addPerasCertAsync = getEnv1 h ChainSel.addPerasCertAsync , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot + , getPerasCertSnapshot = getEnvSTM h Query.getPerasCertSnapshot } addBlockTestFuse <- newFuse "test chain selection" copyTestFuse <- newFuse "test copy to immutable db" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 46ce86beda..29f2822c92 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -20,6 +20,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getMaxSlotNo , getPastLedger , getPerasWeightSnapshot + , getPerasCertSnapshot , getReadOnlyForkerAtPoint , getStatistics , getTipBlock @@ -59,6 +60,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertSnapshot) import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (eitherToMaybe) @@ -287,6 +289,10 @@ getStatistics CDB{..} = LedgerDB.getTipStatistics cdbLedgerDB getPerasWeightSnapshot :: ChainDbEnv m blk -> STM m (PerasWeightSnapshot blk) getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB +getPerasCertSnapshot :: + ChainDbEnv m blk -> STM m (PerasCertSnapshot blk) +getPerasCertSnapshot CDB{..} = PerasCertDB.getCertSnapshot cdbPerasCertDB + {------------------------------------------------------------------------------- Unifying interface over the immutable DB and volatile DB, but independent of the ledger DB. These functions therefore do not require the entire From 7a8205b7f119a3ff43aeb223fc38a8c49d4057a9 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 2 Sep 2025 11:58:27 +0200 Subject: [PATCH 22/35] Add basic API for certificate validation Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Consensus/Storage/ChainDB/API.hs | 8 +++---- .../Storage/ChainDB/Impl/Background.hs | 2 +- .../Storage/ChainDB/Impl/ChainSel.hs | 6 +++--- .../Consensus/Storage/ChainDB/Impl/Types.hs | 7 +++---- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 9 ++++---- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 21 +++++++++++-------- 6 files changed, 27 insertions(+), 26 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 94cc8870eb..0845d95212 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -392,9 +392,9 @@ data ChainDB m blk = ChainDB , getStatistics :: m (Maybe Statistics) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. - , addPerasCertAsync :: PerasCert blk -> m (AddPerasCertPromise m) - -- ^ TODO - , getPerasWeightSnapshot :: STM m (PerasWeightSnapshot blk) + , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m) + -- ^ TODO docs + , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) -- ^ TODO , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk) -- ^ TODO @@ -530,7 +530,7 @@ newtype AddPerasCertPromise m = AddPerasCertPromise -- impossible). } -addPerasCertSync :: IOLike m => ChainDB m blk -> PerasCert blk -> m () +addPerasCertSync :: IOLike m => ChainDB m blk -> ValidatedPerasCert blk -> m () addPerasCertSync chainDB cert = waitPerasCertProcessed =<< addPerasCertAsync chainDB cert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 6cbffb5483..370e66114d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -647,7 +647,7 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do ChainSelAddPerasCert cert _varProcessed -> traceWith cdbTracer $ TraceAddPerasCertEvent $ - PoppedPerasCertFromQueue (perasCertRound cert) (perasCertBoostedBlock cert) + PoppedPerasCertFromQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert) chainSelSync cdb message lift $ atomically $ processedChainSelMessage cdbChainSelQueue message ) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 8fd3f6d799..eb4f9f23ed 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -328,7 +328,7 @@ addPerasCertAsync :: forall m blk. (IOLike m, HasHeader blk) => ChainDbEnv m blk -> - PerasCert blk -> + ValidatedPerasCert blk -> m (AddPerasCertPromise m) addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue @@ -538,10 +538,10 @@ chainSelSync cdb@CDB{..} (ChainSelAddPerasCert cert varProcessed) = do tracer = TraceAddPerasCertEvent >$< cdbTracer certRound :: PerasRoundNo - certRound = perasCertRound cert + certRound = getPerasCertRound cert boostedBlock :: Point blk - boostedBlock = perasCertBoostedBlock cert + boostedBlock = getPerasCertBoostedBlock cert -- | Return 'True' when the given header should be ignored when adding it -- because it is too old, i.e., we wouldn't be able to switch to a chain diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index ade3907a56..b428779ec8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -550,7 +550,7 @@ data ChainSelMessage m blk ChainSelAddBlock !(BlockToAdd m blk) | -- | Add a Peras certificate ChainSelAddPerasCert - !(PerasCert blk) + !(ValidatedPerasCert blk) -- | Used for 'AddPerasCertPromise'. !(StrictTMVar m ()) | -- | Reprocess blocks that have been postponed by the LoE. @@ -606,7 +606,7 @@ addPerasCertToQueue :: (IOLike m, StandardHash blk) => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> - PerasCert blk -> + ValidatedPerasCert blk -> m (AddPerasCertPromise m) addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do varProcessed <- newEmptyTMVarIO @@ -620,8 +620,7 @@ addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do { waitPerasCertProcessed = atomically $ takeTMVar varProcessed } where - addedToQueue = - AddedPerasCertToQueue (perasCertRound cert) (perasCertBoostedBlock cert) + addedToQueue = AddedPerasCertToQueue (getPerasCertRound cert) (getPerasCertBoostedBlock cert) -- | Try to add blocks again that were postponed due to the LoE. addReprocessLoEBlocks :: diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 37bfa49085..835b5d487c 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -148,7 +148,7 @@ data Model blk = Model -- ^ The VolatileDB , immutableDbChain :: Chain blk -- ^ The ImmutableDB - , perasCerts :: Map PerasRoundNo (PerasCert blk) + , perasCerts :: Map PerasRoundNo (ValidatedPerasCert blk) , cps :: CPS.ChainProducerState blk , currentLedger :: ExtLedgerState blk EmptyMK , initLedger :: ExtLedgerState blk EmptyMK @@ -381,8 +381,7 @@ getLoEFragment = loeFragment perasWeights :: StandardHash blk => Model blk -> PerasWeightSnapshot blk perasWeights = mkPerasWeightSnapshot - -- TODO make boost per cert configurable - . fmap (\c -> (perasCertBoostedBlock c, boostPerCert)) + . fmap (\cert -> (getPerasCertBoostedBlock cert, getPerasCertBoost cert)) . Map.elems . perasCerts @@ -446,7 +445,7 @@ addPerasCert :: forall blk. (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) => TopLevelConfig blk -> - PerasCert blk -> + ValidatedPerasCert blk -> Model blk -> Model blk addPerasCert cfg cert m @@ -457,7 +456,7 @@ addPerasCert cfg cert m cfg m{perasCerts = Map.insert certRound cert (perasCerts m)} where - certRound = perasCertRound cert + certRound = getPerasCertRound cert chainSelection :: forall blk. diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 46c6d9c3c5..d03bfc8196 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -178,7 +178,7 @@ import Test.Util.WithEq -- | Commands data Cmd blk it flr = AddBlock blk - | AddPerasCert (PerasCert blk) + | AddPerasCert (ValidatedPerasCert blk) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -1042,19 +1042,22 @@ generator loe genBlock m@Model{..} = genAddBlock = AddBlock <$> genBlock m - genAddPerasCert :: Gen (PerasCert blk) + genAddPerasCert :: Gen (ValidatedPerasCert blk) genAddPerasCert = do -- TODO chain condition? blk <- genBlock m - let pcCertRound = case Model.maxPerasRoundNo dbModel of + let roundNo = case Model.maxPerasRoundNo dbModel of Nothing -> PerasRoundNo 0 Just (PerasRoundNo r) -> PerasRoundNo (r + 1) - cert = - PerasCert - { pcCertRound - , pcCertBoostedBlock = blockPoint blk - } - pure cert + pure $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boostPerCert + } genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = From 15669b7281eb87698cb08e9c5c12b10f94b2ac7e Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 9 Sep 2025 14:03:54 +0200 Subject: [PATCH 23/35] Peras.SelectView: use fragment length instead of tip `BlockNo` In the presence of EBBs, block numbers can be very misleading, eg the tip block number of a shorter chain can have a higher block number than that of a longer one. To avoid test failures due to this peculiar behavior, we do not look at block numbers at all for the `WeightedSelectView`, and instead measure the length of the fragment (relative to its anchor). Concretely, this change fixes test failures in the ChainDB q-s-m test when testing with eg `k=5` instead of `k=2` (as different candidates can then actually contain *multiple* EBBs). When EBBs are not used (which has been the case on mainnet for >5 years), this change has no semantic impact. Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Peras/SelectView.hs | 143 ++++++++++++++++++ .../Consensus/Storage/ChainDB/API.hs | 1 - .../Consensus/Storage/ChainDB/Impl/Query.hs | 1 - 3 files changed, 143 insertions(+), 2 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs new file mode 100644 index 0000000000..7895a38a93 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Ouroboros.Consensus.Peras.SelectView + ( -- * 'WeightedSelectView' + WeightedSelectView (..) + , wsvTotalWeight + , weightedSelectView + + -- * Utility: 'WithEmptyFragment' + , WithEmptyFragment (..) + , withEmptyFragmentFromMaybe + , withEmptyFragmentToMaybe + ) where + +import Data.Function (on) +import Data.Word (Word64) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF + +{------------------------------------------------------------------------------- + Weighted select views +-------------------------------------------------------------------------------} + +-- | Information from a non-empty chain fragment for a weighted chain comparison +-- against other fragments with the same anchor. +data WeightedSelectView proto = WeightedSelectView + { wsvLength :: !Word64 + -- ^ The length of the fragment. + -- + -- If we ignore EBBs, then it would be equivalent to use the tip 'BlockNo' + -- here. However, with EBBs, the 'BlockNo' can result in misleading + -- comparisons if only one fragment contains EBBs. + , wsvWeightBoost :: !PerasWeight + -- ^ The weight boost of a fragment (w.r.t. a particular anchor). + , wsvTiebreaker :: TiebreakerView proto + -- ^ Lazy because it is only needed when 'wsvTotalWeight' is inconclusive. + } + +deriving stock instance Show (TiebreakerView proto) => Show (WeightedSelectView proto) +deriving stock instance Eq (TiebreakerView proto) => Eq (WeightedSelectView proto) + +-- TODO: More type safety to prevent people from accidentally comparing +-- 'WeightedSelectView's obtained from fragments with different anchors? +-- Something ST-trick like? + +-- | The total weight, ie the sum of 'wsvLength' and 'wsvBoostedWeight'. +wsvTotalWeight :: WeightedSelectView proto -> PerasWeight +-- could be cached, but then we need to be careful to maintain the invariant +wsvTotalWeight wsv = + PerasWeight (wsvLength wsv) <> wsvWeightBoost wsv + +instance Ord (TiebreakerView proto) => Ord (WeightedSelectView proto) where + compare = + mconcat + [ compare `on` wsvTotalWeight + , compare `on` wsvTiebreaker + ] + +instance ChainOrder (TiebreakerView proto) => ChainOrder (WeightedSelectView proto) where + type ChainOrderConfig (WeightedSelectView proto) = ChainOrderConfig (TiebreakerView proto) + + preferCandidate cfg ours cand = + case compare (wsvTotalWeight ours) (wsvTotalWeight cand) of + LT -> True + EQ -> preferCandidate cfg (wsvTiebreaker ours) (wsvTiebreaker cand) + GT -> False + +-- | Get the 'WeightedSelectView' for a fragment using the given +-- 'PerasWeightSnapshot'. Note that this is only meanigful for comparisons +-- against other fragments /with the same anchor/. +-- +-- Returns 'EmptyFragment' iff the input fragment is empty. +weightedSelectView :: + ( GetHeader1 h + , HasHeader (h blk) + , HeaderHash blk ~ HeaderHash (h blk) + , BlockSupportsProtocol blk + ) => + BlockConfig blk -> + PerasWeightSnapshot blk -> + AnchoredFragment (h blk) -> + WithEmptyFragment (WeightedSelectView (BlockProtocol blk)) +weightedSelectView bcfg weights = \case + AF.Empty{} -> EmptyFragment + frag@(_ AF.:> (getHeader1 -> hdr)) -> + NonEmptyFragment + WeightedSelectView + { wsvLength = fromIntegral @Int @Word64 $ AF.length frag + , wsvWeightBoost = weightBoostOfFragment weights frag + , wsvTiebreaker = tiebreakerView bcfg hdr + } + +{------------------------------------------------------------------------------- + WithEmptyFragment +-------------------------------------------------------------------------------} + +-- | Attach the possibility of an empty fragment to a type. +data WithEmptyFragment a = EmptyFragment | NonEmptyFragment !a + deriving stock (Show, Eq) + +withEmptyFragmentToMaybe :: WithEmptyFragment a -> Maybe a +withEmptyFragmentToMaybe = \case + EmptyFragment -> Nothing + NonEmptyFragment a -> Just a + +withEmptyFragmentFromMaybe :: Maybe a -> WithEmptyFragment a +withEmptyFragmentFromMaybe = \case + Nothing -> EmptyFragment + Just a -> NonEmptyFragment a + +-- | Prefer non-empty fragments to empty ones. +instance Ord a => Ord (WithEmptyFragment a) where + compare = \cases + EmptyFragment EmptyFragment -> EQ + EmptyFragment NonEmptyFragment{} -> LT + NonEmptyFragment{} EmptyFragment -> GT + (NonEmptyFragment a) (NonEmptyFragment b) -> compare a b + +-- | Prefer non-empty fragments to empty ones. This instance assumes that the +-- underlying fragments all have the same anchor. +instance ChainOrder a => ChainOrder (WithEmptyFragment a) where + type ChainOrderConfig (WithEmptyFragment a) = ChainOrderConfig a + + preferCandidate cfg = \cases + -- We prefer any non-empty fragment to the empty fragment. + EmptyFragment NonEmptyFragment{} -> True + -- We never prefer the empty fragment to our selection (even if it is also + -- empty). + _ EmptyFragment -> False + -- Otherwise, defer to @'ChainOrder' a@. + (NonEmptyFragment ours) (NonEmptyFragment cand) -> + preferCandidate cfg ours cand diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 0845d95212..505ccec98c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -94,7 +94,6 @@ import Ouroboros.Consensus.Storage.LedgerDB , ReadOnlyForker' , Statistics ) -import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertSnapshot) import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.CallStack diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 29f2822c92..5b9089a9d9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -59,7 +59,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB -import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertSnapshot) import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB From d4d5ca0e6c8e722fe94b92521d968b4da74c20b5 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 11 Sep 2025 17:49:17 +0200 Subject: [PATCH 24/35] Finish plugging PerasCertDB and PerasWeightSnapshot with CertDB Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Consensus/Storage/ChainDB/API.hs | 1 + .../Consensus/Storage/ChainDB/Impl.hs | 11 +++++- .../Consensus/Storage/ChainDB/Impl/Args.hs | 9 +++++ .../Consensus/Storage/ChainDB/Impl/Query.hs | 3 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 4 ++ .../Test/Util/ChainDB.hs | 5 +++ .../Test/Consensus/Peras/WeightSnapshot.hs | 37 +++++++++++++++++++ .../Ouroboros/Storage/ChainDB/StateMachine.hs | 4 ++ 9 files changed, 73 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index f66cd91d93..475fe9c16e 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -198,6 +198,7 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId + Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract Ouroboros.Consensus.Protocol.BFT diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 505ccec98c..f4acfef2a4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -87,6 +87,7 @@ import Ouroboros.Consensus.HeaderStateHistory import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.LedgerDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 1f59a5dee4..a49173a15a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -80,6 +80,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (newFuse, whenJust, withFuse) import Ouroboros.Consensus.Util.Args @@ -174,6 +175,8 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do ledgerDbGetVolatileSuffix traceWith tracer $ TraceOpenEvent OpenedLgrDB + perasCertDB <- PerasCertDB.openDB argsPerasCertDB + varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0)) let initChainSelTracer = TraceInitChainSelEvent >$< tracer @@ -253,6 +256,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , cdbChainSelQueue = chainSelQueue , cdbLoE = Args.cdbsLoE cdbSpecificArgs , cdbChainSelStarvation = varChainSelStarvation + , cdbPerasCertDB = perasCertDB } setGetCurrentChainForLedgerDB $ Query.getCurrentChain env @@ -316,7 +320,12 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do return ((chainDB, testing), env) where tracer = Args.cdbsTracer cdbSpecificArgs - Args.ChainDbArgs argsImmutableDb argsVolatileDb argsLgrDb cdbSpecificArgs = args + Args.ChainDbArgs + argsImmutableDb + argsVolatileDb + argsLgrDb + argsPerasCertDB + cdbSpecificArgs = args -- The LedgerDB requires a criterion ('LedgerDB.GetVolatileSuffix') -- determining which of its states are volatile/immutable. Once we have diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index db793c8f0d..cc285627a4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -41,6 +41,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB (LedgerDbFlavorArgs) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.Snapshots +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike @@ -54,6 +55,7 @@ data ChainDbArgs f m blk = ChainDbArgs { cdbImmDbArgs :: ImmutableDB.ImmutableDbArgs f m blk , cdbVolDbArgs :: VolatileDB.VolatileDbArgs f m blk , cdbLgrDbArgs :: LedgerDB.LedgerDbArgs f m blk + , cdbPerasCertDbArgs :: PerasCertDB.PerasCertDbArgs f m blk , cdbsArgs :: ChainDbSpecificArgs f m blk } @@ -138,6 +140,7 @@ defaultArgs = ImmutableDB.defaultArgs VolatileDB.defaultArgs LedgerDB.defaultArgs + PerasCertDB.defaultArgs defaultSpecificArgs ensureValidateAll :: @@ -209,6 +212,10 @@ completeChainDbArgs , LedgerDB.lgrFlavorArgs = flavorArgs , LedgerDB.lgrRegistry = registry } + , cdbPerasCertDbArgs = + PerasCertDB.PerasCertDbArgs + { PerasCertDB.pcdbaTracer = PerasCertDB.pcdbaTracer (cdbPerasCertDbArgs defArgs) + } , cdbsArgs = (cdbsArgs defArgs) { cdbsRegistry = registry @@ -226,6 +233,8 @@ updateTracer trcr args = { cdbImmDbArgs = (cdbImmDbArgs args){ImmutableDB.immTracer = TraceImmutableDBEvent >$< trcr} , cdbVolDbArgs = (cdbVolDbArgs args){VolatileDB.volTracer = TraceVolatileDBEvent >$< trcr} , cdbLgrDbArgs = (cdbLgrDbArgs args){LedgerDB.lgrTracer = TraceLedgerDBEvent >$< trcr} + , cdbPerasCertDbArgs = + (cdbPerasCertDbArgs args){PerasCertDB.pcdbaTracer = TracePerasCertDbEvent >$< trcr} , cdbsArgs = (cdbsArgs args){cdbsTracer = trcr} } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs index 5b9089a9d9..353bae1f65 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Query.hs @@ -285,7 +285,8 @@ getReadOnlyForkerAtPoint CDB{..} = LedgerDB.getReadOnlyForker cdbLedgerDB getStatistics :: IOLike m => ChainDbEnv m blk -> m (Maybe LedgerDB.Statistics) getStatistics CDB{..} = LedgerDB.getTipStatistics cdbLedgerDB -getPerasWeightSnapshot :: ChainDbEnv m blk -> STM m (PerasWeightSnapshot blk) +getPerasWeightSnapshot :: + ChainDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) getPerasWeightSnapshot CDB{..} = PerasCertDB.getWeightSnapshot cdbPerasCertDB getPerasCertSnapshot :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index b428779ec8..f65eee1eee 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -127,6 +127,8 @@ import Ouroboros.Consensus.Storage.LedgerDB , LedgerDbSerialiseConstraints ) import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB +import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDB) +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Storage.VolatileDB ( VolatileDB @@ -352,6 +354,7 @@ data ChainDbEnv m blk = CDB , cdbChainSelStarvation :: !(StrictTVar m ChainSelStarvation) -- ^ Information on the last starvation of ChainSel, whether ongoing or -- ended recently. + , cdbPerasCertDB :: !(PerasCertDB m blk) } deriving Generic @@ -746,6 +749,7 @@ data TraceEvent blk | TraceLedgerDBEvent (LedgerDB.TraceEvent blk) | TraceImmutableDBEvent (ImmutableDB.TraceEvent blk) | TraceVolatileDBEvent (VolatileDB.TraceEvent blk) + | TracePerasCertDbEvent (PerasCertDB.TraceEvent blk) | TraceLastShutdownUnclean | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk) | TraceAddPerasCertEvent (TraceAddPerasCertEvent blk) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index d32ee6522b..75110df40e 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -32,6 +32,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.V2.Args +import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDbArgs (..)) import Ouroboros.Consensus.Storage.VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args @@ -135,6 +136,10 @@ fromMinimalChainDbArgs MinimalChainDbArgs{..} = , lgrQueryBatchSize = DefaultQueryBatchSize , lgrStartSnapshot = Nothing } + , cdbPerasCertDbArgs = + PerasCertDbArgs + { pcdbaTracer = nullTracer + } , cdbsArgs = ChainDbSpecificArgs { cdbsBlocksToAddSize = 1 diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs index f192cd8f18..59fd52d636 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs @@ -14,12 +14,14 @@ -- and fragments. module Test.Consensus.Peras.WeightSnapshot (tests) where +import Cardano.Ledger.BaseTypes (unNonZero) import Data.Containers.ListUtils (nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) import Data.Traversable (for) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Util.Condense import Ouroboros.Network.AnchoredFragment (AnchoredFragment) @@ -54,12 +56,26 @@ prop_perasWeightSnapshot testSetup = weightBoostOfFragmentReference frag =:= weightBoostOfFragment snap frag | frag <- tsFragments ] + , conjoin + [ conjoin + [ counterexample ("Incorrect volatile suffix for " <> condense frag) $ + takeVolatileSuffixReference frag =:= volSuffix + , counterexample ("Volatile suffix must be a suffix of" <> condense frag) $ + AF.headPoint frag =:= AF.headPoint volSuffix + .&&. AF.withinFragmentBounds (AF.anchorPoint volSuffix) frag + , counterexample ("Volatile suffix of " <> condense frag <> " must contain at most k blocks") $ + AF.length volSuffix `le` fromIntegral (unNonZero (maxRollbacks tsSecParam)) + ] + | frag <- tsFragments + , let volSuffix = takeVolatileSuffix snap tsSecParam frag + ] ] where TestSetup { tsWeights , tsPoints , tsFragments + , tsSecParam } = testSetup snap = mkPerasWeightSnapshot $ Map.toList tsWeights @@ -73,12 +89,27 @@ prop_perasWeightSnapshot testSetup = (weightBoostOfPointReference . blockPoint) (AF.toOldestFirst frag) + takeVolatileSuffixReference :: + AnchoredFragment TestBlock -> AnchoredFragment TestBlock + takeVolatileSuffixReference frag = + head + [ suffix + | len <- reverse [0 .. AF.length frag] + , -- Consider suffixes of @frag@, longest first + let suffix = AF.anchorNewest (fromIntegral len) frag + weightBoost = weightBoostOfFragmentReference suffix + lengthWeight = PerasWeight (fromIntegral (AF.length suffix)) + totalWeight = lengthWeight <> weightBoost + , totalWeight <= maxRollbackWeight tsSecParam + ] + data TestSetup = TestSetup { tsWeights :: Map (Point TestBlock) PerasWeight , tsPoints :: [Point TestBlock] -- ^ Check the weight of these points. , tsFragments :: [AnchoredFragment TestBlock] -- ^ Check the weight of these fragments. + , tsSecParam :: SecurityParam } deriving stock Show @@ -106,11 +137,13 @@ instance Arbitrary TestSetup where pure $ AF.dropNewest nDropNewest $ AF.anchorNewest (fromIntegral nTakeNewest) fullFrag + tsSecParam <- arbitrary pure TestSetup { tsWeights , tsPoints , tsFragments + , tsSecParam } shrink ts = @@ -128,6 +161,9 @@ instance Arbitrary TestSetup where , [ ts{tsFragments = tsFragments'} | tsFragments' <- shrinkList (\_frag -> []) tsFragments ] + , [ ts{tsSecParam = tsSecParam'} + | tsSecParam' <- shrink tsSecParam + ] ] where w1 = PerasWeight 1 @@ -136,4 +172,5 @@ instance Arbitrary TestSetup where { tsWeights , tsPoints , tsFragments + , tsSecParam } = ts diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index d03bfc8196..3eb081bfd5 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -127,6 +127,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal import Ouroboros.Consensus.Storage.LedgerDB (LedgerSupportsLedgerDB) import qualified Ouroboros.Consensus.Storage.LedgerDB.TraceEvent as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as DbChangelog +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (split) import Ouroboros.Consensus.Util.CallStack @@ -1371,6 +1372,8 @@ deriving instance SOP.Generic (ImmutableDB.TraceEvent blk) deriving instance SOP.HasDatatypeInfo (ImmutableDB.TraceEvent blk) deriving instance SOP.Generic (VolatileDB.TraceEvent blk) deriving instance SOP.HasDatatypeInfo (VolatileDB.TraceEvent blk) +deriving instance SOP.Generic (PerasCertDB.TraceEvent blk) +deriving instance SOP.HasDatatypeInfo (PerasCertDB.TraceEvent blk) deriving anyclass instance SOP.Generic (TraceChainSelStarvationEvent blk) deriving anyclass instance SOP.HasDatatypeInfo (TraceChainSelStarvationEvent blk) deriving anyclass instance SOP.Generic (TraceAddPerasCertEvent blk) @@ -1816,6 +1819,7 @@ traceEventName = \case TraceLedgerDBEvent ev -> "Ledger." <> constrName ev TraceImmutableDBEvent ev -> "ImmutableDB." <> constrName ev TraceVolatileDBEvent ev -> "VolatileDB." <> constrName ev + TracePerasCertDbEvent ev -> "PerasCertDB." <> constrName ev TraceLastShutdownUnclean -> "LastShutdownUnclean" TraceChainSelStarvationEvent ev -> "ChainSelStarvation." <> constrName ev TraceAddPerasCertEvent ev -> "AddPerasCert." <> constrName ev From 0c0438a36738e99ac3f2015339ccb48742527045 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Tue, 16 Sep 2025 18:27:06 +0200 Subject: [PATCH 25/35] Fix TODOs or add link to issue Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Storage/ChainDB/API.hs | 6 +++--- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 12 ++++-------- .../Test/Ouroboros/Storage/ChainDB/Model/Test.hs | 1 + .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs | 3 ++- 4 files changed, 10 insertions(+), 12 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index f4acfef2a4..f86194ca83 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -393,11 +393,11 @@ data ChainDB m blk = ChainDB -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m) - -- ^ TODO docs + -- ^ Asynchronously insert a certificate to the DB. , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) - -- ^ TODO + -- ^ Get the weight snapshot from the DB. , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk) - -- ^ TODO + -- ^ Get the certificate snapshot from the DB. , closeDB :: m () -- ^ Close the ChainDB -- diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 835b5d487c..910c7e1130 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -1086,6 +1086,7 @@ garbageCollect secParam m@Model{..} = m { volatileDbBlocks = Map.filter (not . collectable) volatileDbBlocks -- TODO garbage collection Peras certs? + -- See https://github.com/tweag/cardano-peras/issues/121 } where -- TODO what about iterators that will stream garbage collected blocks? @@ -1125,6 +1126,8 @@ closeDB m@Model{..} = reopen :: Model blk -> Model blk reopen m = m{isOpen = True} +-- TODO: update to account for persisted Peras certificates. +-- see https://github.com/tweag/cardano-peras/issues/122 wipeVolatileDB :: forall blk. (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) => @@ -1137,14 +1140,7 @@ wipeVolatileDB cfg m = m' = (closeDB m) { volatileDbBlocks = Map.empty - , -- TODO: Currently, the SUT has no persistence of Peras certs across - -- restarts, but this will change. There are at least two options: - -- - -- * Change this command to mean "wipe volatile state" (including - -- volatile certificates) - -- - -- * Add a separate "Wipe volatile certs". - perasCerts = Map.empty + , perasCerts = Map.empty , cps = CPS.switchFork newChain (cps m) , currentLedger = newLedger , invalid = Map.empty diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs index 0b2410f68f..b991a13da6 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model/Test.hs @@ -107,6 +107,7 @@ prop_alwaysPickPreferredChain bt p = candFragment = Chain.toAnchoredFragment (getHeader <$> candidate) -- TODO test with non-trivial weights + -- see https://github.com/tweag/cardano-peras/issues/123 weights :: PerasWeightSnapshot TestBlock weights = emptyPerasWeightSnapshot diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 3eb081bfd5..e3a787a6c6 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -1045,7 +1045,8 @@ generator loe genBlock m@Model{..} = genAddPerasCert :: Gen (ValidatedPerasCert blk) genAddPerasCert = do - -- TODO chain condition? + -- TODO should we be more strict on which blocks we add certs to? + -- see https://github.com/tweag/cardano-peras/issues/124 blk <- genBlock m let roundNo = case Model.maxPerasRoundNo dbModel of Nothing -> PerasRoundNo 0 From f1158c076060e966024227cccb46d4376e131da7 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Wed, 17 Sep 2025 15:12:05 +0200 Subject: [PATCH 26/35] Add changelog entry Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ...5435_thomas.bagrel_weighted_chain_selec.md | 23 +++++++++++++++++++ ...46_nicolas.bacquey_weighted_chain_selec.md | 23 +++++++++++++++++++ 2 files changed, 46 insertions(+) create mode 100644 ouroboros-consensus-diffusion/changelog.d/20250919_095435_thomas.bagrel_weighted_chain_selec.md create mode 100644 ouroboros-consensus/changelog.d/20250917_144846_nicolas.bacquey_weighted_chain_selec.md diff --git a/ouroboros-consensus-diffusion/changelog.d/20250919_095435_thomas.bagrel_weighted_chain_selec.md b/ouroboros-consensus-diffusion/changelog.d/20250919_095435_thomas.bagrel_weighted_chain_selec.md new file mode 100644 index 0000000000..e233858749 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20250919_095435_thomas.bagrel_weighted_chain_selec.md @@ -0,0 +1,23 @@ + + + + + +### Breaking + +- In module `Ouroboros.Consensus.Node.GSM`, `GSMView` now has a monadic `getCandidateOverSelection :: STM m ( selection -> chainSyncState -> CandidateVersusSelection)` instead of the previous pure `candidateOverSelection`. diff --git a/ouroboros-consensus/changelog.d/20250917_144846_nicolas.bacquey_weighted_chain_selec.md b/ouroboros-consensus/changelog.d/20250917_144846_nicolas.bacquey_weighted_chain_selec.md new file mode 100644 index 0000000000..e446f1019f --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250917_144846_nicolas.bacquey_weighted_chain_selec.md @@ -0,0 +1,23 @@ + + + + +### Breaking + +- Make the `ChainDB` aware of `CertDB`, and modify the chain selection function accordingly. In practice, it means that the candidate fragment is now selected based on its Peras weight, instead of its length. +- Add module `Ouroboros.Consensus.Peras.SelectView`, which introduces views to correctly measure the length of a chain fragment when accounting for EBBs. From 2d9eb41e2756065d062e3e8880b8774990961385 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 12 Sep 2025 14:37:41 +0200 Subject: [PATCH 27/35] Change s-r-p for `ouroboros-network` to add ObjectDiffusion support Also use defaultMiniProtocolParameters instead of hardcoded value in unstable-diffusion-testlib to account for newly defined parameters in the new `ouroboros-network` version. Also integrate `NodeToNodeV_16`. Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- cabal.project | 6 ++++-- .../Ouroboros/Consensus/Cardano/Node.hs | 1 + .../Consensus/Shelley/Ledger/NetworkProtocolVersion.hs | 1 + .../Test/ThreadNet/Network.hs | 10 ++-------- 4 files changed, 8 insertions(+), 10 deletions(-) diff --git a/cabal.project b/cabal.project index 42c8cafd79..68bdf33fb2 100644 --- a/cabal.project +++ b/cabal.project @@ -59,8 +59,10 @@ allow-newer: source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: b07a86ed853b63881b5a83e57508902f1562ac01 - --sha256: sha256-n/XX0+cQegq2a1cAfmGx30T64eix4oEXzpVEFCKqmg0= + tag: 8dfff7b8916f7a56b2a3773438d5e5530c780710 + --sha256: sha256-wMDq19G1SW4+puuQUUjgaULSou4+r7wJj6evnWoW/Xk= subdir: + ouroboros-network + ouroboros-network-protocols ouroboros-network-api ouroboros-network 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 52a7e4f910..98093f86c5 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 @@ -430,6 +430,7 @@ instance Map.fromList $ [ (NodeToNodeV_14, CardanoNodeToNodeVersion2) , (NodeToNodeV_15, CardanoNodeToNodeVersion2) + , (NodeToNodeV_16, CardanoNodeToNodeVersion2) ] supportedNodeToClientVersions _ = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs index c03e0e5179..7003a5ce8a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs @@ -48,6 +48,7 @@ instance SupportedNetworkProtocolVersion (ShelleyBlock proto era) where Map.fromList [ (NodeToNodeV_14, ShelleyNodeToNodeVersion1) , (NodeToNodeV_15, ShelleyNodeToNodeVersion1) + , (NodeToNodeV_16, ShelleyNodeToNodeVersion1) ] supportedNodeToClientVersions _ = Map.fromList diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 6df036c539..847659c2ad 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -123,8 +123,8 @@ import Ouroboros.Network.NodeToNode ( ConnectionId (..) , ExpandedInitiatorContext (..) , IsBigLedgerPeer (..) - , MiniProtocolParameters (..) , ResponderContext (..) + , defaultMiniProtocolParameters ) import Ouroboros.Network.PeerSelection.Governor ( makePublicPeerSelectionStateVar @@ -1056,13 +1056,7 @@ runThreadNetwork , mempoolCapacityOverride = NoMempoolCapacityBytesOverride , keepAliveRng = kaRng , peerSharingRng = psRng - , miniProtocolParameters = - MiniProtocolParameters - { chainSyncPipeliningHighMark = 4 - , chainSyncPipeliningLowMark = 2 - , blockFetchPipeliningMax = 10 - , txSubmissionMaxUnacked = 1000 -- TODO ? - } + , miniProtocolParameters = defaultMiniProtocolParameters , blockFetchConfiguration = BlockFetchConfiguration { bfcMaxConcurrencyBulkSync = 1 From 2676153800a6dc47431cd63ed5f00199a2584636 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 12 Sep 2025 14:40:00 +0200 Subject: [PATCH 28/35] Implement general ObjectDiffusion protocol, and related `ObjectPool{Reader,Writer}` API Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 3 + .../MiniProtocol/ObjectDiffusion/Inbound.hs | 483 ++++++++++++++++++ .../ObjectDiffusion/ObjectPool/API.hs | 59 +++ .../MiniProtocol/ObjectDiffusion/Outbound.hs | 244 +++++++++ 4 files changed, 789 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 475fe9c16e..580d3206e2 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -191,6 +191,9 @@ library Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound Ouroboros.Consensus.Node.GsmState Ouroboros.Consensus.Node.InitStorage Ouroboros.Consensus.Node.NetworkProtocolVersion diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs new file mode 100644 index 0000000000..b9eac78989 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + ( objectDiffusionInbound + , TraceObjectDiffusionInbound (..) + , ObjectDiffusionInboundError (..) + , NumObjectsProcessed (..) + ) where + +import Cardano.Prelude (catMaybes) +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked +import Control.Exception (assert) +import Control.Monad (when) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) +import Data.Foldable as Foldable (foldl', toList) +import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as Seq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Word (Word64) +import GHC.Generics (Generic) +import Network.TypedProtocol.Core (N (Z), Nat (..), natToInt) +import NoThunks.Class (NoThunks (..), unsafeNoThunks) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Network.ControlMessage +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + +-- Note: This module is inspired from TxSubmission inbound side. + +newtype NumObjectsProcessed + = NumObjectsProcessed + { getNumObjectsProcessed :: Word64 + } + deriving (Eq, Show) + +data TraceObjectDiffusionInbound objectId object + = -- | Number of objects just about to be inserted. + TraceObjectDiffusionCollected Int + | -- | Just processed object pass/fail breakdown. + TraceObjectDiffusionProcessed NumObjectsProcessed + | -- | Received a 'ControlMessage' from the outbound peer governor, and about + -- to act on it. + TraceObjectDiffusionControlMessage ControlMessage + | TraceObjectInboundCanRequestMoreObjects Int + | TraceObjectInboundCannotRequestMoreObjects Int + deriving (Eq, Show) + +data ObjectDiffusionInboundError + = ProtocolErrorObjectNotRequested + | ProtocolErrorObjectIdsNotRequested + | ProtocolErrorObjectIdAlreadyKnown + | ProtocolErrorObjectIdsDuplicate + deriving Show + +instance Exception ObjectDiffusionInboundError where + displayException ProtocolErrorObjectNotRequested = + "The peer replied with a object we did not ask for." + displayException ProtocolErrorObjectIdsNotRequested = + "The peer replied with more objectIds than we asked for." + displayException ProtocolErrorObjectIdAlreadyKnown = + "The peer replied with an objectId that it has already sent us previously." + displayException ProtocolErrorObjectIdsDuplicate = + "The peer replied with a batch of objectIds containing a duplicate." + +-- | Information maintained internally in the 'objectDiffusionInbound' +-- implementation. +data InboundSt objectId object = InboundSt + { numIdsInFlight :: !NumObjectIdsReq + -- ^ The number of object identifiers that we have requested but + -- which have not yet been replied to. We need to track this to keep + -- our requests within the limit on the 'outstandingFifo' size. + , outstandingFifo :: !(StrictSeq objectId) + -- ^ This mirrors the queue of objects that the outbound peer has available + -- for us. Objects are kept in the order in which the outbound peer + -- advertised them to us. This is the same order in which we submit them to + -- the objectPool. It is also the order we acknowledge them. + , canRequestNext :: !(Set objectId) + -- ^ The objectIds that we can request. These are a subset of the + -- 'outstandingFifo' that we have not yet requested or not have in the pool + -- already. This is not ordered to illustrate the fact that we can + -- request objects out of order. + , pendingObjects :: !(Map objectId (Maybe object)) + -- ^ Objects we have successfully downloaded (or decided intentionally to + -- skip download) but have not yet added to the objectPool or acknowledged. + -- + -- Object IDs in this 'Map' are mapped to 'Nothing' if we notice that + -- they are already in the objectPool. That way we can skip requesting them + -- from the outbound peer, but still acknowledge them when the time comes. + , numToAckOnNextReq :: !NumObjectIdsAck + -- ^ The number of objects we can acknowledge on our next request + -- for more object IDs. Their corresponding IDs have already been removed + -- from 'outstandingFifo'. + } + deriving stock (Show, Generic) + deriving anyclass NoThunks + +initialInboundSt :: InboundSt objectId object +initialInboundSt = InboundSt 0 Seq.empty Set.empty Map.empty 0 + +objectDiffusionInbound :: + forall objectId object m. + ( Ord objectId + , NoThunks objectId + , NoThunks object + , MonadSTM m + , MonadThrow m + ) => + Tracer m (TraceObjectDiffusionInbound objectId object) -> + -- | Maximum values for outstanding FIFO length, number of IDs to request, + -- and number of objects to request + (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) -> + ObjectPoolWriter objectId object m -> + NodeToNodeVersion -> + ControlMessageSTM m -> + ObjectDiffusionInboundPipelined objectId object m () +objectDiffusionInbound + tracer + (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) + ObjectPoolWriter{..} + _version + controlMessageSTM = + ObjectDiffusionInboundPipelined $ do + continueWithStateM (go Zero) initialInboundSt + where + canRequestMoreObjects :: InboundSt k object -> Bool + canRequestMoreObjects st = + not (Set.null (canRequestNext st)) + + -- Computes how many new IDs we can request so that receiving all of them + -- won't make 'outstandingFifo' exceed 'maxFifoLength'. + numIdsToReq :: InboundSt objectId object -> NumObjectIdsReq + numIdsToReq st = + maxNumIdsToReq + `min` ( fromIntegral maxFifoLength + - (fromIntegral $ Seq.length $ outstandingFifo st) + - numIdsInFlight st + ) + + -- Updates 'InboundSt' with new object IDs and return the updated 'InboundSt'. + -- + -- Collected object IDs that are already in the objectPool are pre-emptively + -- acknowledged so that we don't need to bother requesting them from the + -- outbound peer. + preAcknowledge :: + InboundSt objectId object -> + (objectId -> Bool) -> + [objectId] -> + InboundSt objectId object + preAcknowledge st _ collectedIds | null collectedIds = st + preAcknowledge st poolHasObject collectedIds = + let + -- Divide the collected IDs in two parts: those that are already in the + -- objectPool and those that are not. + (alreadyObtained, notYetObtained) = + List.partition + (\objectId -> poolHasObject objectId) + collectedIds + + -- The objects that we intentionally don't request, because they are + -- already in the objectPool, will need to be acknowledged. + -- So we extend 'pendingObjects' with those objects (so of course they + -- have no corresponding reply). + pendingObjects' = + pendingObjects st + <> Map.fromList [(objectId, Nothing) | objectId <- alreadyObtained] + + -- We initially extend 'outstandingFifo' with the all the collected IDs + -- (to properly mirror the server state). + outstandingFifo' = outstandingFifo st <> Seq.fromList collectedIds + + -- Now check if the update of 'pendingObjects' let us acknowledge a prefix + -- of the 'outstandingFifo', as we do in 'goCollect' -> 'CollectObjects'. + (objectIdsToAck, outstandingFifo'') = + Seq.spanl (`Map.member` pendingObjects') outstandingFifo' + + -- If so we can remove them from the 'pendingObjects' structure. + -- + -- Note that unlike in TX-Submission, we made sure the outstanding FIFO + -- couldn't have duplicate IDs, so we don't have to worry about re-adding + -- the duplicate IDs to 'pendingObjects' for future acknowledgment. + pendingObjects'' = + Foldable.foldl' + (flip Map.delete) + pendingObjects' + objectIdsToAck + in + st + { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained) + , pendingObjects = pendingObjects'' + , outstandingFifo = outstandingFifo'' + , numToAckOnNextReq = + numToAckOnNextReq st + + fromIntegral (Seq.length objectIdsToAck) + } + + go :: + forall (n :: N). + Nat n -> + StatefulM (InboundSt objectId object) n objectId object m + go n = StatefulM $ \st -> do + -- Check whether we should continue engaging in the protocol. + ctrlMsg <- atomically controlMessageSTM + traceWith tracer $ TraceObjectDiffusionControlMessage ctrlMsg + case ctrlMsg of + -- The peer selection governor is asking us to terminate the connection. + Terminate -> + pure $ terminateAfterDrain n + -- Otherwise, we can continue the protocol normally. + _continue -> case n of + -- We didn't pipeline any requests, so there are no replies in flight + -- (nothing to collect) + Zero -> do + if canRequestMoreObjects st + then do + -- There are no replies in flight, but we do know some more objects + -- we can ask for, so lets ask for them and more objectIds in a + -- pipelined way. + traceWith tracer (TraceObjectInboundCanRequestMoreObjects (natToInt n)) + pure $ continueWithState (goReqObjectsAndObjectIdsPipelined Zero) st + else do + -- There's no replies in flight, and we have no more objects we can + -- ask for so the only remaining thing to do is to ask for more + -- objectIds. Since this is the only thing to do now, we make this a + -- blocking call. + traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n)) + pure $ continueWithState goReqObjectIdsBlocking st + + -- We have pipelined some requests, so there are some replies in flight. + Succ n' -> + if canRequestMoreObjects st + then do + -- We have replies in flight and we should eagerly collect them if + -- available, but there are objects to request too so we + -- should *not* block waiting for replies. + -- So we ask for new objects and objectIds in a pipelined way. + traceWith tracer (TraceObjectInboundCanRequestMoreObjects (natToInt n)) + pure $ + CollectPipelined + (Just (continueWithState (goReqObjectsAndObjectIdsPipelined (Succ n')) st)) + (collectAndContinueWithState (goCollect n') st) + else do + traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n)) + -- In this case we can theoretically only collect replies or request + -- new object IDs. + -- + -- But it's important not to pipeline more requests for objectIds now + -- because if we did, then immediately after sending the request (but + -- having not yet received a response to either this or the other + -- pipelined requests), we would directly re-enter this code path, + -- resulting us in filling the pipeline with an unbounded number of + -- requests. + -- + -- So we instead block until we collect a reply. + pure $ + CollectPipelined + Nothing + (collectAndContinueWithState (goCollect n') st) + + goCollect :: + forall (n :: N). + Nat n -> + StatefulCollect (InboundSt objectId object) n objectId object m + goCollect n = StatefulCollect $ \st collect -> case collect of + CollectObjectIds numIdsRequested collectedIds -> do + let numCollectedIds = length collectedIds + collectedIdsSet = Set.fromList collectedIds + + -- Check they didn't send more than we asked for. We don't need to + -- check for a minimum: the blocking case checks for non-zero + -- elsewhere, and for the non-blocking case it is quite normal for + -- them to send us none. + when (numCollectedIds > fromIntegral numIdsRequested) $ + throwIO ProtocolErrorObjectIdsNotRequested + + -- Check that the server didn't send IDs that were already in the + -- outstanding FIFO + when (any (`Set.member` collectedIdsSet) (outstandingFifo st)) $ + throwIO ProtocolErrorObjectIdAlreadyKnown + + -- Check that the server didn't send duplicate IDs in its response + when (Set.size collectedIdsSet /= numCollectedIds) $ + throwIO ProtocolErrorObjectIdsDuplicate + + -- We extend our outstanding FIFO with the newly received objectIds by + -- calling 'preAcknowledge' which will also pre-emptively acknowledge the + -- objectIds that we already have in the pool and thus don't need to + -- request. + let st' = st{numIdsInFlight = numIdsInFlight st - numIdsRequested} + poolHasObject <- atomically $ opwHasObject + continueWithStateM + (go n) + (preAcknowledge st' poolHasObject collectedIds) + CollectObjects requestedIds collectedObjects -> do + let requestedIdsSet = Set.fromList requestedIds + obtainedIdsSet = Set.fromList (opwObjectId <$> collectedObjects) + + -- To start with we have to verify that the objects they have sent us are + -- exactly the objects we asked for, not more, not less. + when (requestedIdsSet /= obtainedIdsSet) $ + throwIO ProtocolErrorObjectNotRequested + + traceWith tracer $ + TraceObjectDiffusionCollected (length collectedObjects) + + -- We update 'pendingObjects' with the newly obtained objects + let newPendingObjects :: Map objectId (Maybe object) + newPendingObjects = Map.fromList [(opwObjectId obj, Just obj) | obj <- collectedObjects] + pendingObjects' = pendingObjects st <> newPendingObjects + + -- We then find the longest prefix of 'outstandingFifo' for which we have + -- all the corresponding IDs in 'pendingObjects'. + -- We remove this prefix from 'outstandingFifo'. + (objectIdsToAck, outstandingFifo') = + Seq.spanl (`Map.member` pendingObjects') (outstandingFifo st) + + -- And also remove these entries from 'pendingObjects'. + -- + -- Note that unlike in TX-Submission, we made sure the outstanding FIFO + -- couldn't have duplicate IDs, so we don't have to worry about re-adding + -- the duplicate IDs to 'pendingObjects' for future acknowledgment. + pendingObjects'' = + Foldable.foldl' + (flip Map.delete) + pendingObjects' + objectIdsToAck + + -- These are the objects we need to submit to the object pool + objectsToAck = + catMaybes $ + (((Map.!) pendingObjects') <$> toList objectIdsToAck) + + opwAddObjects objectsToAck + traceWith tracer $ + TraceObjectDiffusionProcessed + (NumObjectsProcessed (fromIntegral $ length objectsToAck)) + continueWithStateM + (go n) + st + { pendingObjects = pendingObjects'' + , outstandingFifo = outstandingFifo' + , numToAckOnNextReq = + numToAckOnNextReq st + + fromIntegral (Seq.length objectIdsToAck) + } + + goReqObjectIdsBlocking :: Stateful (InboundSt objectId object) 'Z objectId object m + goReqObjectIdsBlocking = Stateful $ \st -> do + let numIdsToRequest = numIdsToReq st + -- We should only request new object IDs in a blocking way if we have + -- absolutely nothing else we can do. + assert + ( numIdsInFlight st == 0 + && Seq.null (outstandingFifo st) + && Set.null (canRequestNext st) + && Map.null (pendingObjects st) + ) + $ SendMsgRequestObjectIdsBlocking + (numToAckOnNextReq st) + numIdsToRequest + ( \neCollectedIds -> + collectAndContinueWithState + (goCollect Zero) + st + { numToAckOnNextReq = 0 + , numIdsInFlight = numIdsToRequest + } + (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) + ) + + goReqObjectsAndObjectIdsPipelined :: + forall (n :: N). + Nat n -> + Stateful (InboundSt objectId object) n objectId object m + goReqObjectsAndObjectIdsPipelined n = Stateful $ \st -> do + -- TODO: This implementation is deliberately naive, we pick in an + -- arbitrary order. We may want to revisit this later. + let (toRequest, canRequestNext') = + Set.splitAt (fromIntegral maxNumObjectsToReq) (canRequestNext st) + + SendMsgRequestObjectsPipelined + (toList toRequest) + ( continueWithStateM + (goReqObjectIdsPipelined (Succ n)) + st{canRequestNext = canRequestNext'} + ) + + goReqObjectIdsPipelined :: + forall (n :: N). + Nat n -> + StatefulM (InboundSt objectId object) n objectId object m + goReqObjectIdsPipelined n = StatefulM $ \st -> do + let numIdsToRequest = numIdsToReq st + + if numIdsToRequest <= 0 + then continueWithStateM (go n) st + else + pure $ + SendMsgRequestObjectIdsPipelined + (numToAckOnNextReq st) + numIdsToRequest + ( continueWithStateM + (go (Succ n)) + st + { numIdsInFlight = + numIdsInFlight st + + numIdsToRequest + , numToAckOnNextReq = 0 + } + ) + + -- Ignore all outstanding replies to messages we pipelined ("drain"), and then + -- terminate. + terminateAfterDrain :: + Nat n -> InboundStIdle n objectId object m () + terminateAfterDrain = \case + Zero -> SendMsgDone (pure ()) + Succ n -> CollectPipelined Nothing $ \_ignoredMsg -> pure $ terminateAfterDrain n + +------------------------------------------------------------------------------- +-- Utilities to deal with stateful continuations (copied from TX-submission) +------------------------------------------------------------------------------- + +newtype Stateful s n objectId object m = Stateful (s -> InboundStIdle n objectId object m ()) + +newtype StatefulM s n objectId object m + = StatefulM (s -> m (InboundStIdle n objectId object m ())) + +newtype StatefulCollect s n objectId object m + = StatefulCollect (s -> Collect objectId object -> m (InboundStIdle n objectId object m ())) + +-- | After checking that there are no unexpected thunks in the provided state, +-- pass it to the provided function. +-- +-- See 'checkInvariant' and 'unsafeNoThunks'. +continueWithState :: + NoThunks s => + Stateful s n objectId object m -> + s -> + InboundStIdle n objectId object m () +continueWithState (Stateful f) !st = + checkInvariant (show <$> unsafeNoThunks st) (f st) + +-- | A variant of 'continueWithState' to be more easily utilized with +-- 'inboundIdle' and 'inboundReqObjectIds'. +continueWithStateM :: + NoThunks s => + StatefulM s n objectId object m -> + s -> + m (InboundStIdle n objectId object m ()) +continueWithStateM (StatefulM f) !st = + checkInvariant (show <$> unsafeNoThunks st) (f st) +{-# NOINLINE continueWithStateM #-} + +-- | A variant of 'continueWithState' to be more easily utilized with +-- 'handleReply'. +collectAndContinueWithState :: + NoThunks s => + StatefulCollect s n objectId object m -> + s -> + Collect objectId object -> + m (InboundStIdle n objectId object m ()) +collectAndContinueWithState (StatefulCollect f) !st c = + checkInvariant (show <$> unsafeNoThunks st) (f st c) +{-# NOINLINE collectAndContinueWithState #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs new file mode 100644 index 0000000000..2f949d8b3b --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs @@ -0,0 +1,59 @@ +-- | API for reading from and writing to object pools in the ObjectDiffusion +-- miniprotocol. +-- +-- The underlying object pool can be any database, such as a 'PerasCertDb' in +-- Peras certificate diffusion. +-- +-- 'ObjectPoolReader' is used on the outbound side of the protocol. Objects in +-- the pool are ordered by a strictly increasing ticket number ('ticketNo'), +-- which represents their time of arrival. Ticket numbers are local to each +-- node, unlike object IDs, which are global. Object IDs are not used for +-- ordering, since objects may arrive slightly out of order from peers. +-- +-- To read from the pool, one requests objects with a ticket number strictly +-- greater than the last known one. 'oprZeroTicketNo' provides an initial ticket +-- number for the first request. +-- +-- 'ObjectPoolWriter' is used on the inbound side of the protocol. It allows +-- checking whether an object is already present (to avoid re-requesting it) and +-- appending new objects. Ticket numbers are not part of the inbound interface, +-- but are used internally: newly added objects always receive a ticket number +-- strictly greater than those of older ones. +-- +-- This API design is inspired by 'MempoolSnapshot' from the TX-submission +-- miniprotocol, see: +-- +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) where + +import Control.Concurrent.Class.MonadSTM.Strict (STM) +import Data.Word (Word64) + +-- | Interface used by the outbound side of object diffusion as its source of +-- objects to give to the remote side. +data ObjectPoolReader objectId object ticketNo m + = ObjectPoolReader + { oprObjectId :: object -> objectId + -- ^ Return the id of the specified object + , oprZeroTicketNo :: ticketNo + -- ^ Ticket number before the first item in the pool. + , oprObjectsAfter :: ticketNo -> Word64 -> STM m [(ticketNo, objectId, m object)] + -- ^ Get the list of objects available in the pool with a ticketNo greater + -- than the specified one. The number of returned objects is capped by the + -- given Word64. Only the IDs and ticketNos of the objects are directly + -- accessible; each actual object must be loaded through a monadic action. + } + +-- | Interface used by the inbound side of object diffusion when receiving +-- objects. +data ObjectPoolWriter objectId object m + = ObjectPoolWriter + { opwObjectId :: object -> objectId + -- ^ Return the id of the specified object + , opwAddObjects :: [object] -> m () + -- ^ Add a batch of objects to the objectPool. + , opwHasObject :: STM m (objectId -> Bool) + -- ^ Check if the object pool contains an object with the given id + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs new file mode 100644 index 0000000000..34c90b9836 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + ( objectDiffusionOutbound + , TraceObjectDiffusionOutbound (..) + , ObjectDiffusionOutboundError (..) + ) where + +import Control.Exception (assert) +import Control.Monad (forM, unless, when) +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Tracer (Tracer, traceWith) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as Seq +import Data.Set qualified as Set +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + +-- Note: This module is inspired from TxSubmission outbound side. + +data TraceObjectDiffusionOutbound objectId object + = TraceObjectDiffusionOutboundRecvMsgRequestObjectIds NumObjectIdsReq + | -- | The IDs to be sent in the response + TraceObjectDiffusionOutboundSendMsgReplyObjectIds [objectId] + | -- | The IDs of the objects requested. + TraceObjectDiffusionOutboundRecvMsgRequestObjects + [objectId] + | -- | The objects to be sent in the response. + TraceObjectDiffusionOutboundSendMsgReplyObjects + [object] + | -- | Received 'MsgDone' + TraceObjectDiffusionOutboundTerminated + deriving Show + +data ObjectDiffusionOutboundError + = ProtocolErrorAckedTooManyObjectIds + | ProtocolErrorRequestedNothing + | ProtocolErrorRequestedTooManyObjectIds NumObjectIdsReq NumObjectsOutstanding + | ProtocolErrorRequestBlocking + | ProtocolErrorRequestNonBlocking + | ProtocolErrorRequestedUnavailableObject + | ProtocolErrorRequestedDuplicateObject + deriving Show + +instance Exception ObjectDiffusionOutboundError where + displayException ProtocolErrorAckedTooManyObjectIds = + "The peer tried to acknowledged more objectIds than are available to do so." + displayException (ProtocolErrorRequestedTooManyObjectIds reqNo maxUnacked) = + "The peer requested " + ++ show reqNo + ++ " objectIds which would put the " + ++ "total in flight over the limit of " + ++ show maxUnacked + displayException ProtocolErrorRequestedNothing = + "The peer requested zero objectIds." + displayException ProtocolErrorRequestBlocking = + "The peer made a blocking request for more objectIds when there are still " + ++ "unacknowledged objectIds. It should have used a non-blocking request." + displayException ProtocolErrorRequestNonBlocking = + "The peer made a non-blocking request for more objectIds when there are " + ++ "no unacknowledged objectIds. It should have used a blocking request." + displayException ProtocolErrorRequestedUnavailableObject = + "The peer requested an object which is not available, either " + ++ "because it was never available or because it was previously requested." + displayException ProtocolErrorRequestedDuplicateObject = + "The peer requested the same object twice." + +data OutboundSt objectId object ticketNo = OutboundSt + { outstandingFifo :: !(StrictSeq object) + , lastTicketNo :: !ticketNo + } + +objectDiffusionOutbound :: + forall objectId object ticketNo m. + (Ord objectId, Ord ticketNo, MonadSTM m, MonadThrow m) => + Tracer m (TraceObjectDiffusionOutbound objectId object) -> + -- | Maximum number of unacknowledged objectIds allowed + NumObjectsOutstanding -> + ObjectPoolReader objectId object ticketNo m -> + NodeToNodeVersion -> + ObjectDiffusionOutbound objectId object m () +objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version = + ObjectDiffusionOutbound (pure (makeBundle $ OutboundSt Seq.empty oprZeroTicketNo)) + where + makeBundle :: OutboundSt objectId object ticketNo -> OutboundStIdle objectId object m () + makeBundle !st = + OutboundStIdle + { recvMsgRequestObjectIds = recvMsgRequestObjectIds st + , recvMsgRequestObjects = recvMsgRequestObjects st + , recvMsgDone = traceWith tracer TraceObjectDiffusionOutboundTerminated + } + + updateStNewObjects :: + OutboundSt objectId object ticketNo -> + [(object, ticketNo)] -> + OutboundSt objectId object ticketNo + updateStNewObjects !OutboundSt{..} newObjectsWithTicketNos = + -- These objects should all be fresh + assert (all (\(_, ticketNo) -> ticketNo > lastTicketNo) newObjectsWithTicketNos) $ + let !outstandingFifo' = + outstandingFifo + <> (Seq.fromList $ fst <$> newObjectsWithTicketNos) + !lastTicketNo' + | null newObjectsWithTicketNos = lastTicketNo + | otherwise = snd $ last newObjectsWithTicketNos + in OutboundSt + { outstandingFifo = outstandingFifo' + , lastTicketNo = lastTicketNo' + } + + recvMsgRequestObjectIds :: + forall blocking. + OutboundSt objectId object ticketNo -> + SingBlockingStyle blocking -> + NumObjectIdsAck -> + NumObjectIdsReq -> + m (OutboundStObjectIds blocking objectId object m ()) + recvMsgRequestObjectIds !st@OutboundSt{..} blocking numIdsToAck numIdsToReq = do + traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjectIds numIdsToReq) + + when (numIdsToAck > fromIntegral (Seq.length outstandingFifo)) $ + throwIO ProtocolErrorAckedTooManyObjectIds + + when + ( Seq.length outstandingFifo + - fromIntegral numIdsToAck + + fromIntegral numIdsToReq + > fromIntegral maxFifoLength + ) + $ throwIO (ProtocolErrorRequestedTooManyObjectIds numIdsToReq maxFifoLength) + + -- First we update our FIFO to remove the number of objectIds that the + -- inbound peer has acknowledged. + let !outstandingFifo' = Seq.drop (fromIntegral numIdsToAck) outstandingFifo + -- must specify the type here otherwise GHC complains about mismatch objectId types + st' :: OutboundSt objectId object ticketNo + !st' = st{outstandingFifo = outstandingFifo'} + + -- Grab info about any new objects after the last object ticketNo we've + -- seen, up to the number that the peer has requested. + case blocking of + ----------------------------------------------------------------------- + SingBlocking -> do + when (numIdsToReq == 0) $ + throwIO ProtocolErrorRequestedNothing + unless (Seq.null outstandingFifo') $ + throwIO ProtocolErrorRequestBlocking + + newContent <- atomically $ do + newObjectsWithTicketNos <- + oprObjectsAfter + lastTicketNo + (fromIntegral numIdsToReq) + check (not $ null newObjectsWithTicketNos) + pure newObjectsWithTicketNos + + newObjectsWithTicketNos <- forM newContent $ + \(ticketNo, _, getObject) -> do + object <- getObject + pure (object, ticketNo) + + let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos + st'' = updateStNewObjects st' newObjectsWithTicketNos + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds) + + -- Assert objects is non-empty: we blocked until objects was + -- non-null, and we know numIdsToReq > 0, hence + -- `take numIdsToReq objects` is non-null. + assert (not $ null newObjectsWithTicketNos) $ + pure $ + SendMsgReplyObjectIds + (BlockingReply (NonEmpty.fromList $ newIds)) + (makeBundle st'') + + ----------------------------------------------------------------------- + SingNonBlocking -> do + when (numIdsToReq == 0 && numIdsToAck == 0) $ + throwIO ProtocolErrorRequestedNothing + when (Seq.null outstandingFifo') $ + throwIO ProtocolErrorRequestNonBlocking + + newContent <- + atomically $ + oprObjectsAfter lastTicketNo (fromIntegral numIdsToReq) + newObjectsWithTicketNos <- forM newContent $ + \(ticketNo, _, getObject) -> do + object <- getObject + pure (object, ticketNo) + + let !newIds = oprObjectId . fst <$> newObjectsWithTicketNos + st'' = updateStNewObjects st' newObjectsWithTicketNos + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjectIds newIds) + + pure (SendMsgReplyObjectIds (NonBlockingReply newIds) (makeBundle st'')) + + recvMsgRequestObjects :: + OutboundSt objectId object ticketNo -> + [objectId] -> + m (OutboundStObjects objectId object m ()) + recvMsgRequestObjects !st@OutboundSt{..} requestedIds = do + traceWith tracer (TraceObjectDiffusionOutboundRecvMsgRequestObjects requestedIds) + + -- All the objects correspond to advertised objectIds are already in the + -- outstandingFifo. So we don't need to read from the object pool here. + + -- I've optimized the search to do only one traversal of 'outstandingFifo'. + -- When the 'requestedIds' is exactly the whole 'outstandingFifo', then this + -- should take O(n * log n) time. + -- + -- TODO: We might need to revisit the underlying 'outstandingFifo' data + -- structure and the search if performance isn't sufficient when we'll use + -- ObjectDiffusion for votes diffusion (and not just cert diffusion). + + let requestedIdsSet = Set.fromList requestedIds + + when (Set.size requestedIdsSet /= length requestedIds) $ + throwIO ProtocolErrorRequestedDuplicateObject + + let requestedObjects = + foldr + ( \obj acc -> + if Set.member (oprObjectId obj) requestedIdsSet + then obj : acc + else acc + ) + [] + outstandingFifo + + when (Set.size requestedIdsSet /= length requestedObjects) $ + throwIO ProtocolErrorRequestedUnavailableObject + + traceWith tracer (TraceObjectDiffusionOutboundSendMsgReplyObjects requestedObjects) + + pure (SendMsgReplyObjects requestedObjects (makeBundle st)) From 25f658d11125c576e8d4c11a99783492daeefb86 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 12 Sep 2025 14:50:59 +0200 Subject: [PATCH 29/35] Add smoke tests for generic ObjectDiffusion Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../test/consensus-test/Main.hs | 2 + .../MiniProtocol/ObjectDiffusion/Smoke.hs | 302 ++++++++++++++++++ 3 files changed, 305 insertions(+) create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 580d3206e2..56dd7ce4e3 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -605,6 +605,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ChainSync.CSJ Test.Consensus.MiniProtocol.ChainSync.Client Test.Consensus.MiniProtocol.LocalStateQuery.Server + Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm Test.Consensus.Util.Versioned diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index beddd1f7d2..439d7b3043 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -16,6 +16,7 @@ import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests) import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests) +import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) import qualified Test.Consensus.Util.Versioned (tests) @@ -37,6 +38,7 @@ tests = , Test.Consensus.MiniProtocol.BlockFetch.Client.tests , Test.Consensus.MiniProtocol.ChainSync.CSJ.tests , Test.Consensus.MiniProtocol.ChainSync.Client.tests + , Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke.tests , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests , testGroup "Mempool" diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs new file mode 100644 index 0000000000..d2f21c9b66 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Smoke tests for the object diffusion protocol. This uses a trivial object +-- pool and checks that a few objects can indeed be transferred from the +-- outbound to the inbound peer. +module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + ( tests + , WithId (..) + , ListWithUniqueIds (..) + , ProtocolConstants + , prop_smoke_object_diffusion + ) where + +import Control.Monad.IOSim (runSimStrictShutdown) +import Control.ResourceRegistry (forkLinkedThread, waitAnyThread, withRegistry) +import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Containers.ListUtils (nubOrdOn) +import Data.Functor.Contravariant (contramap) +import Network.TypedProtocol.Channel (Channel, createConnectedChannels) +import Network.TypedProtocol.Codec (AnyMessage) +import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + ( objectDiffusionInbound + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + ( ObjectPoolReader (..) + , ObjectPoolWriter (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +import Ouroboros.Consensus.Util.IOLike + ( IOLike + , MonadDelay (..) + , MonadSTM (..) + , StrictTVar + , modifyTVar + , readTVar + , uncheckedNewTVarM + , writeTVar + ) +import Ouroboros.Network.ControlMessage (ControlMessage (..)) +import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( ObjectDiffusionInboundPipelined + , objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( ObjectDiffusionOutbound + , objectDiffusionOutboundPeer + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type + ( NumObjectIdsReq (..) + , NumObjectsOutstanding (..) + , NumObjectsReq (..) + , ObjectDiffusion + ) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Util.Orphans.Arbitrary () +import Test.Util.Orphans.IOLike () + +tests :: TestTree +tests = + testGroup + "ObjectDiffusion.Smoke" + [ testProperty + "ObjectDiffusion smoke test with mock objects" + prop_smoke + ] + +{------------------------------------------------------------------------------- + Provides a way to generate lists composed of objects with no duplicate ids, + with an Arbitrary instance +-------------------------------------------------------------------------------} + +class WithId a idTy | a -> idTy where + getId :: a -> idTy + +newtype ListWithUniqueIds a idTy = ListWithUniqueIds [a] + deriving (Eq, Show, Ord) + +instance (Ord idTy, WithId a idTy, Arbitrary a) => Arbitrary (ListWithUniqueIds a idTy) where + arbitrary = ListWithUniqueIds . nubOrdOn getId <$> arbitrary + +instance WithId SmokeObject SmokeObjectId where getId = getSmokeObjectId + +{------------------------------------------------------------------------------- + Mock objectPools +-------------------------------------------------------------------------------} + +newtype SmokeObjectId = SmokeObjectId Int + deriving (Eq, Ord, Show, NoThunks, Arbitrary) + +newtype SmokeObject = SmokeObject {getSmokeObjectId :: SmokeObjectId} + deriving (Eq, Ord, Show, NoThunks, Arbitrary) + +newtype SmokeObjectPool m = SmokeObjectPool (StrictTVar m [SmokeObject]) + +newObjectPool :: MonadSTM m => [SmokeObject] -> m (SmokeObjectPool m) +newObjectPool initialPoolContent = SmokeObjectPool <$> uncheckedNewTVarM initialPoolContent + +makeObjectPoolReader :: + MonadSTM m => SmokeObjectPool m -> ObjectPoolReader SmokeObjectId SmokeObject Int m +makeObjectPoolReader (SmokeObjectPool poolContentTvar) = + ObjectPoolReader + { oprObjectId = getSmokeObjectId + , oprObjectsAfter = \minTicketNo limit -> do + poolContent <- readTVar poolContentTvar + pure $ + take (fromIntegral limit) $ + drop (minTicketNo + 1) $ + ( (\(ticketNo, smokeObject) -> (ticketNo, getSmokeObjectId smokeObject, pure smokeObject)) + <$> zip [(0 :: Int) ..] poolContent + ) + , oprZeroTicketNo = -1 -- objectPoolObjectIdsAfter uses strict comparison, and first ticketNo is 0. + } + +makeObjectPoolWriter :: + MonadSTM m => SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m +makeObjectPoolWriter (SmokeObjectPool poolContentTvar) = + ObjectPoolWriter + { opwObjectId = getSmokeObjectId + , opwAddObjects = \objects -> do + atomically $ modifyTVar poolContentTvar (++ objects) + return () + , opwHasObject = do + poolContent <- readTVar poolContentTvar + pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent + } + +mkMockPoolInterfaces :: + MonadSTM m => + [SmokeObject] -> + m + ( ObjectPoolReader SmokeObjectId SmokeObject Int m + , ObjectPoolWriter SmokeObjectId SmokeObject m + , m [SmokeObject] + ) +mkMockPoolInterfaces objects = do + outboundPool <- newObjectPool objects + inboundPool@(SmokeObjectPool tvar) <- newObjectPool [] + + let outboundPoolReader = makeObjectPoolReader outboundPool + inboundPoolWriter = makeObjectPoolWriter inboundPool + + return (outboundPoolReader, inboundPoolWriter, atomically $ readTVar tvar) + +{------------------------------------------------------------------------------- + Main properties +-------------------------------------------------------------------------------} + +-- Protocol constants + +newtype ProtocolConstants + = ProtocolConstants (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) + deriving Show + +instance Arbitrary ProtocolConstants where + arbitrary = do + maxFifoSize <- choose (5, 20) + maxIdsToReq <- choose (3, maxFifoSize) + maxObjectsToReq <- choose (2, maxIdsToReq) + pure $ + ProtocolConstants + ( NumObjectsOutstanding maxFifoSize + , NumObjectIdsReq maxIdsToReq + , NumObjectsReq maxObjectsToReq + ) + +nodeToNodeVersion :: NodeToNodeVersion +nodeToNodeVersion = NodeToNodeV_14 + +prop_smoke :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property +prop_smoke protocolConstants (ListWithUniqueIds objects) = + prop_smoke_object_diffusion + protocolConstants + objects + runOutboundPeer + runInboundPeer + (mkMockPoolInterfaces objects) + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundPeer outbound) + >> pure () + + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundPeerPipelined inbound) + >> pure () + +--- The core logic of the smoke test is shared between the generic smoke tests for ObjectDiffusion, and the ones specialised to PerasCert/PerasVote diffusion +prop_smoke_object_diffusion :: + ( Eq object + , Show object + , Ord objectId + , NoThunks objectId + , Show objectId + , NoThunks object + , Ord ticketNo + ) => + ProtocolConstants -> + [object] -> + ( forall m. + IOLike m => + ObjectDiffusionOutbound objectId object m () -> + Channel m (AnyMessage (ObjectDiffusion objectId object)) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + ObjectDiffusionInboundPipelined objectId object m () -> + (Channel m (AnyMessage (ObjectDiffusion objectId object))) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + m + ( ObjectPoolReader objectId object ticketNo m + , ObjectPoolWriter objectId object m + , m [object] + ) + ) -> + Property +prop_smoke_object_diffusion + (ProtocolConstants (maxFifoSize, maxIdsToReq, maxObjectsToReq)) + objects + runOutboundPeer + runInboundPeer + mkPoolInterfaces = + let + simulationResult = runSimStrictShutdown $ do + let tracer = nullTracer + + traceWith tracer "========== [ Starting ObjectDiffusion smoke test ] ==========" + traceWith tracer (show objects) + + (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) <- mkPoolInterfaces + controlMessage <- uncheckedNewTVarM Continue + + let + inbound = + objectDiffusionInbound + tracer + ( maxFifoSize + , maxIdsToReq + , maxObjectsToReq + ) + inboundPoolWriter + nodeToNodeVersion + (readTVar controlMessage) + + outbound = + objectDiffusionOutbound + tracer + maxFifoSize + outboundPoolReader + nodeToNodeVersion + + withRegistry $ \reg -> do + (outboundChannel, inboundChannel) <- createConnectedChannels + outboundThread <- + forkLinkedThread reg "ObjectDiffusion Outbound peer thread" $ + runOutboundPeer outbound outboundChannel tracer + inboundThread <- + forkLinkedThread reg "ObjectDiffusion Inbound peer thread" $ + runInboundPeer inbound inboundChannel tracer + controlMessageThread <- forkLinkedThread reg "ObjectDiffusion Control thread" $ do + threadDelay 1000 -- give a head start to the other threads + atomically $ writeTVar controlMessage Terminate + threadDelay 1000 -- wait for the other threads to finish + waitAnyThread [outboundThread, inboundThread, controlMessageThread] + + traceWith tracer "========== [ ObjectDiffusion smoke test finished ] ==========" + poolContent <- getAllInboundPoolContent + + traceWith tracer "inboundPoolContent:" + traceWith tracer (show poolContent) + traceWith tracer "========== ======================================= ==========" + pure poolContent + in + case simulationResult of + Right inboundPoolContent -> inboundPoolContent === objects + Left msg -> counterexample (show msg) $ property False From 7be6c521736abb05772c2ca39fd6892360441f72 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 12 Sep 2025 14:55:18 +0200 Subject: [PATCH 30/35] Add definitions and codec for `PerasCert` diffusion through ObjectDiffusion Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 2 + .../ObjectDiffusion/ObjectPool/PerasCert.hs | 105 ++++++++++++++++++ .../MiniProtocol/ObjectDiffusion/PerasCert.hs | 41 +++++++ .../Ouroboros/Consensus/Node/Serialisation.hs | 40 ++++++- 4 files changed, 185 insertions(+), 3 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 56dd7ce4e3..48539fa5d0 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -193,7 +193,9 @@ library Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert Ouroboros.Consensus.Node.GsmState Ouroboros.Consensus.Node.InitStorage Ouroboros.Consensus.Node.NetworkProtocolVersion diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs new file mode 100644 index 0000000000..4a5ac999b3 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras +-- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the +-- 'PerasCertDB'). +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert + ( makePerasCertPoolReaderFromCertDB + , makePerasCertPoolWriterFromCertDB + , makePerasCertPoolReaderFromChainDB + , makePerasCertPoolWriterFromChainDB + ) where + +import GHC.Exception (throw) +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) +import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( PerasCertDB + , PerasCertSnapshot + , PerasCertTicketNo + ) +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB +import Ouroboros.Consensus.Util.IOLike + +makePerasCertPoolReaderFromSnapshot :: + (IOLike m, StandardHash blk) => + STM m (PerasCertSnapshot blk) -> + ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromSnapshot getCertSnapshot = + ObjectPoolReader + { oprObjectId = getPerasCertRound + , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo + , oprObjectsAfter = \lastKnown limit -> do + certSnapshot <- getCertSnapshot + pure $ + take (fromIntegral limit) $ + [ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert)) + | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown + ] + } + +makePerasCertPoolReaderFromCertDB :: + (IOLike m, StandardHash blk) => + PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromCertDB perasCertDB = + makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) + +makePerasCertPoolWriterFromCertDB :: + (StandardHash blk, IOLike m) => + PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromCertDB perasCertDB = + ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = \certs -> do + validatePerasCerts certs + >>= mapM_ (PerasCertDB.addCert perasCertDB) + , opwHasObject = do + certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB + pure $ PerasCertDB.containsCert certSnapshot + } + +makePerasCertPoolReaderFromChainDB :: + (IOLike m, StandardHash blk) => + ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m +makePerasCertPoolReaderFromChainDB chainDB = + makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) + +makePerasCertPoolWriterFromChainDB :: + (StandardHash blk, IOLike m) => + ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromChainDB chainDB = + ObjectPoolWriter + { opwObjectId = getPerasCertRound + , opwAddObjects = \certs -> do + validatePerasCerts certs + >>= mapM_ (ChainDB.addPerasCertAsync chainDB) + , opwHasObject = do + certSnapshot <- ChainDB.getPerasCertSnapshot chainDB + pure $ PerasCertDB.containsCert certSnapshot + } + +data PerasCertInboundException + = forall blk. PerasCertValidationError (PerasValidationErr blk) + +deriving instance Show PerasCertInboundException + +instance Exception PerasCertInboundException + +-- | Validate a list of 'PerasCert's, throwing a 'PerasCertInboundException' if +-- any of them are invalid. +validatePerasCerts :: + (StandardHash blk, MonadThrow m) => + [PerasCert blk] -> + m [ValidatedPerasCert blk] +validatePerasCerts certs = do + let perasCfg = makePerasCfg Nothing + -- TODO replace the mocked-up Nothing with a real + -- 'BlockConfig' when all the plumbing is in place + -- see https://github.com/tweag/cardano-peras/issues/73 + -- see https://github.com/tweag/cardano-peras/issues/120 + case traverse (validatePerasCert perasCfg) certs of + Left validationErr -> throw (PerasCertValidationError validationErr) + Right validatedCerts -> return validatedCerts diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs new file mode 100644 index 0000000000..ba0ba934a2 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -0,0 +1,41 @@ +-- | This module defines type aliases for the ObjectDiffusion protocol applied +-- to PerasCert diffusion. +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + ( TracePerasCertDiffusionInbound + , TracePerasCertDiffusionOutbound + , PerasCertPoolReader + , PerasCertPoolWriter + , PerasCertDiffusionInboundPipelined + , PerasCertDiffusionOutbound + , PerasCertDiffusion + ) where + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound +import Ouroboros.Consensus.Storage.PerasCertDB.API +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion) + +type TracePerasCertDiffusionInbound blk = + TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk) + +type TracePerasCertDiffusionOutbound blk = + TraceObjectDiffusionOutbound PerasRoundNo (PerasCert blk) + +type PerasCertPoolReader blk m = + ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m + +type PerasCertPoolWriter blk m = + ObjectPoolWriter PerasRoundNo (PerasCert blk) m + +type PerasCertDiffusionInboundPipelined blk m a = + ObjectDiffusionInboundPipelined PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusionOutbound blk m a = + ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusion blk = + ObjectDiffusion PerasRoundNo (PerasCert blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs index 6520aae47c..6a4fc87229 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -6,8 +6,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- | Serialisation for sending things across the network. @@ -33,8 +36,8 @@ module Ouroboros.Consensus.Node.Serialisation , Some (..) ) where -import Codec.CBOR.Decoding (Decoder) -import Codec.CBOR.Encoding (Encoding) +import Codec.CBOR.Decoding (Decoder, decodeListLenOf) +import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (Serialise (decode, encode)) import Data.Kind import Data.SOP.BasicFunctors @@ -47,7 +50,15 @@ import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (Some (..)) -import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR) +import Ouroboros.Network.Block + ( Tip + , decodePoint + , decodeTip + , encodePoint + , encodeTip + , unwrapCBORinCBOR + , wrapCBORinCBOR + ) {------------------------------------------------------------------------------- NodeToNode @@ -173,6 +184,29 @@ deriving newtype instance SerialiseNodeToNode blk (GenTxId blk) => SerialiseNodeToNode blk (WrapGenTxId blk) +instance ConvertRawHash blk => SerialiseNodeToNode blk (Point blk) where + encodeNodeToNode _ccfg _version = encodePoint $ encodeRawHash (Proxy @blk) + decodeNodeToNode _ccfg _version = decodePoint $ decodeRawHash (Proxy @blk) + +instance ConvertRawHash blk => SerialiseNodeToNode blk (Tip blk) where + encodeNodeToNode _ccfg _version = encodeTip $ encodeRawHash (Proxy @blk) + decodeNodeToNode _ccfg _version = decodeTip $ decodeRawHash (Proxy @blk) + +instance SerialiseNodeToNode blk PerasRoundNo where + encodeNodeToNode _ccfg _version = encode + decodeNodeToNode _ccfg _version = decode +instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where + -- Consistent with the 'Serialise' instance for 'PerasCert' defined in Ouroboros.Consensus.Block.SupportsPeras + encodeNodeToNode ccfg version PerasCert{..} = + encodeListLen 2 + <> encodeNodeToNode ccfg version pcCertRound + <> encodeNodeToNode ccfg version pcCertBoostedBlock + decodeNodeToNode ccfg version = do + decodeListLenOf 2 + pcCertRound <- decodeNodeToNode ccfg version + pcCertBoostedBlock <- decodeNodeToNode ccfg version + pure $ PerasCert pcCertRound pcCertBoostedBlock + deriving newtype instance SerialiseNodeToClient blk (GenTxId blk) => SerialiseNodeToClient blk (WrapGenTxId blk) From bd0378f16a7d063b62900f355aaa2f6efb9e6b63 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 12 Sep 2025 14:58:12 +0200 Subject: [PATCH 31/35] Add smoke tests for PerasCertDiffusion Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../test/consensus-test/Main.hs | 2 + .../ObjectDiffusion/PerasCert/Smoke.hs | 131 ++++++++++++++++++ 3 files changed, 134 insertions(+) create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 48539fa5d0..dff72b90be 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -607,6 +607,7 @@ test-suite consensus-test Test.Consensus.MiniProtocol.ChainSync.CSJ Test.Consensus.MiniProtocol.ChainSync.Client Test.Consensus.MiniProtocol.LocalStateQuery.Server + Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke Test.Consensus.Peras.WeightSnapshot Test.Consensus.Util.MonadSTM.NormalForm diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 439d7b3043..79d681213a 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -16,6 +16,7 @@ import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests) import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests) +import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (tests) import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests) import qualified Test.Consensus.Peras.WeightSnapshot (tests) import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests) @@ -39,6 +40,7 @@ tests = , Test.Consensus.MiniProtocol.ChainSync.CSJ.tests , Test.Consensus.MiniProtocol.ChainSync.Client.tests , Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke.tests + , Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke.tests , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests , testGroup "Mempool" diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs new file mode 100644 index 0000000000..fbcf9af79a --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke (tests) where + +import Control.Tracer (contramap, nullTracer) +import Data.Functor.Identity (Identity (..)) +import qualified Data.List.NonEmpty as NE +import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) +import Ouroboros.Consensus.Block.SupportsPeras +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( AddPerasCertResult (..) + , PerasCertDB + , PerasCertTicketNo + ) +import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB +import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo), StandardHash) +import Ouroboros.Network.Point (Block (Block), WithOrigin (..)) +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) +import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke + ( ListWithUniqueIds (..) + , ProtocolConstants + , WithId + , getId + , prop_smoke_object_diffusion + ) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.Util.TestBlock + +tests :: TestTree +tests = + testGroup + "ObjectDiffusion.PerasCert.Smoke" + [ testProperty "PerasCertDiffusion smoke test" prop_smoke + ] + +instance Arbitrary (Point TestBlock) where + arbitrary = + -- Sometimes pick the genesis point + frequency + [ (1, pure $ Point Origin) + , + ( 4 + , do + slotNo <- SlotNo <$> arbitrary + hash <- TestHash . NE.fromList . getNonEmpty <$> arbitrary + pure $ Point (At (Block slotNo hash)) + ) + ] + +instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where + arbitrary = do + pcCertRound <- PerasRoundNo <$> arbitrary + pcCertBoostedBlock <- arbitrary + pure $ PerasCert{pcCertRound, pcCertBoostedBlock} + +instance WithId (PerasCert blk) PerasRoundNo where + getId = pcCertRound + +newCertDB :: (IOLike m, StandardHash blk) => [PerasCert blk] -> m (PerasCertDB m blk) +newCertDB certs = do + db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) + mapM_ + ( \cert -> do + let validatedCert = + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = boostPerCert + } + result <- PerasCertDB.addCert db validatedCert + case result of + AddedPerasCertToDB -> pure () + PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB") + ) + certs + pure db + +prop_smoke :: ProtocolConstants -> ListWithUniqueIds (PerasCert TestBlock) PerasRoundNo -> Property +prop_smoke protocolConstants (ListWithUniqueIds certs) = + prop_smoke_object_diffusion protocolConstants certs runOutboundPeer runInboundPeer mkPoolInterfaces + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundPeer outbound) + >> pure () + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundPeerPipelined inbound) + >> pure () + mkPoolInterfaces :: + forall m. + IOLike m => + m + ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m + , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m + , m [PerasCert TestBlock] + ) + mkPoolInterfaces = do + outboundPool <- newCertDB certs + inboundPool <- newCertDB [] + + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool + getAllInboundPoolContent = do + snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool + let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) + pure $ getPerasCert . fst <$> rawContent + + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) From 93a5016b6d50c16e3a211ff341e7384166054fd1 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 12 Sep 2025 15:07:26 +0200 Subject: [PATCH 32/35] Register and wire-in PerasCertDiffusion in the network layer Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 171 +++++++++++++++--- .../Ouroboros/Consensus/Node.hs | 2 + .../Ouroboros/Consensus/Node/Tracers.hs | 11 ++ .../Test/ThreadNet/Network.hs | 6 + .../test/mock-test/Test/ThreadNet/BFT.hs | 1 + 5 files changed, 161 insertions(+), 30 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 85c4109a52..1b5ca20c1a 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -68,6 +68,10 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client ) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CsClient import Ouroboros.Consensus.MiniProtocol.ChainSync.Server +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound (objectDiffusionInbound) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert import Ouroboros.Consensus.Node.ExitPolicy import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.Run @@ -81,10 +85,6 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Network.Block ( Serialised (..) - , decodePoint - , decodeTip - , encodePoint - , encodeTip ) import Ouroboros.Network.BlockFetch import Ouroboros.Network.BlockFetch.Client @@ -124,6 +124,18 @@ import Ouroboros.Network.Protocol.KeepAlive.Client import Ouroboros.Network.Protocol.KeepAlive.Codec import Ouroboros.Network.Protocol.KeepAlive.Server import Ouroboros.Network.Protocol.KeepAlive.Type +import Ouroboros.Network.Protocol.ObjectDiffusion.Codec + ( byteLimitsObjectDiffusion + , codecObjectDiffusion + , codecObjectDiffusionId + , timeLimitsObjectDiffusion + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound + ( objectDiffusionInboundPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( objectDiffusionOutboundPeer + ) import Ouroboros.Network.Protocol.PeerSharing.Client ( PeerSharingClient , peerSharingClientPeer @@ -197,6 +209,15 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ConnectionId addr -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m () + , hPerasCertDiffusionClient :: + NodeToNodeVersion -> + ControlMessageSTM m -> + ConnectionId addr -> + PerasCertDiffusionInboundPipelined blk m () + , hPerasCertDiffusionServer :: + NodeToNodeVersion -> + ConnectionId addr -> + PerasCertDiffusionOutbound blk m () , hKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m -> @@ -293,6 +314,22 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version + , hPerasCertDiffusionClient = \version controlMessageSTM peer -> + objectDiffusionInbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers)) + ( perasCertDiffusionMaxFifoLength miniProtocolParameters + , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 + , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 + ) + (makePerasCertPoolWriterFromChainDB $ getChainDB) + version + controlMessageSTM + , hPerasCertDiffusionServer = \version peer -> + objectDiffusionOutbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) + (perasCertDiffusionMaxFifoLength miniProtocolParameters) + (makePerasCertPoolReaderFromChainDB $ getChainDB) + version , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng , hKeepAliveServer = \_version _peer -> keepAliveServer , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM @@ -304,7 +341,7 @@ mkHandlers -------------------------------------------------------------------------------} -- | Node-to-node protocol codecs needed to run 'Handlers'. -data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs +data Codecs blk addr e m bCS bSCS bBF bSBF bTX bPCD bKA bPS = Codecs { cChainSyncCodec :: Codec (ChainSync (Header blk) (Point blk) (Tip blk)) e m bCS , cChainSyncCodecSerialised :: Codec (ChainSync (SerialisedHeader blk) (Point blk) (Tip blk)) e m bSCS @@ -312,6 +349,7 @@ data Codecs blk addr e m bCS bSCS bBF bSBF bTX bKA bPS = Codecs , cBlockFetchCodecSerialised :: Codec (BlockFetch (Serialised blk) (Point blk)) e m bSBF , cTxSubmission2Codec :: Codec (TxSubmission2 (GenTxId blk) (GenTx blk)) e m bTX + , cPerasCertDiffusionCodec :: Codec (PerasCertDiffusion blk) e m bPCD , cKeepAliveCodec :: Codec KeepAlive e m bKA , cPeerSharingCodec :: Codec (PeerSharing addr) e m bPS } @@ -339,49 +377,53 @@ defaultCodecs :: ByteString ByteString ByteString + ByteString defaultCodecs ccfg version encAddr decAddr nodeToNodeVersion = Codecs { cChainSyncCodec = codecChainSync enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (encodeTip (encodeRawHash p)) - (decodeTip (decodeRawHash p)) + enc + dec + enc + dec , cChainSyncCodecSerialised = codecChainSync enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) - (encodeTip (encodeRawHash p)) - (decodeTip (decodeRawHash p)) + enc + dec + enc + dec , cBlockFetchCodec = codecBlockFetch enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) + enc + dec , cBlockFetchCodecSerialised = codecBlockFetch enc dec - (encodePoint (encodeRawHash p)) - (decodePoint (decodeRawHash p)) + enc + dec , cTxSubmission2Codec = codecTxSubmission2 enc dec enc dec + , cPerasCertDiffusionCodec = + codecObjectDiffusion + enc + dec + enc + dec , cKeepAliveCodec = codecKeepAlive_v2 , cPeerSharingCodec = codecPeerSharing (encAddr nodeToNodeVersion) (decAddr nodeToNodeVersion) } where - p :: Proxy blk - p = Proxy - enc :: SerialiseNodeToNode blk a => a -> Encoding enc = encodeNodeToNode ccfg version @@ -401,6 +443,7 @@ identityCodecs :: (AnyMessage (BlockFetch blk (Point blk))) (AnyMessage (BlockFetch (Serialised blk) (Point blk))) (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing addr)) identityCodecs = @@ -410,6 +453,7 @@ identityCodecs = , cBlockFetchCodec = codecBlockFetchId , cBlockFetchCodecSerialised = codecBlockFetchId , cTxSubmission2Codec = codecTxSubmission2Id + , cPerasCertDiffusionCodec = codecObjectDiffusionId , cKeepAliveCodec = codecKeepAliveId , cPeerSharingCodec = codecPeerSharingId } @@ -432,6 +476,7 @@ data Tracers' peer ntnAddr blk e f = Tracers f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk) (Point blk)))) , tTxSubmission2Tracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission2 (GenTxId blk) (GenTx blk)))) + , tPerasCertDiffusionTracer :: f (TraceLabelPeer peer (TraceSendRecv (PerasCertDiffusion blk))) , tKeepAliveTracer :: f (TraceLabelPeer peer (TraceSendRecv KeepAlive)) , tPeerSharingTracer :: f (TraceLabelPeer peer (TraceSendRecv (PeerSharing ntnAddr))) } @@ -444,6 +489,7 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer ntnAddr blk e f , tBlockFetchTracer = f tBlockFetchTracer , tBlockFetchSerialisedTracer = f tBlockFetchSerialisedTracer , tTxSubmission2Tracer = f tTxSubmission2Tracer + , tPerasCertDiffusionTracer = f tPerasCertDiffusionTracer , tKeepAliveTracer = f tKeepAliveTracer , tPeerSharingTracer = f tPeerSharingTracer } @@ -464,6 +510,7 @@ nullTracers = , tBlockFetchTracer = nullTracer , tBlockFetchSerialisedTracer = nullTracer , tTxSubmission2Tracer = nullTracer + , tPerasCertDiffusionTracer = nullTracer , tKeepAliveTracer = nullTracer , tPeerSharingTracer = nullTracer } @@ -485,6 +532,7 @@ showTracers tr = , tBlockFetchTracer = showTracing tr , tBlockFetchSerialisedTracer = showTracing tr , tTxSubmission2Tracer = showTracing tr + , tPerasCertDiffusionTracer = showTracing tr , tKeepAliveTracer = showTracing tr , tPeerSharingTracer = showTracing tr } @@ -509,7 +557,7 @@ type ServerApp m addr bytes a = -- | Applications for the node-to-node protocols -- -- See 'Network.Mux.Types.MuxApplication' -data Apps m addr bCS bBF bTX bKA bPS a b = Apps +data Apps m addr bCS bBF bTX bPCD bKA bPS a b = Apps { aChainSyncClient :: ClientApp m addr bCS a -- ^ Start a chain sync client that communicates with the given upstream -- node. @@ -525,6 +573,10 @@ data Apps m addr bCS bBF bTX bKA bPS a b = Apps -- given upstream node. , aTxSubmission2Server :: ServerApp m addr bTX b -- ^ Start a transaction submission v2 server. + , aPerasCertDiffusionClient :: ClientApp m addr bPCD a + -- ^ Start a Peras cert diffusion client. + , aPerasCertDiffusionServer :: ServerApp m addr bPCD b + -- ^ Start a Peras cert diffusion server. , aKeepAliveClient :: ClientApp m addr bKA a -- ^ Start a keep-alive client. , aKeepAliveServer :: ServerApp m addr bKA b @@ -540,7 +592,7 @@ data Apps m addr bCS bBF bTX bKA bPS a b = Apps -- -- They don't depend on the instantiation of the protocol parameters (which -- block type is used, etc.), hence the use of 'RankNTypes'. -data ByteLimits bCS bBF bTX bKA = ByteLimits +data ByteLimits bCS bBF bTX bPCD bKA = ByteLimits { blChainSync :: forall header point tip. ProtocolSizeLimits @@ -556,27 +608,34 @@ data ByteLimits bCS bBF bTX bKA = ByteLimits ProtocolSizeLimits (TxSubmission2 txid tx) bTX + , blPerasCertDiffusion :: + forall blk. + ProtocolSizeLimits + (PerasCertDiffusion blk) + bPCD , blKeepAlive :: ProtocolSizeLimits KeepAlive bKA } -noByteLimits :: ByteLimits bCS bBF bTX bKA +noByteLimits :: ByteLimits bCS bBF bTX bPCD bKA noByteLimits = ByteLimits { blChainSync = byteLimitsChainSync (const 0) , blBlockFetch = byteLimitsBlockFetch (const 0) , blTxSubmission2 = byteLimitsTxSubmission2 (const 0) + , blPerasCertDiffusion = byteLimitsObjectDiffusion (const 0) , blKeepAlive = byteLimitsKeepAlive (const 0) } -byteLimits :: ByteLimits ByteString ByteString ByteString ByteString +byteLimits :: ByteLimits ByteString ByteString ByteString ByteString ByteString byteLimits = ByteLimits { blChainSync = byteLimitsChainSync size , blBlockFetch = byteLimitsBlockFetch size , blTxSubmission2 = byteLimitsTxSubmission2 size + , blPerasCertDiffusion = byteLimitsObjectDiffusion size , blKeepAlive = byteLimitsKeepAlive size } where @@ -587,7 +646,7 @@ byteLimits = -- | Construct the 'NetworkApplication' for the node-to-node protocols mkApps :: - forall m addrNTN addrNTC blk e bCS bBF bTX bKA bPS. + forall m addrNTN addrNTC blk e bCS bBF bTX bPCD bKA bPS. ( IOLike m , MonadTimer m , Ord addrNTN @@ -602,8 +661,8 @@ mkApps :: NodeKernel m addrNTN addrNTC blk -> StdGen -> Tracers m addrNTN blk e -> - (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bKA bPS) -> - ByteLimits bCS bBF bTX bKA -> + (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) -> + ByteLimits bCS bBF bTX bPCD bKA -> -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as -- the server (`SerialisedHeader blk`). (forall header. ProtocolTimeLimitsWithRnd (ChainSync header (Point blk) (Tip blk))) -> @@ -611,7 +670,7 @@ mkApps :: CsClient.CSJConfig -> ReportPeerMetrics m (ConnectionId addrNTN) -> Handlers m addrNTN blk -> - Apps m addrNTN bCS bBF bTX bKA bPS NodeToNodeInitiatorResult () + Apps m addrNTN bCS bBF bTX bPCD bKA bPS NodeToNodeInitiatorResult () mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucketConfig csjConfig ReportPeerMetrics{..} Handlers{..} = Apps{..} where @@ -790,6 +849,51 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke channel (txSubmissionServerPeerPipelined (hTxSubmissionServer version them)) + aPerasCertDiffusionClient :: + NodeToNodeVersion -> + ExpandedInitiatorContext addrNTN m -> + Channel m bPCD -> + m (NodeToNodeInitiatorResult, Maybe bPCD) + aPerasCertDiffusionClient + version + ExpandedInitiatorContext + { eicConnectionId = them + , eicControlMessage = controlMessageSTM + } + channel = do + labelThisThread "PerasCertDiffusionClient" + ((), trailing) <- + runPipelinedPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionInboundPeerPipelined + (hPerasCertDiffusionClient version controlMessageSTM them) + ) + return (NoInitiatorResult, trailing) + + aPerasCertDiffusionServer :: + NodeToNodeVersion -> + ResponderContext addrNTN -> + Channel m bPCD -> + m ((), Maybe bPCD) + aPerasCertDiffusionServer + version + ResponderContext{rcConnectionId = them} + channel = do + labelThisThread "PerasCertDiffusionServer" + runPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionOutboundPeer + (hPerasCertDiffusionServer version them) + ) + aKeepAliveClient :: NodeToNodeVersion -> ExpandedInitiatorContext addrNTN m -> @@ -893,7 +997,7 @@ initiator :: MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> - Apps m addr b b b b b a c -> + Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorMode addr b m a Void initiator miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols @@ -911,6 +1015,8 @@ initiator miniProtocolParameters version versionData Apps{..} = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aBlockFetchClient version ctx))) , txSubmissionProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aTxSubmission2Client version ctx))) + , perasCertDiffusionProtocol = + (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aPerasCertDiffusionClient version ctx))) , keepAliveProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aKeepAliveClient version ctx))) , peerSharingProtocol = @@ -929,7 +1035,7 @@ initiatorAndResponder :: MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> - Apps m addr b b b b b a c -> + Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorResponderMode addr b m a c initiatorAndResponder miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols @@ -950,6 +1056,11 @@ initiatorAndResponder miniProtocolParameters version versionData Apps{..} = (MiniProtocolCb (\initiatorCtx -> aTxSubmission2Client version initiatorCtx)) (MiniProtocolCb (\responderCtx -> aTxSubmission2Server version responderCtx)) ) + , perasCertDiffusionProtocol = + ( InitiatorAndResponderProtocol + (MiniProtocolCb (\initiatorCtx -> aPerasCertDiffusionClient version initiatorCtx)) + (MiniProtocolCb (\responderCtx -> aPerasCertDiffusionServer version responderCtx)) + ) , keepAliveProtocol = ( InitiatorAndResponderProtocol (MiniProtocolCb (\initiatorCtx -> aKeepAliveClient version initiatorCtx)) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index 7c0535c1bd..6d3d649d6b 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -649,6 +649,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () mkNodeToNodeApps nodeKernelArgs nodeKernel peerMetrics encAddrNTN decAddrNTN version = @@ -690,6 +691,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = ByteString ByteString ByteString + ByteString NodeToNodeInitiatorResult () ) -> diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index 3d025ea91d..4b8627dbd9 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -42,6 +42,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Server import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server ( TraceLocalTxSubmissionServerEvent (..) ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert import Ouroboros.Consensus.Node.GSM (TraceGsmEvent) import Ouroboros.Consensus.Protocol.Praos.AgentClient ( KESAgentClientTrace (..) @@ -79,6 +80,10 @@ data Tracers' remotePeer localPeer blk f = Tracers f (TraceLabelPeer remotePeer (TraceTxSubmissionOutbound (GenTxId blk) (GenTx blk))) , localTxSubmissionServerTracer :: f (TraceLocalTxSubmissionServerEvent blk) , mempoolTracer :: f (TraceEventMempool blk) + , perasCertDiffusionInboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionInbound blk)) + , perasCertDiffusionOutboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionOutbound blk)) , forgeTracer :: f (TraceLabelCreds (TraceForgeEvent blk)) , blockchainTimeTracer :: f (TraceBlockchainTimeEvent UTCTime) , forgeStateInfoTracer :: f (TraceLabelCreds (ForgeStateInfo blk)) @@ -109,6 +114,8 @@ instance , txOutboundTracer = f txOutboundTracer , localTxSubmissionServerTracer = f localTxSubmissionServerTracer , mempoolTracer = f mempoolTracer + , perasCertDiffusionInboundTracer = f perasCertDiffusionInboundTracer + , perasCertDiffusionOutboundTracer = f perasCertDiffusionOutboundTracer , forgeTracer = f forgeTracer , blockchainTimeTracer = f blockchainTimeTracer , forgeStateInfoTracer = f forgeStateInfoTracer @@ -146,6 +153,8 @@ nullTracers = , txOutboundTracer = nullTracer , localTxSubmissionServerTracer = nullTracer , mempoolTracer = nullTracer + , perasCertDiffusionInboundTracer = nullTracer + , perasCertDiffusionOutboundTracer = nullTracer , forgeTracer = nullTracer , blockchainTimeTracer = nullTracer , forgeStateInfoTracer = nullTracer @@ -185,6 +194,8 @@ showTracers tr = , txOutboundTracer = showTracing tr , localTxSubmissionServerTracer = showTracing tr , mempoolTracer = showTracing tr + , perasCertDiffusionInboundTracer = showTracing tr + , perasCertDiffusionOutboundTracer = showTracing tr , forgeTracer = showTracing tr , blockchainTimeTracer = showTracing tr , forgeStateInfoTracer = showTracing tr diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 847659c2ad..44f13dbfe8 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -83,6 +83,7 @@ import Ouroboros.Consensus.Mempool import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusion) import qualified Ouroboros.Consensus.Network.NodeToNode as NTN import Ouroboros.Consensus.Node.ExitPolicy import qualified Ouroboros.Consensus.Node.GSM as GSM @@ -1182,6 +1183,7 @@ runThreadNetwork Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing NodeId)) customNodeToNodeCodecs cfg ntnVersion = @@ -1201,6 +1203,9 @@ runThreadNetwork , cTxSubmission2Codec = mapFailureCodec CodecIdFailure $ NTN.cTxSubmission2Codec NTN.identityCodecs + , cPerasCertDiffusionCodec = + mapFailureCodec CodecIdFailure $ + NTN.cPerasCertDiffusionCodec NTN.identityCodecs , cKeepAliveCodec = mapFailureCodec CodecIdFailure $ NTN.cKeepAliveCodec NTN.identityCodecs @@ -1791,6 +1796,7 @@ type LimitedApp' m addr blk = Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing addr)) NodeToNodeInitiatorResult diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs index a455689110..34d0c567a9 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs @@ -103,6 +103,7 @@ prop_simple_bft_convergence , version = newestVersion (Proxy @MockBftBlock) } + testOutput :: TestOutput MockBftBlock testOutput = runTestNetwork testConfig From d47c331d8013265fd412fb512a9c14d5d1c097df Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 18 Sep 2025 10:51:35 +0200 Subject: [PATCH 33/35] Add changelog entry Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ...9_095938_thomas.bagrel_object_diffusion.md | 23 +++++++++++++++ ...9_095930_thomas.bagrel_object_diffusion.md | 27 ++++++++++++++++++ ...8_104810_thomas.bagrel_object_diffusion.md | 28 +++++++++++++++++++ 3 files changed, 78 insertions(+) create mode 100644 ouroboros-consensus-cardano/changelog.d/20250919_095938_thomas.bagrel_object_diffusion.md create mode 100644 ouroboros-consensus-diffusion/changelog.d/20250919_095930_thomas.bagrel_object_diffusion.md create mode 100644 ouroboros-consensus/changelog.d/20250918_104810_thomas.bagrel_object_diffusion.md diff --git a/ouroboros-consensus-cardano/changelog.d/20250919_095938_thomas.bagrel_object_diffusion.md b/ouroboros-consensus-cardano/changelog.d/20250919_095938_thomas.bagrel_object_diffusion.md new file mode 100644 index 0000000000..9efe00d438 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20250919_095938_thomas.bagrel_object_diffusion.md @@ -0,0 +1,23 @@ + + + + + +### Breaking + +- Added support for `NodeToNodeV_16` diff --git a/ouroboros-consensus-diffusion/changelog.d/20250919_095930_thomas.bagrel_object_diffusion.md b/ouroboros-consensus-diffusion/changelog.d/20250919_095930_thomas.bagrel_object_diffusion.md new file mode 100644 index 0000000000..8ba76bb8ff --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20250919_095930_thomas.bagrel_object_diffusion.md @@ -0,0 +1,27 @@ + + + + + +### Breaking + +- Modify `Ouroboros.Consensus{.Node,.Node.Tracer,.Network.NodeToNode}` to wire-in PerasCertDiffusion similarly to other mini-protocols (e.g. TX-submission) + +### Non-Breaking + +- Update `Test.ThreadNet.Network` in `unstable-diffusion-testlib` accordingly to the changes made in `Ouroboros.Consensus.Network.NodeToNode` diff --git a/ouroboros-consensus/changelog.d/20250918_104810_thomas.bagrel_object_diffusion.md b/ouroboros-consensus/changelog.d/20250918_104810_thomas.bagrel_object_diffusion.md new file mode 100644 index 0000000000..fba0bcc16c --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250918_104810_thomas.bagrel_object_diffusion.md @@ -0,0 +1,28 @@ + + + + + +### Breaking + +- Relies on a new version of `ouroboros-network` with support for ObjectDiffusion mini-protocol +- Added modules `Ouroboros.Consensus.MiniProtocol.ObjectDiffusion{.Inbound,.Outbound}` with implementations of the ObjectDiffusion protocol (quite similar/inspired from TX-submission, except that client = inbound, server = outbound) +- Added module `Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API` defining `ObjectPool{Reader,Writer}` interfaces, through which ObjectDiffusion accesses/stores the objects to send/that have been received. +- Added modules `Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert` and `Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert` containing definitions specific to `PerasCert` diffusion through the ObjectDiffusion mini-protocol +- Modifies `Ouroboros.Consensus.Node.Serialisation` to add CBOR serialisation (`SerialiseNodeToNode`) for `Point blk`, `Tip blk`, and `PerasCert blk` +- Added modules `Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke` and `Test.Consensus.MiniProtocol.ObjectDiffusion.PerasCert.Smoke` with smoke tests for the general ObjectDiffusion mini-protocol and for the `PerasCert`-specific instance of it From ab2c6b5789fbd4fdd2b6c9e85331afcf972e2066 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 22 Jul 2025 09:13:31 +0200 Subject: [PATCH 34/35] Adapt the HFC time translation layer for Peras - Add `PerasRoundLength` - introduce the `PerasEnabled` datatype to track values are only used when Peras is enabled - HFC: translate between Peras rounds and slots Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- .../Consensus/Byron/Ledger/Ledger.hs | 2 + .../Consensus/Shelley/Ledger/Ledger.hs | 5 + .../Test/Consensus/Cardano/Generators.hs | 10 +- .../Test/Consensus/HardFork/Combinator.hs | 1 + .../Ouroboros/Consensus/HardFork/Abstract.hs | 2 +- .../Consensus/HardFork/History/EraParams.hs | 78 ++++++++++++++- .../Consensus/HardFork/History/Qry.hs | 96 ++++++++++++++++++- .../Consensus/HardFork/History/Summary.hs | 64 +++++++++++-- .../Consensus/HardFork/History/Util.hs | 10 ++ .../Test/Ouroboros/Storage/TestBlock.hs | 1 + .../Test/Util/Orphans/Arbitrary.hs | 21 +++- .../Test/Consensus/HardFork/History.hs | 40 +++++++- .../Test/Consensus/HardFork/Infra.hs | 14 ++- .../Test/Consensus/HardFork/Summary.hs | 64 ++++++++++++- 14 files changed, 382 insertions(+), 26 deletions(-) diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index f57756fe0f..c1b7ebbf39 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/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 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 c096ab5d87..566a399a19 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 @@ -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,9 @@ 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 + -- see https://github.com/tweag/cardano-peras/issues/112 + eraPerasRoundLength = HardFork.NoPerasEnabled } where stabilityWindow = @@ -183,6 +187,7 @@ shelleyEraParamsNeverHardForks genesis = , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone , eraGenesisWin = GenesisWindow stabilityWindow + , eraPerasRoundLength = HardFork.NoPerasEnabled } where stabilityWindow = diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs index 0e0672c7c9..ac35649dad 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Generators.hs @@ -993,11 +993,11 @@ instance Arbitrary History.EraEnd where ] instance Arbitrary History.EraSummary where - arbitrary = - History.EraSummary - <$> arbitrary - <*> arbitrary - <*> arbitrary + -- Note: this generator may produce EraSummary with nonsensical bounds, + -- i.e. with existing PerasRoundNo at era start and Nothing for it at the end. + -- However, we only use this generator to check that the serialisation roundtrips, + -- and the internal structure of EraSummary is irrelevant for that. + arbitrary = History.EraSummary <$> arbitrary <*> arbitrary <*> arbitrary instance (Arbitrary a, SListI xs) => Arbitrary (NonEmpty xs a) where arbitrary = do diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index fdd205031b..b07657af11 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -164,6 +164,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = (History.StandardSafeZone (safeFromTipA k)) (safeZoneB k) <*> pure (GenesisWindow ((unNonZero $ maxRollbacks k) * 2)) + <*> pure (History.PerasEnabled defaultPerasRoundLength) shape :: History.Shape '[BlockA, BlockB] shape = History.Shape $ exactlyTwo eraParamsA eraParamsB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs index 7498024f6a..b2a07369df 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Abstract.hs @@ -67,6 +67,6 @@ neverForksHardForkSummary :: LedgerState blk mk -> HardFork.Summary '[blk] neverForksHardForkSummary getParams cfg _st = - HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin + HardFork.neverForksSummary eraEpochSize eraSlotLength eraGenesisWin eraPerasRoundLength where HardFork.EraParams{..} = getParams cfg diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs index e0784c8d34..4bcbc77786 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/EraParams.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -12,17 +16,23 @@ module Ouroboros.Consensus.HardFork.History.EraParams ( -- * API EraParams (..) , SafeZone (..) + , PerasEnabled + , pattern PerasEnabled + , pattern NoPerasEnabled + , PerasEnabledT (..) + , fromPerasEnabled -- * Defaults , defaultEraParams ) where -import Cardano.Binary (enforceSize) +import Cardano.Binary (DecoderError (DecoderErrorCustom), cborError) import Cardano.Ledger.BaseTypes (unNonZero) import Codec.CBOR.Decoding (Decoder, decodeListLen, decodeWord8) import Codec.CBOR.Encoding (Encoding, encodeListLen, encodeWord8) import Codec.Serialise (Serialise (..)) -import Control.Monad (void) +import Control.Monad (ap, liftM, void) +import Control.Monad.Trans.Class import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -136,10 +146,57 @@ data EraParams = EraParams , eraSlotLength :: !SlotLength , eraSafeZone :: !SafeZone , eraGenesisWin :: !GenesisWindow + , eraPerasRoundLength :: !(PerasEnabled PerasRoundLength) + -- ^ Optional, as not every era will be Peras-enabled } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks +-- | A marker for era parameters that are Peras-specific +-- and are not present in pre-Peras eras +newtype PerasEnabled a = MkPerasEnabled (Maybe a) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + deriving newtype (Functor, Applicative, Monad) + +pattern PerasEnabled :: a -> PerasEnabled a +pattern PerasEnabled x <- MkPerasEnabled (Just !x) + where + PerasEnabled !x = MkPerasEnabled (Just x) + +pattern NoPerasEnabled :: PerasEnabled a +pattern NoPerasEnabled = MkPerasEnabled Nothing + +{-# COMPLETE PerasEnabled, NoPerasEnabled #-} + +-- | A 'fromMaybe'-like eliminator for 'PerasEnabled' +fromPerasEnabled :: a -> PerasEnabled a -> a +fromPerasEnabled defaultValue = + \case + NoPerasEnabled -> defaultValue + PerasEnabled value -> value + +-- | A 'MaybeT'-line monad transformer. +-- +-- Used solely for the Peras-related hard fork combinator queries, +-- see 'Ouroboros.Consensus.HardFork.History.Qry'. +newtype PerasEnabledT m a = PerasEnabledT {runPerasEnabledT :: m (PerasEnabled a)} + deriving stock Functor + +instance (Functor m, Monad m) => Applicative (PerasEnabledT m) where + pure = PerasEnabledT . pure . PerasEnabled + (<*>) = ap + +instance Monad m => Monad (PerasEnabledT m) where + x >>= f = PerasEnabledT $ do + v <- runPerasEnabledT x + case v of + NoPerasEnabled -> pure NoPerasEnabled + PerasEnabled y -> runPerasEnabledT (f y) + +instance MonadTrans PerasEnabledT where + lift = PerasEnabledT . liftM PerasEnabled + -- | Default 'EraParams' -- -- We set @@ -147,6 +204,7 @@ data EraParams = EraParams -- * epoch size to @10k@ slots -- * the safe zone to @2k@ slots -- * the upper bound to 'NoLowerBound' +-- * the Peras Round Length is unset -- -- This is primarily useful for tests. defaultEraParams :: SecurityParam -> SlotLength -> EraParams @@ -156,6 +214,8 @@ defaultEraParams (SecurityParam k) slotLength = , eraSlotLength = slotLength , eraSafeZone = StandardSafeZone (unNonZero k * 2) , eraGenesisWin = GenesisWindow (unNonZero k * 2) + , -- Peras is disabled by default + eraPerasRoundLength = NoPerasEnabled } -- | Zone in which it is guaranteed that no hard fork can take place @@ -235,17 +295,27 @@ decodeSafeBeforeEpoch = do instance Serialise EraParams where encode EraParams{..} = mconcat $ - [ encodeListLen 4 + [ encodeListLen $ case eraPerasRoundLength of + NoPerasEnabled -> 4 + PerasEnabled{} -> 5 , encode (unEpochSize eraEpochSize) , encode eraSlotLength , encode eraSafeZone , encode (unGenesisWindow eraGenesisWin) ] + <> case eraPerasRoundLength of + NoPerasEnabled -> [] + PerasEnabled rl -> [encode (unPerasRoundLength rl)] decode = do - enforceSize "EraParams" 4 + len <- decodeListLen eraEpochSize <- EpochSize <$> decode eraSlotLength <- decode eraSafeZone <- decode eraGenesisWin <- GenesisWindow <$> decode + eraPerasRoundLength <- + case len of + 4 -> pure NoPerasEnabled + 5 -> PerasEnabled . PerasRoundLength <$> decode + _ -> cborError (DecoderErrorCustom "EraParams" "unexpected list length") return EraParams{..} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs index 9c4844c752..786c269433 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Qry.hs @@ -42,12 +42,15 @@ module Ouroboros.Consensus.HardFork.History.Qry , slotToSlotLength , slotToWallclock , wallclockToSlot + , perasRoundNoToSlot + , slotToPerasRoundNo ) where import Codec.Serialise (Serialise (..)) import Control.Exception (throw) import Control.Monad (ap, guard, liftM, (>=>)) import Control.Monad.Except () +import Control.Monad.Trans.Class import Data.Bifunctor import Data.Fixed (divMod') import Data.Foldable (toList) @@ -126,6 +129,8 @@ import Quiet These are equal by (INV-2a). + 5. Slot to Peras round translation. + This means that for values at that boundary, it does not matter if we use this era or the next era for the translation. However, this is only true for these 4 translations. If we are returning the era parameters directly, then @@ -182,12 +187,16 @@ newtype TimeInSlot = TimeInSlot {getTimeInSlot :: NominalDiffTime} deriving Gene newtype SlotInEra = SlotInEra {getSlotInEra :: Word64} deriving Generic newtype SlotInEpoch = SlotInEpoch {getSlotInEpoch :: Word64} deriving Generic newtype EpochInEra = EpochInEra {getEpochInEra :: Word64} deriving Generic +newtype PerasRoundNoInEra = PerasRoundNoInEra {getPerasRoundNoInEra :: Word64} deriving Generic +newtype SlotInPerasRound = SlotInPerasRound {getSlotInPerasRound :: Word64} deriving Generic deriving via Quiet TimeInEra instance Show TimeInEra deriving via Quiet TimeInSlot instance Show TimeInSlot deriving via Quiet SlotInEra instance Show SlotInEra deriving via Quiet SlotInEpoch instance Show SlotInEpoch deriving via Quiet EpochInEra instance Show EpochInEra +deriving via Quiet PerasRoundNoInEra instance Show PerasRoundNoInEra +deriving via Quiet SlotInPerasRound instance Show SlotInPerasRound {------------------------------------------------------------------------------- Expressions @@ -212,23 +221,30 @@ data Expr (f :: Type -> Type) :: Type -> Type where EAbsToRelTime :: Expr f RelativeTime -> Expr f TimeInEra EAbsToRelSlot :: Expr f SlotNo -> Expr f SlotInEra EAbsToRelEpoch :: Expr f EpochNo -> Expr f EpochInEra + EAbsToRelPerasRoundNo :: Expr f PerasRoundNo -> Expr f (PerasEnabled PerasRoundNoInEra) -- Convert from era-relative to absolute ERelToAbsTime :: Expr f TimeInEra -> Expr f RelativeTime ERelToAbsSlot :: Expr f (SlotInEra, TimeInSlot) -> Expr f SlotNo ERelToAbsEpoch :: Expr f (EpochInEra, SlotInEpoch) -> Expr f EpochNo + ERelToAbsPerasRoundNo :: + Expr f (PerasEnabled PerasRoundNoInEra) -> Expr f (PerasEnabled PerasRoundNo) -- Convert between relative values ERelTimeToSlot :: Expr f TimeInEra -> Expr f (SlotInEra, TimeInSlot) ERelSlotToTime :: Expr f SlotInEra -> Expr f TimeInEra ERelSlotToEpoch :: Expr f SlotInEra -> Expr f (EpochInEra, SlotInEpoch) ERelEpochToSlot :: Expr f EpochInEra -> Expr f SlotInEra + ERelPerasRoundNoToSlot :: Expr f (PerasEnabled PerasRoundNoInEra) -> Expr f (PerasEnabled SlotInEra) + ERelSlotToPerasRoundNo :: + Expr f SlotInEra -> Expr f (PerasEnabled (PerasRoundNoInEra, SlotInPerasRound)) -- Get era parameters -- The arguments are used for bound checks ESlotLength :: Expr f SlotNo -> Expr f SlotLength EEpochSize :: Expr f EpochNo -> Expr f EpochSize EGenesisWindow :: Expr f SlotNo -> Expr f GenesisWindow + EPerasRoundLength :: Expr f PerasRoundNo -> Expr f (PerasEnabled PerasRoundLength) {------------------------------------------------------------------------------- Interpreter @@ -247,6 +263,11 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e EraUnbounded -> return () EraEnd b -> guard $ p b + guardEndPeras :: (Bound -> PerasEnabledT Maybe Bool) -> PerasEnabledT Maybe () + guardEndPeras p = case eraEnd of + EraUnbounded -> pure () + EraEnd end -> lift . guard =<< p end + go :: Expr Identity a -> Maybe a go (EVar a) = return $ runIdentity a @@ -279,6 +300,13 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e e <- go expr guard (e >= boundEpoch eraStart) return $ EpochInEra (countEpochs e (boundEpoch eraStart)) + go (EAbsToRelPerasRoundNo expr) = + runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + absPerasRoundNo <- lift $ go expr + lift . guard $ absPerasRoundNo >= eraStartPerasRound + let roundInEra = countPerasRounds absPerasRoundNo eraStartPerasRound + pure . PerasRoundNoInEra $ roundInEra -- Convert relative to absolute -- @@ -304,6 +332,15 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e absEpoch < boundEpoch end || absEpoch == boundEpoch end && getSlotInEpoch s == 0 return absEpoch + go (ERelToAbsPerasRoundNo expr) = runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + relPerasRound <- PerasEnabledT $ go expr + let absPerasRound = addPerasRounds (getPerasRoundNoInEra relPerasRound) eraStartPerasRound + + guardEndPeras $ \end -> do + eraEndPerasRound <- PerasEnabledT . Just $ boundPerasRound end + pure $ absPerasRound <= eraEndPerasRound + pure absPerasRound -- Convert between relative values -- @@ -321,6 +358,14 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e go (ERelEpochToSlot expr) = do e <- go expr return $ SlotInEra (getEpochInEra e * epochSize) + go (ERelPerasRoundNoToSlot expr) = runPerasEnabledT $ do + PerasRoundNoInEra relPerasRoundNo <- PerasEnabledT $ go expr + PerasRoundLength perasRoundLength <- PerasEnabledT . Just $ eraPerasRoundLength + pure $ SlotInEra (relPerasRoundNo * perasRoundLength) + go (ERelSlotToPerasRoundNo expr) = runPerasEnabledT $ do + SlotInEra relSlot <- lift $ go expr + PerasRoundLength perasRoundLength <- PerasEnabledT . Just $ eraPerasRoundLength + pure . bimap PerasRoundNoInEra SlotInPerasRound $ relSlot `divMod` perasRoundLength -- Get era parameters -- @@ -342,6 +387,14 @@ evalExprInEra EraSummary{..} = \(ClosedExpr e) -> go e guard $ s >= boundSlot eraStart guardEnd $ \end -> s < boundSlot end return eraGenesisWin + go (EPerasRoundLength expr) = runPerasEnabledT $ do + eraStartPerasRound <- PerasEnabledT . Just $ boundPerasRound eraStart + absPerasRound <- lift $ go expr + lift . guard $ absPerasRound >= eraStartPerasRound + guardEndPeras $ \end -> do + eraEndPerasRound <- PerasEnabledT . Just $ boundPerasRound end + pure $ absPerasRound < eraEndPerasRound + PerasEnabledT . Just $ eraPerasRoundLength {------------------------------------------------------------------------------- PastHorizonException @@ -499,7 +552,7 @@ slotToEpoch' absSlot = -- | Translate 'SlotNo' to its corresponding 'EpochNo' -- -- Additionally returns the relative slot within this epoch and how many --- slots are left in this slot. +-- slots are left in this epoch. slotToEpoch :: SlotNo -> Qry (EpochNo, Word64, Word64) slotToEpoch absSlot = aux <$> qryFromExpr (slotToEpochExpr absSlot) @@ -528,6 +581,38 @@ epochToSize :: EpochNo -> Qry EpochSize epochToSize absEpoch = qryFromExpr (epochToSizeExpr absEpoch) +-- | Translate 'PerasRoundNo' to the 'SlotNo' of the first slot in that Peras round +-- +-- Additionally returns the length of the round. +perasRoundNoToSlot :: PerasRoundNo -> Qry (PerasEnabled (SlotNo, PerasRoundLength)) +perasRoundNoToSlot perasRoundNo = runPerasEnabledT $ do + relSlot <- + PerasEnabledT $ qryFromExpr (ERelPerasRoundNoToSlot (EAbsToRelPerasRoundNo (ELit perasRoundNo))) + absSlot <- lift $ qryFromExpr (ERelToAbsSlot (EPair (ELit relSlot) (ELit (TimeInSlot 0)))) + roundLength <- PerasEnabledT $ qryFromExpr (perasRoundNoPerasRoundLengthExpr perasRoundNo) + pure (absSlot, roundLength) + +-- | Translate 'SlotNo' to its corresponding 'PerasRoundNo' +-- +-- Additionally returns the relative slot within this round and how many +-- slots are left in this round. +slotToPerasRoundNo :: SlotNo -> Qry (PerasEnabled (PerasRoundNo, Word64, Word64)) +slotToPerasRoundNo absSlot = runPerasEnabledT $ do + (relPerasRoundNo, slotInPerasRound) <- + PerasEnabledT $ + qryFromExpr (ERelSlotToPerasRoundNo (EAbsToRelSlot (ELit absSlot))) + absPerasRoundNo <- + PerasEnabledT $ + qryFromExpr (ERelToAbsPerasRoundNo (ELit (PerasEnabled relPerasRoundNo))) + roundLength <- + PerasEnabledT $ + qryFromExpr (perasRoundNoPerasRoundLengthExpr absPerasRoundNo) + pure $ + ( absPerasRoundNo + , getSlotInPerasRound slotInPerasRound + , unPerasRoundLength roundLength - getSlotInPerasRound slotInPerasRound + ) + {------------------------------------------------------------------------------- Supporting expressions for the queries above -------------------------------------------------------------------------------} @@ -581,6 +666,10 @@ slotToGenesisWindow :: SlotNo -> Expr f GenesisWindow slotToGenesisWindow absSlot = EGenesisWindow (ELit absSlot) +perasRoundNoPerasRoundLengthExpr :: PerasRoundNo -> Expr f (PerasEnabled PerasRoundLength) +perasRoundNoPerasRoundLengthExpr absPerasRoundNo = + EPerasRoundLength (ELit absPerasRoundNo) + {------------------------------------------------------------------------------- 'Show' instances -------------------------------------------------------------------------------} @@ -629,13 +718,18 @@ instance Show (ClosedExpr a) where EAbsToRelTime e -> showString "EAbsToRelTime " . go n 11 e EAbsToRelSlot e -> showString "EAbsToRelSlot " . go n 11 e EAbsToRelEpoch e -> showString "EAbsToRelEpoch " . go n 11 e + EAbsToRelPerasRoundNo e -> showString "EAbsToRelPerasRoundNo " . go n 11 e ERelToAbsTime e -> showString "ERelToAbsTime " . go n 11 e ERelToAbsSlot e -> showString "ERelToAbsSlot " . go n 11 e ERelToAbsEpoch e -> showString "ERelToAbsEpoch " . go n 11 e + ERelToAbsPerasRoundNo e -> showString "ERelToAbsPerasRoundNo " . go n 11 e ERelTimeToSlot e -> showString "ERelTimeToSlot " . go n 11 e ERelSlotToTime e -> showString "ERelSlotToTime " . go n 11 e ERelSlotToEpoch e -> showString "ERelSlotToEpoch " . go n 11 e ERelEpochToSlot e -> showString "ERelEpochToSlot " . go n 11 e + ERelPerasRoundNoToSlot e -> showString "ERelPerasRoundNoToSlot " . go n 11 e + ERelSlotToPerasRoundNo e -> showString "ERelSlotToPerasRoundNo " . go n 11 e ESlotLength e -> showString "ESlotLength " . go n 11 e EEpochSize e -> showString "EEpochSize " . go n 11 e EGenesisWindow e -> showString "EGenesisWindow " . go n 11 e + EPerasRoundLength e -> showString "EPerasRoundLength " . go n 11 e diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs index 0ef241f4a5..03b71562e1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Summary.hs @@ -47,7 +47,7 @@ module Ouroboros.Consensus.HardFork.History.Summary , summaryInit ) where -import Cardano.Binary (enforceSize) +import Cardano.Binary (DecoderError (DecoderErrorCustom), cborError, decodeListLen, enforceSize) import Codec.CBOR.Decoding ( TokenType (TypeNull) , decodeNull @@ -83,6 +83,8 @@ data Bound = Bound { boundTime :: !RelativeTime , boundSlot :: !SlotNo , boundEpoch :: !EpochNo + , boundPerasRound :: !(PerasEnabled PerasRoundNo) + -- ^ Optional, as not every era will be Peras-enabled } deriving stock (Show, Eq, Generic) deriving anyclass NoThunks @@ -93,6 +95,9 @@ initBound = { boundTime = RelativeTime 0 , boundSlot = SlotNo 0 , boundEpoch = EpochNo 0 + , -- TODO(geo2a): we may want to make this configurable, + -- see https://github.com/tweag/cardano-peras/issues/112 + boundPerasRound = NoPerasEnabled } -- | Version of 'mkUpperBound' when the upper bound may not be known @@ -122,12 +127,16 @@ mkUpperBound EraParams{..} lo hiEpoch = { boundTime = addRelTime inEraTime $ boundTime lo , boundSlot = addSlots inEraSlots $ boundSlot lo , boundEpoch = hiEpoch + , boundPerasRound = addPerasRounds <$> inEraPerasRounds <*> boundPerasRound lo } where inEraEpochs, inEraSlots :: Word64 inEraEpochs = countEpochs hiEpoch (boundEpoch lo) inEraSlots = inEraEpochs * unEpochSize eraEpochSize + inEraPerasRounds :: PerasEnabled Word64 + inEraPerasRounds = div <$> PerasEnabled inEraSlots <*> (unPerasRoundLength <$> eraPerasRoundLength) + inEraTime :: NominalDiffTime inEraTime = fromIntegral inEraSlots * getSlotLength eraSlotLength @@ -182,6 +191,10 @@ slotToEpochBound EraParams{eraEpochSize = EpochSize epochSize} lo hiSlot = -- > t' - t == ((s' - s) * slotLen) -- > (t' - t) / slotLen == s' - s -- > s + ((t' - t) / slotLen) == s' +-- +-- Ouroboros Peras adds an invariant relating epoch size and Peras voting round lengths: +-- > epochSize % perasRoundLength == 0 +-- i.e. the round length should divide the epoch size data EraSummary = EraSummary { eraStart :: !Bound -- ^ Inclusive lower bound @@ -219,8 +232,9 @@ newtype Summary xs = Summary {getSummary :: NonEmpty xs EraSummary} -------------------------------------------------------------------------------} -- | 'Summary' for a ledger that never forks -neverForksSummary :: EpochSize -> SlotLength -> GenesisWindow -> Summary '[x] -neverForksSummary epochSize slotLen genesisWindow = +neverForksSummary :: + EpochSize -> SlotLength -> GenesisWindow -> PerasEnabled PerasRoundLength -> Summary '[x] +neverForksSummary epochSize slotLen genesisWindow perasRoundLength = Summary $ NonEmptyOne $ EraSummary @@ -232,6 +246,7 @@ neverForksSummary epochSize slotLen genesisWindow = , eraSlotLength = slotLen , eraSafeZone = UnsafeIndefiniteSafeZone , eraGenesisWin = genesisWindow + , eraPerasRoundLength = perasRoundLength } } @@ -331,8 +346,19 @@ summarize :: Transitions xs -> Summary xs summarize ledgerTip = \(Shape shape) (Transitions transitions) -> - Summary $ go initBound shape transitions + Summary $ go initBoundWithPeras shape transitions where + -- as noted in the haddock, this function is only used for testing purposes, + -- therefore we make the initial era is Peras-enabled, which means + -- we only test Peras-enabled eras. It is rather difficult + -- to parameterise the test suite, as it requires also parameterise many non-test functions, like + -- 'HF.initBound'. + -- + -- TODO(geo2a): revisit this hard-coding of enabling Peras when + -- we're further into the integration process + -- see https://github.com/tweag/cardano-peras/issues/112 + initBoundWithPeras = initBound{boundPerasRound = PerasEnabled . PerasRoundNo $ 0} + go :: Bound -> -- Lower bound for current era Exactly (x ': xs) EraParams -> -- params for all eras @@ -471,6 +497,21 @@ invariantSummary = \(Summary summary) -> , " (INV-2b)" ] + case eraPerasRoundLength curParams of + NoPerasEnabled -> pure () + PerasEnabled perasRoundLength -> + unless + ( (unEpochSize $ eraEpochSize curParams) + `mod` (unPerasRoundLength perasRoundLength) + == 0 + ) + $ throwError + $ mconcat + [ "Invalid Peras round length " + , show curSummary + , " (Peras round length does not divide epoch size)" + ] + go curEnd next where curStart :: Bound @@ -484,18 +525,27 @@ invariantSummary = \(Summary summary) -> instance Serialise Bound where encode Bound{..} = - mconcat - [ encodeListLen 3 + mconcat $ + [ encodeListLen $ case boundPerasRound of + NoPerasEnabled -> 3 + PerasEnabled{} -> 4 , encode boundTime , encode boundSlot , encode boundEpoch ] + <> case boundPerasRound of + NoPerasEnabled -> [] + PerasEnabled bound -> [encode bound] decode = do - enforceSize "Bound" 3 + len <- decodeListLen boundTime <- decode boundSlot <- decode boundEpoch <- decode + boundPerasRound <- case len of + 3 -> pure NoPerasEnabled + 4 -> PerasEnabled <$> decode + _ -> cborError (DecoderErrorCustom "Bound" "unexpected list length") return Bound{..} instance Serialise EraEnd where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs index daf8fd443e..7cdebd4ea0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/History/Util.hs @@ -2,8 +2,10 @@ module Ouroboros.Consensus.HardFork.History.Util ( -- * Adding and subtracting slots/epochs addEpochs , addSlots + , addPerasRounds , countEpochs , countSlots + , countPerasRounds , subSlots ) where @@ -26,6 +28,9 @@ subSlots n (SlotNo x) = assert (x >= n) $ SlotNo (x - n) addEpochs :: Word64 -> EpochNo -> EpochNo addEpochs n (EpochNo x) = EpochNo (x + n) +addPerasRounds :: Word64 -> PerasRoundNo -> PerasRoundNo +addPerasRounds n (PerasRoundNo x) = PerasRoundNo (x + n) + -- | @countSlots to fr@ counts the slots from @fr@ to @to@ (@to >= fr@) countSlots :: HasCallStack => SlotNo -> SlotNo -> Word64 countSlots (SlotNo to) (SlotNo fr) = assert (to >= fr) $ to - fr @@ -37,3 +42,8 @@ countEpochs :: HasCallStack => EpochNo -> EpochNo -> Word64 countEpochs (EpochNo to) (EpochNo fr) = assert (to >= fr) $ to - fr where _ = keepRedundantConstraint (Proxy :: Proxy HasCallStack) + +countPerasRounds :: HasCallStack => PerasRoundNo -> PerasRoundNo -> Word64 +countPerasRounds (PerasRoundNo to) (PerasRoundNo fr) = assert (to >= fr) $ to - fr + where + _ = keepRedundantConstraint (Proxy :: Proxy HasCallStack) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs index 08ef2fa6f9..47b4ab762a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Storage/TestBlock.hs @@ -750,6 +750,7 @@ mkTestConfig k ChunkSize{chunkCanContainEBB, numRegularBlocks} = , eraSlotLength = slotLength , eraSafeZone = HardFork.StandardSafeZone (unNonZero (maxRollbacks k) * 2) , eraGenesisWin = GenesisWindow (unNonZero (maxRollbacks k) * 2) + , eraPerasRoundLength = HardFork.PerasEnabled defaultPerasRoundLength } instance ImmutableEraParams TestBlock where diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs index 27b96abf4e..544f25db2a 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/Arbitrary.hs @@ -310,7 +310,17 @@ instance -------------------------------------------------------------------------------} instance Arbitrary EraParams where - arbitrary = EraParams <$> arbitrary <*> arbitrary <*> arbitrary <*> (GenesisWindow <$> arbitrary) + arbitrary = + EraParams + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> (GenesisWindow <$> arbitrary) + <*> mPerasRoundLength + where + mPerasRoundLength :: Gen (PerasEnabled PerasRoundLength) + mPerasRoundLength = do + (\x -> if x == 0 then NoPerasEnabled else PerasEnabled . PerasRoundLength $ x) <$> arbitrary instance Arbitrary SafeZone where arbitrary = @@ -332,6 +342,15 @@ instance Arbitrary Bound where <$> (RelativeTime <$> arbitrary) <*> (SlotNo <$> arbitrary) <*> (EpochNo <$> arbitrary) + <*> mPerasRoundNo + where + mPerasRoundNo :: Gen (PerasEnabled PerasRoundNo) + mPerasRoundNo = do + n <- arbitrary + pure $ + if n == 0 + then NoPerasEnabled + else PerasEnabled (PerasRoundNo n) instance Arbitrary (K Past blk) where arbitrary = K <$> (Past <$> arbitrary <*> arbitrary) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs index 95491738d3..a2ad4d3bc8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/History.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -65,11 +66,11 @@ import Test.Util.QuickCheck -- General approach: -- -- * Generate a chain of events --- * Each event records its own 'RelativeTime', 'SlotNo', and 'EpochNo' +-- * Each event records its own 'RelativeTime', 'SlotNo', 'EpochNo', and 'PerasRoundNo' -- * We then construct a 'HF.Summary' from a /prefix/ of this chain -- * We then pick an arbitrary event from the (full) chain: -- a. If that event is on the prefix of the chain, or within the safe zone, we --- expect to be able to do any slot/epoch or slot/time conversion, and we +-- expect to be able to do any slot/epoch, slot/time or Peras round/slot conversion, and we -- can easily verify the result by comparing it to the values the 'Event' -- itself reports. -- b. If the event is outside of safe zone, we expect the conversion to throw @@ -96,6 +97,7 @@ tests = , testProperty "eventWallclockToSlot" eventWallclockToSlot , testProperty "epochInfoSlotToEpoch" epochInfoSlotToEpoch , testProperty "epochInfoEpochToSlot" epochInfoEpochToSlot + , testProperty "eventPerasRounNoToSlot" eventPerasRoundNoToSlot , testProperty "query vs expr" queryVsExprConsistency ] ] @@ -208,6 +210,20 @@ eventWallclockToSlot chain@ArbitraryChain{..} = diff :: NominalDiffTime diff = arbitraryDiffTime arbitraryParams +eventPerasRoundNoToSlot :: ArbitraryChain -> Property +eventPerasRoundNoToSlot chain@ArbitraryChain{..} = + testSkeleton chain (HF.perasRoundNoToSlot eventTimePerasRoundNo) $ + \case + HF.NoPerasEnabled -> property True + HF.PerasEnabled (startOfPerasRound, roundLength) -> + conjoin + [ eventTimeSlot + === (HF.addSlots eventTimeSlotInPerasRound startOfPerasRound) + , eventTimeSlotInPerasRound `lt` (unPerasRoundLength roundLength) + ] + where + EventTime{..} = eventTime arbitraryEvent + -- | Composing queries should be equivalent to composing expressions. -- -- This is a regression test. Each expression in a query should be evaluated in @@ -503,7 +519,13 @@ data EventTime = EventTime { eventTimeSlot :: SlotNo , eventTimeEpochNo :: EpochNo , eventTimeEpochSlot :: Word64 + -- ^ Relative slot withing the current epoch round, + -- needed to be able to advance the epoch number , eventTimeRelative :: RelativeTime + , eventTimePerasRoundNo :: PerasRoundNo + , eventTimeSlotInPerasRound :: Word64 + -- ^ Relative slot withing the current Peras round, + -- needed to be able to advance the round number } deriving Show @@ -514,6 +536,8 @@ initEventTime = , eventTimeEpochNo = EpochNo 0 , eventTimeEpochSlot = 0 , eventTimeRelative = RelativeTime 0 + , eventTimePerasRoundNo = PerasRoundNo 0 + , eventTimeSlotInPerasRound = 0 } -- | Next time slot @@ -526,6 +550,8 @@ stepEventTime HF.EraParams{..} EventTime{..} = , eventTimeRelative = addRelTime (getSlotLength eraSlotLength) $ eventTimeRelative + , eventTimePerasRoundNo = perasRoundNo' + , eventTimeSlotInPerasRound = slotInPerasRound' } where epoch' :: EpochNo @@ -535,6 +561,16 @@ stepEventTime HF.EraParams{..} EventTime{..} = then (succ eventTimeEpochNo, 0) else (eventTimeEpochNo, succ eventTimeEpochSlot) + perasRoundNo' :: PerasRoundNo + slotInPerasRound' :: Word64 + args@(perasRoundNo', slotInPerasRound') = + case eraPerasRoundLength of + HF.NoPerasEnabled -> args + HF.PerasEnabled (PerasRoundLength perasRoundLength) -> + if succ eventTimeSlotInPerasRound == perasRoundLength + then (succ eventTimePerasRoundNo, 0) + else (eventTimePerasRoundNo, succ eventTimeSlotInPerasRound) + {------------------------------------------------------------------------------- Chain model -----------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs index 150ccda30e..4cecb8c968 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Infra.hs @@ -35,7 +35,9 @@ import Data.SOP.Strict import Data.Word import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime +import Ouroboros.Consensus.HardFork.History (Bound (..)) import qualified Ouroboros.Consensus.HardFork.History as HF +import Ouroboros.Consensus.HardFork.History.EraParams (EraParams (..)) import Test.QuickCheck {------------------------------------------------------------------------------- @@ -121,6 +123,11 @@ genEraParams = do eraSlotLength <- slotLengthFromSec <$> choose (1, 5) eraSafeZone <- genSafeZone eraGenesisWin <- GenesisWindow <$> choose (1, 10) + -- we restrict Peras round length to divide the epoch size. + -- for testing purposes, we include Peras round length in every era. + eraPerasRoundLength <- + HF.PerasEnabled . PerasRoundLength + <$> choose (1, 10) `suchThat` (\x -> (unEpochSize eraEpochSize) `mod` x == 0) return HF.EraParams{..} where genSafeZone :: Gen HF.SafeZone @@ -154,8 +161,13 @@ genShape eras = HF.Shape <$> erasMapStateM genParams eras (EpochNo 0) genSummary :: Eras xs -> Gen (HF.Summary xs) genSummary is = - HF.Summary <$> erasUnfoldAtMost genEraSummary is HF.initBound + HF.Summary <$> erasUnfoldAtMost genEraSummary is initBoundWithPeras where + -- TODO(geo2a): revisit this hard-coding of enabling Peras when + -- we're further into the integration process + -- see https://github.com/tweag/cardano-peras/issues/112 + initBoundWithPeras = HF.initBound{boundPerasRound = HF.PerasEnabled . PerasRoundNo $ 0} + genEraSummary :: Era -> HF.Bound -> Gen (HF.EraSummary, HF.EraEnd) genEraSummary _era lo = do params <- genEraParams diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs index c1bc38c9f6..361e5d0966 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/HardFork/Summary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} @@ -19,6 +20,7 @@ -- * Converting slot to an epoch and then back to a slot should be an identity -- (modulo the time spent in that epoch). -- * Converting an epoch to a slot and then back should be an identity. +-- * Converting a Peras round number to a slot and then back should be an identity. module Test.Consensus.HardFork.Summary (tests) where import Data.Time @@ -50,6 +52,7 @@ tests = , testProperty "roundtripSlotWallclock" roundtripSlotWallclock , testProperty "roundtripSlotEpoch" roundtripSlotEpoch , testProperty "roundtripEpochSlot" roundtripEpochSlot + , testProperty "roundtripPerasRoundSlot" roundtripPerasRoundSlot , testProperty "reportsPastHorizon" reportsPastHorizon ] ] @@ -131,6 +134,28 @@ roundtripEpochSlot s@ArbitrarySummary{beforeHorizonEpoch = epoch} = , inEpoch + slotsLeft === unEpochSize epochSize ] +-- | Test that conversion between Peras rounds and slots roundtips. +-- Additionally, test that the relative slot in round and remaining +-- slots in round are withing the round length. +roundtripPerasRoundSlot :: ArbitrarySummary -> Property +roundtripPerasRoundSlot s@ArbitrarySummary{beforeHorizonPerasRoundNo} = + case beforeHorizonPerasRoundNo of + HF.NoPerasEnabled -> property True + HF.PerasEnabled perasRoundNo -> + noPastHorizonException s $ + HF.perasRoundNoToSlot perasRoundNo >>= \case + HF.NoPerasEnabled -> pure $ property True + HF.PerasEnabled (slot, PerasRoundLength perasRoundLength) -> do + HF.slotToPerasRoundNo slot >>= \case + HF.NoPerasEnabled -> pure $ property True + HF.PerasEnabled (perasRoundNo', slotInRound, remainingSlotsInRound) -> + pure $ + conjoin + [ perasRoundNo' === perasRoundNo + , slotInRound `lt` perasRoundLength + , remainingSlotsInRound `le` perasRoundLength + ] + reportsPastHorizon :: ArbitrarySummary -> Property reportsPastHorizon s@ArbitrarySummary{..} = conjoin @@ -146,6 +171,9 @@ reportsPastHorizon s@ArbitrarySummary{..} = , case mPastHorizonEpoch of Just x -> isPastHorizonException s $ HF.epochToSlot x Nothing -> property True + , case mPastHorizonPerasRoundNo of + Just (HF.PerasEnabled x) -> isPastHorizonException s $ HF.perasRoundNoToSlot x + _ -> property True ] {------------------------------------------------------------------------------- @@ -160,9 +188,13 @@ data ArbitrarySummary = forall xs. ArbitrarySummary , beforeHorizonTime :: RelativeTime , beforeHorizonSlot :: SlotNo , beforeHorizonEpoch :: EpochNo + , beforeHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo + -- ^ 'PerasRoundNo' is not optional here, + -- i.e. we do not model non-Peras eras in the time conversion tests , mPastHorizonTime :: Maybe RelativeTime , mPastHorizonSlot :: Maybe SlotNo , mPastHorizonEpoch :: Maybe EpochNo + , mPastHorizonPerasRoundNo :: Maybe (HF.PerasEnabled PerasRoundNo) } deriving instance Show ArbitrarySummary @@ -181,10 +213,12 @@ instance Arbitrary ArbitrarySummary where beforeHorizonSlots <- choose (0, 100_000_000) beforeHorizonEpochs <- choose (0, 1_000_000) beforeHorizonSeconds <- choose (0, 1_000_000_000) + beforeHorizonPerasRounds <- HF.PerasEnabled <$> choose (0, 1_000) let beforeHorizonSlot :: SlotNo beforeHorizonEpoch :: EpochNo beforeHorizonTime :: RelativeTime + beforeHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo beforeHorizonSlot = HF.addSlots @@ -198,19 +232,25 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac (beforeHorizonSeconds :: Double)) (HF.boundTime summaryStart) - + beforeHorizonPerasRoundNo = + HF.addPerasRounds + <$> beforeHorizonPerasRounds + <*> HF.boundPerasRound summaryStart return ArbitrarySummary { arbitrarySummary = summary , beforeHorizonTime , beforeHorizonSlot , beforeHorizonEpoch + , beforeHorizonPerasRoundNo , mPastHorizonTime = Nothing , mPastHorizonSlot = Nothing , mPastHorizonEpoch = Nothing + , mPastHorizonPerasRoundNo = Nothing } HF.EraEnd summaryEnd -> do let summarySlots, summaryEpochs :: Word64 + summaryPerasRounds :: HF.PerasEnabled Word64 summarySlots = HF.countSlots (HF.boundSlot summaryEnd) @@ -219,7 +259,10 @@ instance Arbitrary ArbitrarySummary where HF.countEpochs (HF.boundEpoch summaryEnd) (HF.boundEpoch summaryStart) - + summaryPerasRounds = + HF.countPerasRounds + <$> HF.boundPerasRound summaryEnd + <*> HF.boundPerasRound summaryStart summaryTimeSpan :: NominalDiffTime summaryTimeSpan = diffRelTime @@ -236,7 +279,9 @@ instance Arbitrary ArbitrarySummary where beforeHorizonSeconds <- choose (0, summaryTimeSpanSeconds) `suchThat` \x -> x /= summaryTimeSpanSeconds - + beforeHorizonPerasRounds <- case summaryPerasRounds of + HF.NoPerasEnabled -> pure HF.NoPerasEnabled + HF.PerasEnabled rounds -> HF.PerasEnabled <$> choose (0, rounds - 1) let beforeHorizonSlot :: SlotNo beforeHorizonEpoch :: EpochNo beforeHorizonTime :: RelativeTime @@ -253,16 +298,22 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac beforeHorizonSeconds) (HF.boundTime summaryStart) + beforeHorizonPerasRoundNo = + HF.addPerasRounds + <$> beforeHorizonPerasRounds + <*> HF.boundPerasRound summaryStart -- Pick arbitrary values past the horizon pastHorizonSlots :: Word64 <- choose (0, 10) pastHorizonEpochs :: Word64 <- choose (0, 10) pastHorizonSeconds :: Double <- choose (0, 10) + pastHorizonPerasRounds :: HF.PerasEnabled Word64 <- HF.PerasEnabled <$> choose (0, 10) let pastHorizonSlot :: SlotNo pastHorizonEpoch :: EpochNo pastHorizonTime :: RelativeTime + pastHorizonPerasRoundNo :: HF.PerasEnabled PerasRoundNo pastHorizonSlot = HF.addSlots @@ -276,16 +327,21 @@ instance Arbitrary ArbitrarySummary where addRelTime (realToFrac pastHorizonSeconds) (HF.boundTime summaryEnd) - + pastHorizonPerasRoundNo = + HF.addPerasRounds + <$> pastHorizonPerasRounds + <*> HF.boundPerasRound summaryEnd return ArbitrarySummary { arbitrarySummary = summary , beforeHorizonTime , beforeHorizonSlot , beforeHorizonEpoch + , beforeHorizonPerasRoundNo , mPastHorizonTime = Just pastHorizonTime , mPastHorizonSlot = Just pastHorizonSlot , mPastHorizonEpoch = Just pastHorizonEpoch + , mPastHorizonPerasRoundNo = Just pastHorizonPerasRoundNo } shrink summary@ArbitrarySummary{..} = From 66e465788b60cb777de7463f238c75250ccadbdd Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 18 Sep 2025 11:46:59 +0200 Subject: [PATCH 35/35] Add changelog entry Co-authored-by: Agustin Mista Co-authored-by: Alexander Esgen Co-authored-by: Georgy Lukyanov Co-authored-by: Thomas BAGREL Co-authored-by: Nicolas BACQUEY Co-authored-by: Nicolas "Niols" Jeannerod --- ...0919_101630_thomas.bagrel_hfc_era_peras.md | 29 +++++++++++++++ ...0919_101623_thomas.bagrel_hfc_era_peras.md | 24 +++++++++++++ ...0918_114333_thomas.bagrel_hfc_era_peras.md | 36 +++++++++++++++++++ 3 files changed, 89 insertions(+) create mode 100644 ouroboros-consensus-cardano/changelog.d/20250919_101630_thomas.bagrel_hfc_era_peras.md create mode 100644 ouroboros-consensus-diffusion/changelog.d/20250919_101623_thomas.bagrel_hfc_era_peras.md create mode 100644 ouroboros-consensus/changelog.d/20250918_114333_thomas.bagrel_hfc_era_peras.md diff --git a/ouroboros-consensus-cardano/changelog.d/20250919_101630_thomas.bagrel_hfc_era_peras.md b/ouroboros-consensus-cardano/changelog.d/20250919_101630_thomas.bagrel_hfc_era_peras.md new file mode 100644 index 0000000000..043efd4958 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20250919_101630_thomas.bagrel_hfc_era_peras.md @@ -0,0 +1,29 @@ + + + + + +### Breaking + +- Add `eraPerasRoundLength` parameters to `{Byron,Shelley}EraParams` structs. + + +### Non-Breaking + +- The `EraSummary`, while not modified directly, is now Peras-aware via `EraParams` + - in a valid summary, Peras round length must divide the epoch size. diff --git a/ouroboros-consensus-diffusion/changelog.d/20250919_101623_thomas.bagrel_hfc_era_peras.md b/ouroboros-consensus-diffusion/changelog.d/20250919_101623_thomas.bagrel_hfc_era_peras.md new file mode 100644 index 0000000000..18ef030930 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20250919_101623_thomas.bagrel_hfc_era_peras.md @@ -0,0 +1,24 @@ + + + + +### Non-Breaking + +- Update code using `EraParams` now that it has a new field `eraPerasRoundLength` for Byron and Shelley eras. + + diff --git a/ouroboros-consensus/changelog.d/20250918_114333_thomas.bagrel_hfc_era_peras.md b/ouroboros-consensus/changelog.d/20250918_114333_thomas.bagrel_hfc_era_peras.md new file mode 100644 index 0000000000..912fa15175 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250918_114333_thomas.bagrel_hfc_era_peras.md @@ -0,0 +1,36 @@ + + + + + +### Breaking + +- Changes in the HFC types: + - `EraParams` now keeps track of an optional Peras round length. + - `Bound` now keeps track of an optional Peras round number. + - In the `Serialise` instances for `EraParams` and `Bound`, the encoders generate different CBOR depending on whether of not the Peras-relate components are present. The decoders act differently depending on the length of the CBOR list. +- Changes in the HFC time translation queries: + - Two new top-level queries are exposed from `Ouroboros.Consensus.HardFork.History.Qry`: + + ```haskell + perasRoundNoToSlot :: PerasRoundNo -> Qry SlotNo + slotToPerasRoundNo :: SlotNo -> Qry PerasRoundNo + ``` + +- Add a roundtrip test that ensures that converting Peras round number to a slot and then back is an identity is added into the `Test.Consensus.HardFork.Summary` module. +- Add a Peras-specific test into `Test.Consensus.HardFork.History` module.