From 2a4378f71d687ee69bb23e8d31e50148ce727a02 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Oct 2025 10:15:53 +0100 Subject: [PATCH 1/7] Introduce O.C.Peras.Params This commits introduces the module: Ouroboros.Consensus.Peras.Params To consolidate all the protocol parameters related to Peras in one place. Until we defined concrete BlockSupportsPeras for the different block types + HFC, all blocks satisfy: type PerasCfg blk = PerasParams 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 --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Consensus/Block/SupportsPeras.hs | 62 ++------- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 7 +- .../Ouroboros/Consensus/Peras/Params.hs | 119 ++++++++++++++++++ .../ObjectDiffusion/PerasCert/Smoke.hs | 6 +- .../Storage/PerasCertDB/StateMachine.hs | 4 +- 6 files changed, 136 insertions(+), 63 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index a0d3a83786..2565f9120d 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -203,6 +203,7 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId + Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 030ab9d7e2..09a764c7c8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -13,31 +13,27 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) - , PerasWeight (..) , BlockSupportsPeras (..) , PerasCert (..) - , PerasCfg (..) , ValidatedPerasCert (..) - , makePerasCfg , HasPerasCert (..) , getPerasCertRound , getPerasCertBoostedBlock , getPerasCertBoost - -- * Ouroboros Peras round length - , PerasRoundLength (..) - , defaultPerasRoundLength + -- * Convenience re-exports + , module Ouroboros.Consensus.Peras.Params ) 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.Peras.Params import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Quiet (Quiet (..)) @@ -53,20 +49,6 @@ instance Condense PerasRoundNo where 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) @@ -76,27 +58,16 @@ data ValidatedPerasCert blk = ValidatedPerasCert deriving anyclass NoThunks {------------------------------------------------------------------------------- - Ouroboros Peras round length +-- * BlockSupportsPeras class -------------------------------------------------------------------------------} -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 + type PerasCfg blk data PerasCert blk @@ -110,13 +81,7 @@ class -- 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) + type PerasCfg blk = PerasParams data PerasCert blk = PerasCert { pcCertRound :: PerasRoundNo @@ -134,11 +99,11 @@ instance StandardHash blk => BlockSupportsPeras blk where -- TODO: perform actual validation against all -- possible 'PerasValidationErr' variants -- see https://github.com/tweag/cardano-peras/issues/120 - validatePerasCert cfg cert = + validatePerasCert params cert = Right ValidatedPerasCert { vpcCert = cert - , vpcCertBoost = perasCfgWeightBoost cfg + , vpcCertBoost = perasWeight params } instance ShowProxy blk => ShowProxy (PerasCert blk) where @@ -155,17 +120,6 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where 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 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 index 26bff506f3..d7f98a87ec 100644 --- 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 @@ -104,11 +104,10 @@ validatePerasCerts :: [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 + let perasParams = mkPerasParams + -- TODO pass down '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 + case traverse (validatePerasCert perasParams) certs of Left validationErr -> throw (PerasCertValidationError validationErr) Right validatedCerts -> return validatedCerts diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs new file mode 100644 index 0000000000..c6af611269 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Peras protocol parameters +module Ouroboros.Consensus.Peras.Params + ( -- * Protocol parameters + PerasIgnoranceRounds (..) + , PerasCooldownRounds (..) + , PerasBlockMinSlots (..) + , PerasCertArrivalThreshold (..) + , PerasRoundLength (..) + , PerasWeight (..) + + -- * Protocol parameters bundle + , PerasParams (..) + , mkPerasParams + ) +where + +import Data.Semigroup (Sum (..)) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Ouroboros.Consensus.Util.Condense (Condense (..)) +import Ouroboros.Consensus.Util.IOLike (NoThunks) +import Quiet (Quiet (..)) + +{------------------------------------------------------------------------------- + Protocol parameters +-------------------------------------------------------------------------------} + +-- | Number of rounds for which to ignore certificates after entering a +-- cooldown period. +newtype PerasIgnoranceRounds + = PerasIgnoranceRounds {unPerasIgnoranceRounds :: Word64} + deriving Show via Quiet PerasIgnoranceRounds + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Minimum number of rounds to wait before voting again after a cooldown +-- period starts. +newtype PerasCooldownRounds + = PerasCooldownRounds {unPerasCooldownRounds :: Word64} + deriving Show via Quiet PerasCooldownRounds + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Minimum age in slots of a block before it can be voted for in order to get +-- a boost. +newtype PerasBlockMinSlots + = PerasBlockMinSlots {unPerasBlockMinSlots :: Word64} + deriving Show via Quiet PerasBlockMinSlots + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Maximum number of slots to wait for after the start of a round to consider +-- a certificate valid for voting. +newtype PerasCertArrivalThreshold + = PerasCertArrivalThreshold {unPerasCertArrivalThreshold :: Word64} + deriving Show via Quiet PerasCertArrivalThreshold + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Length of a Peras round in slots. +newtype PerasRoundLength + = PerasRoundLength {unPerasRoundLength :: Word64} + deriving Show via Quiet PerasRoundLength + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks) + +-- | Weight assigned to a block when boosted by a Peras certificate. +newtype PerasWeight + = PerasWeight {unPerasWeight :: Word64} + deriving Show via Quiet PerasWeight + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +deriving via Sum Word64 instance Semigroup PerasWeight +deriving via Sum Word64 instance Monoid PerasWeight + +{------------------------------------------------------------------------------- + Protocol parameters bundle +-------------------------------------------------------------------------------} + +-- | Peras protocol parameters. +-- +-- These are documented in the section 2.1 of the Peras design report: +-- https://tweag.github.io/cardano-peras/peras-design.pdf#section.2.1 +data PerasParams = PerasParams + { perasIgnoranceRounds :: PerasIgnoranceRounds + , perasCooldownRounds :: PerasCooldownRounds + , perasBlockMinSlots :: PerasBlockMinSlots + , perasCertArrivalThreshold :: PerasCertArrivalThreshold + , perasRoundLength :: PerasRoundLength + , perasWeight :: PerasWeight + } + deriving (Show, Eq, Generic, NoThunks) + +-- | Instantiate default Peras protocol parameters. +-- +-- NOTE: in the future this will depend on a concrete 'BlockConfig'. +mkPerasParams :: PerasParams +mkPerasParams = + PerasParams + { perasIgnoranceRounds = + error "perasIgnoranceRounds: not yet defined" + , perasCooldownRounds = + error "perasCooldownRounds: not yet defined" + , perasBlockMinSlots = + error "perasBlockMinSlots: not yet defined" + , perasCertArrivalThreshold = + error "perasCertArrivalThreshold: not yet defined" + , perasRoundLength = + PerasRoundLength 90 + , perasWeight = + PerasWeight 15 + } 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 index baee97b57d..dd21bcd485 100644 --- 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 @@ -55,7 +55,7 @@ tests = ] perasTestCfg :: PerasCfg TestBlock -perasTestCfg = makePerasCfg Nothing +perasTestCfg = mkPerasParams genPoint :: Gen (Point (TestBlock)) genPoint = @@ -85,14 +85,14 @@ newCertDB :: PerasCfg blk -> [PerasCert blk] -> m (PerasCertDB m blk) -newCertDB perasCfg certs = do +newCertDB perasParams certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do let validatedCert = ValidatedPerasCert { vpcCert = cert - , vpcCertBoost = perasCfgWeightBoost perasCfg + , vpcCertBoost = perasWeight perasParams } result <- PerasCertDB.addCert db validatedCert case result of 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 504949b9ed..f92b5f316d 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 @@ -46,7 +46,7 @@ tests = ] perasTestCfg :: PerasCfg TestBlock -perasTestCfg = makePerasCfg Nothing +perasTestCfg = mkPerasParams prop_qd :: Actions Model -> Property prop_qd actions = QC.monadic f $ property () <$ runActions actions @@ -85,7 +85,7 @@ instance StateModel Model where { pcCertRound = roundNo , pcCertBoostedBlock = boostedBlock } - , vpcCertBoost = perasCfgWeightBoost perasTestCfg + , vpcCertBoost = perasWeight perasTestCfg } -- Generators are heavily skewed toward collisions, to get equivocating certificates From 68ff8a7a0d6d59310689605380c74234b074c622 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Oct 2025 10:05:57 +0100 Subject: [PATCH 2/7] Add onPerasRoundNo helper and Num instance This commit adds a small helper to compute over Peras round numbers. Will be needed later on to implement the Peras voting rules. 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 --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 09a764c7c8..2f287a76ff 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) + , onPerasRoundNo , BlockSupportsPeras (..) , PerasCert (..) , ValidatedPerasCert (..) @@ -28,6 +29,7 @@ module Ouroboros.Consensus.Block.SupportsPeras import Codec.Serialise (Serialise (..)) import Codec.Serialise.Decoding (decodeListLenOf) import Codec.Serialise.Encoding (encodeListLen) +import Data.Coerce (coerce) import Data.Proxy (Proxy (..)) import Data.Word (Word64) import GHC.Generics (Generic) @@ -41,7 +43,7 @@ import Quiet (Quiet (..)) newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving Show via Quiet PerasRoundNo deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Serialise) + deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise) instance Condense PerasRoundNo where condense = show . unPerasRoundNo @@ -49,6 +51,12 @@ instance Condense PerasRoundNo where instance ShowProxy PerasRoundNo where showProxy _ = "PerasRoundNo" +-- | Lift a binary operation on 'Word64' to 'PerasRoundNo' +onPerasRoundNo :: + (Word64 -> Word64 -> Word64) -> + (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) +onPerasRoundNo = coerce + -- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module? data ValidatedPerasCert blk = ValidatedPerasCert { vpcCert :: !(PerasCert blk) From 270531f348d3cd9340bd9eb0428009feb7da0303 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 12:14:51 +0200 Subject: [PATCH 3/7] Tweak HasPerasCertX typeclasses This commit simplifies the interface of the HasPerasCertX typeclasses, removing the StandardHash superclass constraint, and splitting them into several smaller typeclasses. 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 --- .../Consensus/Block/SupportsPeras.hs | 42 +++++++++++-------- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 8 ++-- .../Storage/ChainDB/Impl/ChainSel.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 2 +- .../Consensus/Storage/PerasCertDB/Impl.hs | 2 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 2 +- .../Ouroboros/Storage/PerasCertDB/Model.hs | 3 +- 7 files changed, 34 insertions(+), 27 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 2f287a76ff..2186878ae7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -3,8 +3,8 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -17,10 +17,9 @@ module Ouroboros.Consensus.Block.SupportsPeras , BlockSupportsPeras (..) , PerasCert (..) , ValidatedPerasCert (..) - , HasPerasCert (..) - , getPerasCertRound - , getPerasCertBoostedBlock - , getPerasCertBoost + , HasPerasCertRound (..) + , HasPerasCertBoostedBlock (..) + , HasPerasCertBoost (..) -- * Convenience re-exports , module Ouroboros.Consensus.Peras.Params @@ -128,20 +127,29 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where pcCertBoostedBlock <- decode pure $ PerasCert{pcCertRound, pcCertBoostedBlock} -class StandardHash blk => HasPerasCert cert blk where - getPerasCert :: cert blk -> PerasCert blk +-- | Extract the certificate round from a Peras certificate container +class HasPerasCertRound cert where + getPerasCertRound :: cert -> PerasRoundNo -instance StandardHash blk => HasPerasCert PerasCert blk where - getPerasCert = id +instance HasPerasCertRound (PerasCert blk) where + getPerasCertRound = pcCertRound -instance StandardHash blk => HasPerasCert ValidatedPerasCert blk where - getPerasCert = vpcCert +instance HasPerasCertRound (ValidatedPerasCert blk) where + getPerasCertRound = getPerasCertRound . vpcCert -getPerasCertRound :: HasPerasCert cert blk => cert blk -> PerasRoundNo -getPerasCertRound = pcCertRound . getPerasCert +-- | Extract the boosted block point from a Peras certificate container +class HasPerasCertBoostedBlock cert blk | cert -> blk where + getPerasCertBoostedBlock :: cert -> Point blk -getPerasCertBoostedBlock :: HasPerasCert cert blk => cert blk -> Point blk -getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert +instance HasPerasCertBoostedBlock (PerasCert blk) blk where + getPerasCertBoostedBlock = pcCertBoostedBlock -getPerasCertBoost :: ValidatedPerasCert blk -> PerasWeight -getPerasCertBoost = vpcCertBoost +instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where + getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert + +-- | Extract the certificate boost from a Peras certificate container +class HasPerasCertBoost cert where + getPerasCertBoost :: cert -> PerasWeight + +instance HasPerasCertBoost (ValidatedPerasCert blk) where + getPerasCertBoost = vpcCertBoost 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 index d7f98a87ec..b541c07688 100644 --- 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 @@ -31,7 +31,7 @@ takeAscMap :: Int -> Map k v -> Map k v takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList makePerasCertPoolReaderFromSnapshot :: - (IOLike m, StandardHash blk) => + IOLike m => STM m (PerasCertSnapshot blk) -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromSnapshot getCertSnapshot = @@ -43,7 +43,7 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot = let certsAfterLastKnown = PerasCertDB.getCertsAfter certSnapshot lastKnown let loadCertsAfterLastKnown = - pure (getPerasCert <$> takeAscMap (fromIntegral limit) certsAfterLastKnown) + pure (vpcCert <$> takeAscMap (fromIntegral limit) certsAfterLastKnown) pure $ if Map.null certsAfterLastKnown then Nothing @@ -51,7 +51,7 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot = } makePerasCertPoolReaderFromCertDB :: - (IOLike m, StandardHash blk) => + IOLike m => PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromCertDB perasCertDB = makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) @@ -71,7 +71,7 @@ makePerasCertPoolWriterFromCertDB perasCertDB = } makePerasCertPoolReaderFromChainDB :: - (IOLike m, StandardHash blk) => + IOLike m => ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) 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 5278133580..c24dd56a47 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 @@ -326,7 +326,7 @@ addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertAsync :: forall m blk. - (IOLike m, HasHeader blk) => + IOLike m => ChainDbEnv m blk -> ValidatedPerasCert blk -> m (AddPerasCertPromise m) 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 3336ba527f..5c8c823ca9 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 @@ -606,7 +606,7 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish -- | Add a Peras certificate to the background queue. addPerasCertToQueue :: - (IOLike m, StandardHash blk) => + IOLike m => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> ValidatedPerasCert blk -> 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 index 8b8a33c342..2c4cb26c2a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -221,7 +221,7 @@ implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} = implGarbageCollect :: forall m blk. - (IOLike m, StandardHash blk) => + IOLike m => PerasCertDbEnv m blk -> SlotNo -> m () implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- No need to update the 'Fingerprint' as we only remove certificates that do 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 index dd21bcd485..4c21aca69f 100644 --- 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 @@ -140,7 +140,7 @@ prop_smoke = let rawContent = Map.toAscList $ PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) - pure $ getPerasCert . snd <$> rawContent + pure $ vpcCert . snd <$> rawContent return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) in 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 index 9808ffe21c..156b66d050 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -49,7 +49,6 @@ addCert model@Model{certs} cert | otherwise = model{certs = Set.insert cert certs} hasRoundNo :: - StandardHash blk => Set (ValidatedPerasCert blk) -> ValidatedPerasCert blk -> Bool @@ -65,7 +64,7 @@ getWeightSnapshot Model{certs} = | cert <- Set.toList certs ] -garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk +garbageCollect :: SlotNo -> Model blk -> Model blk garbageCollect slot model@Model{certs} = model{certs = Set.filter keepCert certs} where From eb5226baf8abd1b7d772bc769973e5a50e097227 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 09:21:38 +0200 Subject: [PATCH 4/7] Define WithArrivalTime combinator This commit defines a generic WithArrivalTime combinator to wrap a value with its arrival time (as a Relative time). This is needed by Peras in several places, e.g., to evaluate the voting rules. Notably, we store a raw Relative time instead of a (arguably more apt) SlotNo or PerasRoundNo to defer as much as possible having to deal with the case where making this translation (timestamp -> slot/round) is not possible due to the HFC time translation horizon. Instead, the client will need to perform this translation in a context where such a failure cannot occur or can be more easily dealt with. 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 --- .../Consensus/Block/SupportsPeras.hs | 19 ++++++++++++++ .../BlockchainTime/WallClock/Types.hs | 26 +++++++++++++++++++ 2 files changed, 45 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 2186878ae7..4f5a9ff49c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -34,6 +34,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..)) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense @@ -137,6 +138,12 @@ instance HasPerasCertRound (PerasCert blk) where instance HasPerasCertRound (ValidatedPerasCert blk) where getPerasCertRound = getPerasCertRound . vpcCert +instance + HasPerasCertRound cert => + HasPerasCertRound (WithArrivalTime cert) + where + getPerasCertRound = getPerasCertRound . forgetArrivalTime + -- | Extract the boosted block point from a Peras certificate container class HasPerasCertBoostedBlock cert blk | cert -> blk where getPerasCertBoostedBlock :: cert -> Point blk @@ -147,9 +154,21 @@ instance HasPerasCertBoostedBlock (PerasCert blk) blk where instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert +instance + HasPerasCertBoostedBlock cert blk => + HasPerasCertBoostedBlock (WithArrivalTime cert) blk + where + getPerasCertBoostedBlock = getPerasCertBoostedBlock . forgetArrivalTime + -- | Extract the certificate boost from a Peras certificate container class HasPerasCertBoost cert where getPerasCertBoost :: cert -> PerasWeight instance HasPerasCertBoost (ValidatedPerasCert blk) where getPerasCertBoost = vpcCertBoost + +instance + HasPerasCertBoost cert => + HasPerasCertBoost (WithArrivalTime cert) + where + getPerasCertBoost = getPerasCertBoost . forgetArrivalTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs index 28105dd672..16277ad4ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Types.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} module Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -15,6 +17,10 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types -- * Get current time (as 'RelativeTime') , SystemTime (..) + -- * Attach an arrival time (as 'RelativeTime') to an object + , WithArrivalTime (..) + , addArrivalTime + -- * Slot length , getSlotLength , mkSlotLength @@ -31,6 +37,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Types import Cardano.Slotting.Time import Data.Time.Clock (NominalDiffTime) +import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) addRelTime :: NominalDiffTime -> RelativeTime -> RelativeTime @@ -60,3 +67,22 @@ data SystemTime m = SystemTime -- to reach 'SystemStart'. In tests this does nothing. } deriving NoThunks via OnlyCheckWhnfNamed "SystemTime" (SystemTime m) + +{------------------------------------------------------------------------------- + Attach an arrival time (as RelativeTime) to an object +-------------------------------------------------------------------------------} + +-- | WithArrivalTime +data WithArrivalTime a = WithArrivalTime + { getArrivalTime :: !RelativeTime + -- ^ The time at which the object arrived + , forgetArrivalTime :: !a + -- ^ The object without its arrival time + } + deriving (Show, Eq, Ord, Generic, NoThunks) + +-- | Add an arrival time to an object +addArrivalTime :: Monad m => SystemTime m -> a -> m (WithArrivalTime a) +addArrivalTime systemTime a = do + t <- systemTimeCurrent systemTime + return (WithArrivalTime t a) From 3e511dffbde71e14d21fa4da600f37767523db14 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 12:25:09 +0200 Subject: [PATCH 5/7] Wrap validated Peras certificates with arrival time This commit wraps the existing ValidatedPerasCerts stored in the PerasCertDB with their corresponding arrival time. In addition, it adapts tests to use either a randomly generated arrival time, or (when appropriate) one generated by a monotonically increasing SystemTime. 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 --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 3 +- .../Ouroboros/Consensus/Node.hs | 4 + .../Ouroboros/Consensus/NodeKernel.hs | 1 + .../Test/ThreadNet/Network.hs | 1 + .../ObjectDiffusion/ObjectPool/PerasCert.hs | 51 ++++++-- .../Consensus/Storage/ChainDB/API.hs | 5 +- .../Storage/ChainDB/Impl/ChainSel.hs | 3 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 5 +- .../Consensus/Storage/PerasCertDB/API.hs | 7 +- .../Consensus/Storage/PerasCertDB/Impl.hs | 9 +- .../Test/Util/Orphans/ToExpr.hs | 5 + .../ObjectDiffusion/PerasCert/Smoke.hs | 116 +++++++++++------- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 5 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 37 +++--- .../Test/Ouroboros/Storage/Orphans.hs | 10 ++ .../Ouroboros/Storage/PerasCertDB/Model.hs | 9 +- .../Storage/PerasCertDB/StateMachine.hs | 35 ++++-- 17 files changed, 208 insertions(+), 98 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 294aace61f..3890267c84 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 @@ -263,6 +263,7 @@ mkHandlers , keepAliveRng , miniProtocolParameters , getDiffusionPipeliningSupport + , systemTime } NodeKernel { getChainDB @@ -322,7 +323,7 @@ mkHandlers , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 ) - (makePerasCertPoolWriterFromChainDB $ getChainDB) + (makePerasCertPoolWriterFromChainDB systemTime getChainDB) version controlMessageSTM , hPerasCertDiffusionServer = \version peer -> 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 ac9fb75450..c8f021fd66 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 @@ -578,6 +578,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = cfg rnTraceConsensus btime + systemTime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) historicityCheck chainDB @@ -855,6 +856,7 @@ mkNodeKernelArgs :: TopLevelConfig blk -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockchainTime m -> + SystemTime m -> InFutureCheck.SomeHeaderInFutureCheck m blk -> (m GSM.GsmState -> HistoricityCheck m blk) -> ChainDB m blk -> @@ -874,6 +876,7 @@ mkNodeKernelArgs cfg tracers btime + systemTime chainSyncFutureCheck chainSyncHistoricityCheck chainDB @@ -892,6 +895,7 @@ mkNodeKernelArgs , registry , cfg , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck 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 1c45c68155..5fdeb9dffe 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 @@ -196,6 +196,7 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs , registry :: ResourceRegistry m , cfg :: TopLevelConfig blk , btime :: BlockchainTime m + , systemTime :: SystemTime m , chainDB :: ChainDB m blk , initChainDB :: StorageConfig blk -> InitChainDB m blk -> m () , chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk 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 f5e9dbecbd..234a3fd4c1 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 @@ -1046,6 +1046,7 @@ runThreadNetwork , registry , cfg = pInfoConfig , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck = 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 index b541c07688..0312dd4288 100644 --- 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 @@ -11,10 +11,16 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where +import Control.Monad ((>=>)) import Data.Map (Map) import qualified Data.Map as Map import GHC.Exception (throw) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( SystemTime (..) + , WithArrivalTime (..) + , addArrivalTime + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB @@ -43,7 +49,10 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot = let certsAfterLastKnown = PerasCertDB.getCertsAfter certSnapshot lastKnown let loadCertsAfterLastKnown = - pure (vpcCert <$> takeAscMap (fromIntegral limit) certsAfterLastKnown) + pure $ + fmap + (vpcCert . forgetArrivalTime) + (takeAscMap (fromIntegral limit) certsAfterLastKnown) pure $ if Map.null certsAfterLastKnown then Nothing @@ -58,13 +67,13 @@ makePerasCertPoolReaderFromCertDB perasCertDB = makePerasCertPoolWriterFromCertDB :: (StandardHash blk, IOLike m) => - PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromCertDB perasCertDB = + SystemTime m -> + PerasCertDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromCertDB systemTime perasCertDB = ObjectPoolWriter { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> do - validatePerasCerts certs - >>= mapM_ (PerasCertDB.addCert perasCertDB) + , opwAddObjects = addPerasCerts systemTime (PerasCertDB.addCert perasCertDB) , opwHasObject = do certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB pure $ PerasCertDB.containsCert certSnapshot @@ -78,13 +87,13 @@ makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolWriterFromChainDB :: (StandardHash blk, IOLike m) => - ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromChainDB chainDB = + SystemTime m -> + ChainDB m blk -> + ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromChainDB systemTime chainDB = ObjectPoolWriter { opwObjectId = getPerasCertRound - , opwAddObjects = \certs -> do - validatePerasCerts certs - >>= mapM_ (ChainDB.addPerasCertAsync chainDB) + , opwAddObjects = addPerasCerts systemTime (ChainDB.addPerasCertAsync chainDB) , opwHasObject = do certSnapshot <- ChainDB.getPerasCertSnapshot chainDB pure $ PerasCertDB.containsCert certSnapshot @@ -111,3 +120,23 @@ validatePerasCerts certs = do case traverse (validatePerasCert perasParams) certs of Left validationErr -> throw (PerasCertValidationError validationErr) Right validatedCerts -> return validatedCerts + +-- | Add a list of 'PerasCert's into an object pool. +-- +-- NOTE: we first validate the certificates, throwing an exception if any of +-- them are invalid. We then wrap them with their arrival time, and finally add +-- them to the pool using the provided adder function. +-- +-- The order of the first two operations (i.e., validation and timestamping) are +-- rather arbitrary, and the abstract Peras protocol just assumes it can happen +-- "within" a slot. +addPerasCerts :: + (StandardHash blk, MonadThrow m) => + SystemTime m -> + (WithArrivalTime (ValidatedPerasCert blk) -> m a) -> + [PerasCert blk] -> + m () +addPerasCerts systemTime adder = do + validatePerasCerts + >=> mapM (addArrivalTime systemTime) + >=> mapM_ adder 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 8b89764c2c..99d5d46e1e 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 @@ -81,6 +81,7 @@ import Control.ResourceRegistry import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.HeaderStateHistory ( HeaderStateHistory (..) ) @@ -396,7 +397,7 @@ data ChainDB m blk = ChainDB , getStatistics :: m (Maybe Statistics) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. - , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m) + , addPerasCertAsync :: WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) -- ^ Asynchronously insert a certificate to the DB. If this leads to a fork to -- be weightier than our current selection, this will trigger a fork switch. , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) @@ -537,7 +538,7 @@ newtype AddPerasCertPromise m = AddPerasCertPromise -- impossible). } -addPerasCertSync :: IOLike m => ChainDB m blk -> ValidatedPerasCert blk -> m () +addPerasCertSync :: IOLike m => ChainDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m () addPerasCertSync chainDB cert = waitPerasCertProcessed =<< addPerasCertAsync chainDB cert 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 c24dd56a47..a032a268d6 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 @@ -45,6 +45,7 @@ import qualified Data.Set as Set import Data.Traversable (for) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..)) import qualified Ouroboros.Consensus.Fragment.Diff as Diff @@ -328,7 +329,7 @@ addPerasCertAsync :: forall m blk. IOLike m => ChainDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue 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 5c8c823ca9..71f836f487 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 @@ -94,6 +94,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.Fragment.Diff (ChainDiff) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) @@ -553,7 +554,7 @@ data ChainSelMessage m blk ChainSelAddBlock !(BlockToAdd m blk) | -- | Add a Peras certificate ChainSelAddPerasCert - !(ValidatedPerasCert blk) + !(WithArrivalTime (ValidatedPerasCert blk)) -- | Used for 'AddPerasCertPromise'. !(StrictTMVar m ()) | -- | Reprocess blocks that have been postponed by the LoE. @@ -609,7 +610,7 @@ addPerasCertToQueue :: IOLike m => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do varProcessed <- newEmptyTMVarIO 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 index 873ebe29f9..6d992b4b42 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -17,12 +17,13 @@ import Data.Map (Map) import Data.Word (Word64) import NoThunks.Class import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) 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 + { addCert :: WithArrivalTime (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)) @@ -46,7 +47,9 @@ data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB data PerasCertSnapshot blk = PerasCertSnapshot { containsCert :: PerasRoundNo -> Bool -- ^ Do we have the certificate for this round? - , getCertsAfter :: PerasCertTicketNo -> Map PerasCertTicketNo (ValidatedPerasCert blk) + , getCertsAfter :: + PerasCertTicketNo -> + Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)) -- ^ Get certificates after the given ticket number (excluded). -- The result is a map of ticket numbers to validated certificates. } 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 index 2c4cb26c2a..9c4e7bd261 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -32,6 +32,7 @@ import qualified Data.Set as Set import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.PerasCertDB.API import Ouroboros.Consensus.Util.Args @@ -152,7 +153,7 @@ implAddCert :: , StandardHash blk ) => PerasCertDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt @@ -255,11 +256,13 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- -- INVARIANT: See 'invariantForPerasVolatileCertState'. data PerasVolatileCertState blk = PerasVolatileCertState - { pvcsCerts :: !(Map PerasRoundNo (ValidatedPerasCert blk)) + { pvcsCerts :: !(Map PerasRoundNo (WithArrivalTime (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. - , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk)) + -- + -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))) -- ^ The certificates by 'PerasCertTicketNo'. , pvcsLastTicketNo :: !PerasCertTicketNo -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' 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 e5560f70f8..d00f14ec1b 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 @@ -17,6 +17,7 @@ import qualified Control.Monad.Class.MonadTime.SI as SI import Data.TreeDiff import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime, WithArrivalTime) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -112,6 +113,8 @@ instance , toExpr j ] +instance ToExpr RelativeTime where + toExpr = defaultExprViaShow instance ToExpr ChunkInfo where toExpr = defaultExprViaShow instance ToExpr FsError where @@ -127,6 +130,8 @@ deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (PerasCert blk) deriving anyclass instance ToExpr (HeaderHash blk) => ToExpr (ValidatedPerasCert blk) +deriving anyclass instance ToExpr a => ToExpr (WithArrivalTime a) + {------------------------------------------------------------------------------- si-timers --------------------------------------------------------------------------------} 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 index 4c21aca69f..9513201752 100644 --- 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 @@ -15,6 +15,13 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Consensus.Block.SupportsPeras +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , SystemTime (..) + , WithArrivalTime (..) + , addArrivalTime + , systemTimeCurrent + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert import Ouroboros.Consensus.Storage.PerasCertDB.API @@ -25,6 +32,12 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB import Ouroboros.Consensus.Util.IOLike + ( IOLike + , atomically + , stateTVar + , throwIO + , uncheckedNewTVarM + ) import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo), StandardHash) import Ouroboros.Network.Point (Block (Block), WithOrigin (..)) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec @@ -32,6 +45,7 @@ import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( objectDiffusionInboundPeerPipelined ) import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) +import System.Random (mkStdGen, uniform) import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( ListWithUniqueIds (..) , WithId @@ -80,12 +94,24 @@ genPerasCert = do instance WithId (PerasCert blk) PerasRoundNo where getId = pcCertRound +mockSystemTime :: IOLike m => Int -> m (SystemTime m) +mockSystemTime seed = do + varGen <- uncheckedNewTVarM (mkStdGen seed) + return $ + SystemTime + { systemTimeCurrent = + RelativeTime . realToFrac @Int <$> atomically (stateTVar varGen uniform) + , systemTimeWait = + pure () + } + newCertDB :: (IOLike m, StandardHash blk) => PerasCfg blk -> + SystemTime m -> [PerasCert blk] -> m (PerasCertDB m blk) -newCertDB perasParams certs = do +newCertDB perasParams systemTime certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do @@ -94,7 +120,7 @@ newCertDB perasParams certs = do { vpcCert = cert , vpcCertBoost = perasWeight perasParams } - result <- PerasCertDB.addCert db validatedCert + result <- PerasCertDB.addCert db =<< addArrivalTime systemTime validatedCert case result of AddedPerasCertToDB -> pure () PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB") @@ -106,47 +132,49 @@ prop_smoke :: Property prop_smoke = forAll genProtocolConstants $ \protocolConstants -> forAll (genListWithUniqueIds genPerasCert) $ \(ListWithUniqueIds certs) -> - let - 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 perasTestCfg certs - inboundPool <- newCertDB perasTestCfg [] + forAll arbitrary $ \systemTimeSeed -> + let + 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 + systemTime <- mockSystemTime systemTimeSeed + outboundPool <- newCertDB perasTestCfg systemTime certs + inboundPool <- newCertDB perasTestCfg systemTime [] - let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool - inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool - getAllInboundPoolContent = atomically $ do - snap <- PerasCertDB.getCertSnapshot inboundPool - let rawContent = - Map.toAscList $ - PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) - pure $ vpcCert . snd <$> rawContent + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB systemTime inboundPool + getAllInboundPoolContent = atomically $ do + snap <- PerasCertDB.getCertSnapshot inboundPool + let rawContent = + Map.toAscList $ + PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) + pure $ vpcCert . forgetArrivalTime . snd <$> rawContent - return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) - in - prop_smoke_object_diffusion - protocolConstants - certs - runOutboundPeer - runInboundPeer - mkPoolInterfaces + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) + in + prop_smoke_object_diffusion + protocolConstants + certs + runOutboundPeer + runInboundPeer + mkPoolInterfaces 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 910c7e1130..22cff44b75 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 @@ -104,6 +104,7 @@ import qualified Data.Set as Set import Data.TreeDiff import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract @@ -148,7 +149,7 @@ data Model blk = Model -- ^ The VolatileDB , immutableDbChain :: Chain blk -- ^ The ImmutableDB - , perasCerts :: Map PerasRoundNo (ValidatedPerasCert blk) + , perasCerts :: Map PerasRoundNo (WithArrivalTime (ValidatedPerasCert blk)) , cps :: CPS.ChainProducerState blk , currentLedger :: ExtLedgerState blk EmptyMK , initLedger :: ExtLedgerState blk EmptyMK @@ -445,7 +446,7 @@ addPerasCert :: forall blk. (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) => TopLevelConfig blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> Model blk -> Model blk addPerasCert cfg cert m 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 13d9735c5f..72cd8cfca5 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 @@ -97,11 +97,15 @@ import Data.Proxy import Data.TreeDiff import Data.Typeable import Data.Void (Void) -import Data.Word (Word16) +import Data.Word (Word16, Word64) import GHC.Generics (Generic) import qualified Generics.SOP as SOP import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , WithArrivalTime (..) + ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -190,7 +194,7 @@ data Cmd blk it flr AddBlock blk (Persistent [blk]) | -- | Add a Peras cert for a block, with (possibly) some gap blocks leading to it. -- For more information about gap blocks, refer to 'GenState' below. - AddPerasCert (ValidatedPerasCert blk) (Persistent [blk]) + AddPerasCert (WithArrivalTime (ValidatedPerasCert blk)) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -1147,6 +1151,9 @@ generator loe genBlock m@Model{..} = empty :: Bool empty = null pointsInDB + genRelativeTime :: Gen RelativeTime + genRelativeTime = RelativeTime . fromIntegral <$> arbitrary @Word64 + genRealPoint :: Gen (RealPoint blk) genRealPoint = frequency @@ -1196,19 +1203,19 @@ generator loe genBlock m@Model{..} = ] -- Include the boosted block itself in the persisted seenBlocks let seenBlks = fmap (blk :) gapBlks - - pure $ - AddPerasCert - ( ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk - } - , vpcCertBoost = boost - } - ) - seenBlks + -- Build the certificate + now <- genRelativeTime + let certWithTime = + WithArrivalTime now $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boost + } + pure $ AddPerasCert certWithTime seenBlks genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs index d81a0a7940..cadeff1857 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs @@ -4,6 +4,7 @@ module Test.Ouroboros.Storage.Orphans () where import Data.Maybe (isJust) +import Data.Time.Clock (NominalDiffTime) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.ChainDB.API ( ChainDbError @@ -16,6 +17,8 @@ import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB import Ouroboros.Consensus.Util.CallStack import System.FS.API.Types (FsError, sameFsError) +import Test.QuickCheck.StateModel (HasVariables) +import Test.QuickCheck.StateModel.Variables (HasVariables (..)) {------------------------------------------------------------------------------- PrettyCallStack @@ -66,3 +69,10 @@ deriving instance StandardHash blk => Eq (ImmutableDB.UnexpectedFailure blk) deriving instance StandardHash blk => Eq (ChainDbFailure blk) deriving instance StandardHash blk => Eq (ChainDbError blk) + +{------------------------------------------------------------------------------- + Time +-------------------------------------------------------------------------------} + +instance HasVariables NominalDiffTime where + getAllVariables _ = mempty 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 index 156b66d050..8e48d8b91f 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -19,13 +19,14 @@ import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot ) data Model blk = Model - { certs :: Set (ValidatedPerasCert blk) + { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) , open :: Bool } deriving Generic @@ -43,14 +44,14 @@ closeDB _ = Model{open = False, certs = Set.empty} addCert :: StandardHash blk => - Model blk -> ValidatedPerasCert blk -> Model blk + Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk addCert model@Model{certs} cert | certs `hasRoundNo` cert = model | otherwise = model{certs = Set.insert cert certs} hasRoundNo :: - Set (ValidatedPerasCert blk) -> - ValidatedPerasCert blk -> + Set (WithArrivalTime (ValidatedPerasCert blk)) -> + WithArrivalTime (ValidatedPerasCert blk) -> Bool hasRoundNo certs cert = (getPerasCertRound cert) `Set.member` (Set.map getPerasCertRound certs) 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 f92b5f316d..11f066e532 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 @@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -23,12 +24,19 @@ import Control.Tracer (nullTracer) import Data.Function ((&)) import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set +import Data.Word (Word64) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , WithArrivalTime (..) + ) 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.Orphans () import Ouroboros.Consensus.Util.STM +import Test.Ouroboros.Storage.Orphans () import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model import Test.QuickCheck hiding (Some (..)) import qualified Test.QuickCheck.Monadic as QC @@ -60,7 +68,7 @@ instance StateModel Model where data Action Model a where OpenDB :: Action Model () CloseDB :: Action Model () - AddCert :: ValidatedPerasCert TestBlock -> Action Model AddPerasCertResult + AddCert :: WithArrivalTime (ValidatedPerasCert TestBlock) -> Action Model AddPerasCertResult GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) GarbageCollect :: SlotNo -> Action Model () @@ -74,19 +82,24 @@ instance StateModel Model where ] | otherwise = pure $ Some OpenDB where + genRelativeTime :: Gen RelativeTime + genRelativeTime = RelativeTime . fromIntegral <$> arbitrary @Word64 + genAddCert = do roundNo <- genRoundNo boostedBlock <- genPoint - pure $ - AddCert - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = boostedBlock - } - , vpcCertBoost = perasWeight perasTestCfg - } + now <- genRelativeTime + let certWithTime = + WithArrivalTime now $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = boostedBlock + } + , vpcCertBoost = perasWeight perasTestCfg + } + pure (AddCert certWithTime) -- Generators are heavily skewed toward collisions, to get equivocating certificates -- and certificates boosting the same block From 817d487b686db2c55daf0022ab66cf8834b09ac4 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 3 Nov 2025 10:26:31 +0100 Subject: [PATCH 6/7] Store most recent cert in the PerasCertDB This commit adds a method to the PerasCertDB API to retrieve the latest certificate seen. This is certificate needed to implement the Peras voting and must be kept around even after garbage collection. Because of this, we extend the internal state of the PerasCertDB to store this special certificate on the side, and (potentially) update it after new certificates are added to the database. 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 --- .../Consensus/Storage/PerasCertDB/API.hs | 8 +++++++ .../Consensus/Storage/PerasCertDB/Impl.hs | 24 ++++++++++++++++--- .../Ouroboros/Storage/PerasCertDB/Model.hs | 19 +++++++++++---- .../Storage/PerasCertDB/StateMachine.hs | 12 ++++++++++ 4 files changed, 56 insertions(+), 7 deletions(-) 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 index 6d992b4b42..6ef63864c8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -35,6 +35,14 @@ data PerasCertDB m blk = PerasCertDB -- 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) + , getLatestCertSeen :: STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ Get the certificate with the highest round number that has been added to + -- the db since it has been opened. This certificate is not affected by garbage + -- collection, but it's forgotten when the db is closed. + -- + -- FIXME(peras): having seen a certificate is a precondition to start voting + -- in every round except for the first one (at origin). As a consequence, only + -- caught-up nodes can actively participate in the Peras protocol for now. , garbageCollect :: SlotNo -> m () -- ^ Garbage-collect state older than the given slot number. , closeDB :: m () 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 index 9c4e7bd261..16d59df38c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -79,6 +79,7 @@ openDB args = do { addCert = getEnv1 h implAddCert , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot , getCertSnapshot = getEnvSTM h implGetCertSnapshot + , getLatestCertSeen = getEnvSTM h implGetLatestCertSeen , garbageCollect = getEnv1 h implGarbageCollect , closeDB = implCloseDB h } @@ -170,18 +171,22 @@ implAddCert env cert = do if Map.member roundNo pvcsCerts then pure PerasCertAlreadyInDB else do + let pvcsCerts' = Map.insert roundNo cert pvcsCerts let pvcsLastTicketNo' = succ pvcsLastTicketNo writeTVar pcdbVolatileState $ WithFingerprint PerasVolatileCertState { pvcsCerts = - Map.insert roundNo cert pvcsCerts + 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' + , pvcsLastTicketNo = + pvcsLastTicketNo' + , pvcsLatestCertSeen = + snd <$> Map.lookupMax pvcsCerts' } (succ fp) pure AddedPerasCertToDB @@ -220,6 +225,14 @@ implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} = snd $ Map.split ticketNo pvcsCertsByTicket } +implGetLatestCertSeen :: + IOLike m => + PerasCertDbEnv m blk -> STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) +implGetLatestCertSeen PerasCertDbEnv{pcdbVolatileState} = + readTVar pcdbVolatileState + <&> forgetFingerprint + <&> pvcsLatestCertSeen + implGarbageCollect :: forall m blk. IOLike m => @@ -236,12 +249,14 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = , pvcsWeightByPoint , pvcsLastTicketNo , pvcsCertsByTicket + , pvcsLatestCertSeen } = PerasVolatileCertState { pvcsCerts = Map.filter keepCert pvcsCerts , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint , pvcsCertsByTicket = Map.filter keepCert pvcsCertsByTicket , pvcsLastTicketNo = pvcsLastTicketNo + , pvcsLatestCertSeen = pvcsLatestCertSeen } where keepCert cert = @@ -267,6 +282,9 @@ data PerasVolatileCertState blk = PerasVolatileCertState , pvcsLastTicketNo :: !PerasCertTicketNo -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' -- otherwise). + , pvcsLatestCertSeen :: !(Maybe (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ The certificate with the highest round number that has been added to the + -- db since it has been opened. } deriving stock (Show, Generic) deriving anyclass NoThunks @@ -279,6 +297,7 @@ initialPerasVolatileCertState = , pvcsWeightByPoint = emptyPerasWeightSnapshot , pvcsCertsByTicket = Map.empty , pvcsLastTicketNo = zeroPerasCertTicketNo + , pvcsLatestCertSeen = Nothing } (Fingerprint 0) @@ -303,7 +322,6 @@ invariantForPerasVolatileCertState pvcs = do <> " > " <> show pvcsLastTicketNo where - PerasVolatileCertState _ _ _ _keep = forgetFingerprint pvcs PerasVolatileCertState { pvcsCerts , pvcsWeightByPoint 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 index 8e48d8b91f..a455d4ac27 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -11,6 +11,7 @@ module Test.Ouroboros.Storage.PerasCertDB.Model , closeDB , addCert , getWeightSnapshot + , getLatestCertSeen , garbageCollect , hasRoundNo ) where @@ -19,14 +20,16 @@ import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime, forgetArrivalTime) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot ) +import Ouroboros.Consensus.Util (safeMaximumOn) data Model blk = Model { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) + , latestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk)) , open :: Bool } deriving Generic @@ -34,20 +37,23 @@ data Model blk = Model deriving instance StandardHash blk => Show (Model blk) initModel :: Model blk -initModel = Model{open = False, certs = Set.empty} +initModel = Model{open = False, certs = Set.empty, latestCertSeen = Nothing} openDB :: Model blk -> Model blk openDB model = model{open = True} closeDB :: Model blk -> Model blk -closeDB _ = Model{open = False, certs = Set.empty} +closeDB _ = Model{open = False, certs = Set.empty, latestCertSeen = Nothing} addCert :: StandardHash blk => Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk addCert model@Model{certs} cert | certs `hasRoundNo` cert = model - | otherwise = model{certs = Set.insert cert certs} + | otherwise = model{certs = certs', latestCertSeen = safeMaximumOn roundNo (Set.toList certs')} + where + certs' = Set.insert cert certs + roundNo = getPerasCertRound . forgetArrivalTime hasRoundNo :: Set (WithArrivalTime (ValidatedPerasCert blk)) -> @@ -65,6 +71,11 @@ getWeightSnapshot Model{certs} = | cert <- Set.toList certs ] +getLatestCertSeen :: + Model blk -> Maybe (WithArrivalTime (ValidatedPerasCert blk)) +getLatestCertSeen Model{latestCertSeen} = + latestCertSeen + garbageCollect :: SlotNo -> Model blk -> Model blk garbageCollect slot model@Model{certs} = model{certs = Set.filter keepCert certs} 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 11f066e532..160b722bf4 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 @@ -70,6 +70,7 @@ instance StateModel Model where CloseDB :: Action Model () AddCert :: WithArrivalTime (ValidatedPerasCert TestBlock) -> Action Model AddPerasCertResult GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) + GetLatestCertSeen :: Action Model (Maybe (WithArrivalTime (ValidatedPerasCert TestBlock))) GarbageCollect :: SlotNo -> Action Model () arbitraryAction _ (Model model) @@ -78,6 +79,7 @@ instance StateModel Model where [ (1, pure $ Some CloseDB) , (20, Some <$> genAddCert) , (20, pure $ Some GetWeightSnapshot) + , (10, pure $ Some GetLatestCertSeen) , (5, Some . GarbageCollect . SlotNo <$> arbitrary) ] | otherwise = pure $ Some OpenDB @@ -125,6 +127,7 @@ instance StateModel Model where CloseDB -> Model.closeDB model AddCert cert -> Model.addCert model cert GetWeightSnapshot -> model + GetLatestCertSeen -> model GarbageCollect slot -> Model.garbageCollect slot model precondition (Model model) = \case @@ -140,6 +143,7 @@ instance StateModel Model where where p cert' = getPerasCertRound cert /= getPerasCertRound cert' || cert == cert' GetWeightSnapshot -> True + GetLatestCertSeen -> True GarbageCollect _slot -> True deriving stock instance Show (Action Model a) @@ -162,6 +166,9 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where GetWeightSnapshot -> do perasCertDB <- get lift $ atomically $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB + GetLatestCertSeen -> do + perasCertDB <- get + lift $ atomically $ PerasCertDB.getLatestCertSeen perasCertDB GarbageCollect slot -> do perasCertDB <- get lift $ PerasCertDB.garbageCollect perasCertDB slot @@ -177,6 +184,11 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where counterexamplePost $ "Model: " <> show expected counterexamplePost $ "SUT: " <> show actual pure $ expected == actual + postcondition (Model model, _) GetLatestCertSeen _ actual = do + let expected = Model.getLatestCertSeen model + counterexamplePost $ "Model: " <> show expected + counterexamplePost $ "SUT: " <> show actual + pure $ expected == actual postcondition _ _ _ _ = pure True monitoring (Model model, _) (AddCert cert) _ _ prop = From 29574266030a1f4dd77a5027ef62fd36d77f77bc Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 1 Dec 2025 13:10:31 +0100 Subject: [PATCH 7/7] Add changelog entries 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 --- ...629_agustin.mista_new_defs_and_plumbing.md | 25 ++++++++++++++++++ ...034_agustin.mista_new_defs_and_plumbing.md | 26 +++++++++++++++++++ 2 files changed, 51 insertions(+) create mode 100644 ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md create mode 100644 ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md diff --git a/ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md b/ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md new file mode 100644 index 0000000000..8848bf832e --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md @@ -0,0 +1,25 @@ + + + + +### Non-Breaking + +- Add plumbing to provide a SystemTime to the PerasCertDB in ordert to record + certificate arrival times. + + diff --git a/ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md b/ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md new file mode 100644 index 0000000000..9a2276a8dc --- /dev/null +++ b/ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md @@ -0,0 +1,26 @@ + + + +### Non-Breaking + +- Introduce `Ouroboros.Consensus.Peras.Params` module. +- Introduce `WithArrivalTime` combinator. +- Refactor `HasPerasCertX` field projection typeclasses. +- Add `getLatestCertSeen` method to the PerasCertDB API. + +