From 2f9b26da4aaf13423928ce5c8c3c16769de5b60a Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 3 Jul 2025 15:58:10 +0200 Subject: [PATCH 01/68] Scaffolding for Peras certs and PerasCertDB --- ouroboros-consensus/ouroboros-consensus.cabal | 4 + .../Ouroboros/Consensus/Block.hs | 1 + .../Consensus/Block/SupportsPeras.hs | 57 +++++ .../Consensus/Storage/ChainDB/Impl.hs | 11 +- .../Consensus/Storage/ChainDB/Impl/Args.hs | 9 + .../Consensus/Storage/ChainDB/Impl/Types.hs | 4 + .../Consensus/Storage/PerasCertDB.hs | 4 + .../Consensus/Storage/PerasCertDB/API.hs | 52 +++++ .../Consensus/Storage/PerasCertDB/Impl.hs | 201 ++++++++++++++++++ .../Test/Util/ChainDB.hs | 5 + .../Ouroboros/Storage/ChainDB/StateMachine.hs | 4 + 11 files changed, 351 insertions(+), 1 deletion(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs 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 1c93bb8f26..47cb97188f 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 @@ -262,6 +263,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/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..70d547c913 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.Block.SupportsPeras + ( PerasRoundNo (..) + , PerasWeight (..) + , boostPerCert + , BlockSupportsPeras (..) + ) where + +import Data.Monoid (Sum (..)) +import Data.Word (Word64) +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block.Abstract + +newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} + deriving stock Show + deriving newtype (Eq, Ord, NoThunks) + +newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} + deriving stock Show + deriving newtype (Eq, Ord, NoThunks) + deriving (Semigroup, Monoid) via Sum Word64 + +-- | TODO this will become a Ledger protocol parameter +boostPerCert :: PerasWeight +boostPerCert = PerasWeight 15 + +class + NoThunks (PerasCert blk) => + BlockSupportsPeras blk + where + data PerasCert blk + + perasCertRound :: PerasCert blk -> PerasRoundNo + + perasCertBoostedBlock :: PerasCert blk -> Point blk + +-- TODO degenerate instance for all blks to get things to compile +instance StandardHash blk => BlockSupportsPeras blk where + data PerasCert blk = PerasCert + { pcCertRound :: PerasRoundNo + , pcCertBoostedBlock :: Point blk + } + deriving stock Generic + deriving anyclass NoThunks + + perasCertRound = pcCertRound + perasCertBoostedBlock = pcCertBoostedBlock 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..c0b0785d02 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 @@ -79,6 +79,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 @@ -173,6 +174,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 @@ -250,6 +253,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , cdbChainSelQueue = chainSelQueue , cdbLoE = Args.cdbsLoE cdbSpecificArgs , cdbChainSelStarvation = varChainSelStarvation + , cdbPerasCertDB = perasCertDB } setGetCurrentChainForLedgerDB $ Query.getCurrentChain env @@ -310,7 +314,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/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 30193ba314..2940f6b32d 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 @@ -124,6 +124,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 @@ -349,6 +351,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 @@ -717,6 +720,7 @@ data TraceEvent blk | TraceLedgerDBEvent (LedgerDB.TraceEvent blk) | TraceImmutableDBEvent (ImmutableDB.TraceEvent blk) | TraceVolatileDBEvent (VolatileDB.TraceEvent blk) + | TracePerasCertDbEvent (PerasCertDB.TraceEvent blk) | TraceLastShutdownUnclean | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk) deriving Generic 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..92f55946e4 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.Storage.PerasCertDB.API + ( PerasCertDB (..) + , PerasWeightSnapshot (..) + , boostedWeightForPoint + , boostedWeightForFragment + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.AnchoredFragment (AnchoredFragment) +import qualified Ouroboros.Network.AnchoredFragment as AF + +data PerasCertDB m blk = PerasCertDB + { addCert :: PerasCert blk -> m () + , getWeightSnapshot :: STM m (PerasWeightSnapshot blk) + , closeDB :: m () + } + deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk) + +newtype PerasWeightSnapshot blk = PerasWeightSnapshot + { getPerasWeightSnapshot :: Map (Point blk) PerasWeight + } + deriving stock Show + deriving newtype NoThunks + +boostedWeightForPoint :: + forall blk. + StandardHash blk => + PerasWeightSnapshot blk -> Point blk -> PerasWeight +boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt = + Map.findWithDefault mempty pt weightByPoint + +boostedWeightForFragment :: + forall blk. + HasHeader blk => + PerasWeightSnapshot blk -> + AnchoredFragment blk -> + PerasWeight +boostedWeightForFragment weightSnap frag = + -- TODO think about whether this could be done in sublinear complexity + -- probably should write microbenchmarks at some point to see if this is a bottleneck + foldMap + (boostedWeightForPoint weightSnap) + (blockPoint <$> AF.toOldestFirst frag) 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..1369a691eb --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -0,0 +1,201 @@ +{-# 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.Monad (join) +import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Kind (Type) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Storage.PerasCertDB.API +import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Util.CallStack +import Ouroboros.Consensus.Util.IOLike + +{------------------------------------------------------------------------------ + 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 + pcdbRoundNos <- newTVarIO Set.empty + pcdbWeightByPoint <- newTVarIO Map.empty + let env = + PerasCertDbEnv + { pcdbTracer + , pcdbRoundNos + , pcdbWeightByPoint + } + h <- PerasCertDbHandle <$> newTVarIO (PerasCertDbOpen env) + traceWith pcdbTracer OpenedPerasCertDB + pure + PerasCertDB + { addCert = getEnv1 h implAddCert + , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot + , 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)) + , pcdbRoundNos :: !(StrictTVar m (Set PerasRoundNo)) + -- ^ The 'RoundNo's of all certificates currently in the db. + , pcdbWeightByPoint :: !(StrictTVar m (Map (Point blk) PerasWeight)) + -- ^ The weight of boosted blocks w.r.t. the certificates currently in the + -- db. + -- + -- INVARIANT: In sync with 'pcdbRoundNos'. + } + 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: validation +implAddCert :: + ( IOLike m + , StandardHash blk + ) => + PerasCertDbEnv m blk -> + PerasCert blk -> + m () +implAddCert env cert = do + traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt + join $ atomically $ do + roundNos <- readTVar pcdbRoundNos + if Set.member roundNo roundNos + then do + pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt + else do + writeTVar pcdbRoundNos $ Set.insert roundNo roundNos + -- Note that the same block might be boosted by multiple points. + modifyTVar pcdbWeightByPoint $ Map.insertWith (<>) boostedPt boostPerCert + pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt + where + PerasCertDbEnv + { pcdbTracer + , pcdbRoundNos + , pcdbWeightByPoint + } = env + + roundNo = perasCertRound cert + boostedPt = perasCertBoostedBlock cert + +implGetWeightSnapshot :: + IOLike m => + PerasCertDbEnv m blk -> STM m (PerasWeightSnapshot blk) +implGetWeightSnapshot PerasCertDbEnv{pcdbWeightByPoint} = + PerasWeightSnapshot <$> readTVar pcdbWeightByPoint + +{------------------------------------------------------------------------------- + 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 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/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 4e97810d90..693a005e15 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 @@ -1329,6 +1330,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) @@ -1755,6 +1758,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 From d41124bdc847fbabf529ceed4004be5ada27f696 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 7 Jul 2025 17:18:43 +0200 Subject: [PATCH 02/68] [WIP] set structure for model-based testing for PerasCertDB --- ouroboros-consensus/ouroboros-consensus.cabal | 3 + .../Consensus/Block/SupportsPeras.hs | 3 +- .../Consensus/Storage/PerasCertDB/API.hs | 3 + .../storage-test/Test/Ouroboros/Storage.hs | 3 + .../Test/Ouroboros/Storage/PerasCertDB.hs | 17 ++++++ .../Ouroboros/Storage/PerasCertDB/Model.hs | 60 +++++++++++++++++++ .../Storage/PerasCertDB/StateMachine.hs | 29 +++++++++ 7 files changed, 117 insertions(+), 1 deletion(-) 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 47cb97188f..09bc9a2030 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -721,6 +721,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/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 70d547c913..e70914f5c3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -23,6 +23,7 @@ import Ouroboros.Consensus.Block.Abstract newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving stock Show + deriving Generic deriving newtype (Eq, Ord, NoThunks) newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} @@ -50,7 +51,7 @@ instance StandardHash blk => BlockSupportsPeras blk where { pcCertRound :: PerasRoundNo , pcCertBoostedBlock :: Point blk } - deriving stock Generic + deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks perasCertRound = pcCertRound 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 92f55946e4..0f9eb80894 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 @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} module Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertDB (..) @@ -17,6 +18,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF +import GHC.Generics (Generic) data PerasCertDB m blk = PerasCertDB { addCert :: PerasCert blk -> m () @@ -29,6 +31,7 @@ newtype PerasWeightSnapshot blk = PerasWeightSnapshot { getPerasWeightSnapshot :: Map (Point blk) PerasWeight } deriving stock Show + deriving Generic deriving newtype NoThunks boostedWeightForPoint :: diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs index 419d8872a7..c8deb68894 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs @@ -6,6 +6,8 @@ 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.VolatileDB as VolatileDB +import qualified Test.Ouroboros.Storage.PerasCertDB as PerasCertDB + import Test.Tasty (TestTree, testGroup) -- @@ -20,4 +22,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..5cb66374f1 --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Test.Ouroboros.Storage.PerasCertDB.Model + ( PerasCertDBModel, + initPerasCertDBModel, + openDBModel, + closeDBModel, + addCertModel, + getWeightSnapshotModel + ) where +import Ouroboros.Consensus.Block (PerasCert, boostPerCert, perasCertBoostedBlock, StandardHash) +import Data.Set (Set) +import GHC.Generics (Generic) +import Data.Proxy (Proxy) +import qualified Data.Set as Set +import Ouroboros.Consensus.Storage.PerasCertDB.API +import qualified Data.Map as Map +import Data.Vector.Internal.Check (HasCallStack) +import Ouroboros.Consensus.Storage.PerasCertDB.Impl (PerasCertDbError(..)) +import Ouroboros.Consensus.Util.CallStack (prettyCallStack) + +data PerasCertDBModel blk = PerasCertDBModel + { + open :: Bool, + certs :: Set (PerasCert blk) + } deriving Generic + +deriving instance (StandardHash blk) => Show (PerasCertDBModel blk) + +initPerasCertDBModel :: Proxy blk -> PerasCertDBModel blk +initPerasCertDBModel _ = PerasCertDBModel + { open = False + , certs = Set.empty + } + +openDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk +openDBModel model = model { open = True } + +closeDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk +closeDBModel model = model { open = False } + +addCertModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> PerasCert blk -> Either PerasCertDbError (PerasCertDBModel blk) +addCertModel model cert = + if open model + then Right model { certs = Set.insert cert (certs model) } + else Left (ClosedDBError prettyCallStack) + +getWeightSnapshotModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> Either PerasCertDbError (PerasWeightSnapshot blk) +getWeightSnapshotModel model = + if open model + then + Right $ PerasWeightSnapshot { + getPerasWeightSnapshot = Set.fold + (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc) + Map.empty + (certs model) + } + else Left (ClosedDBError prettyCallStack) 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..1f635bec7f --- /dev/null +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -0,0 +1,29 @@ + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where +import Test.Tasty (TestTree) +import Test.Ouroboros.Storage.TestBlock (TestBlock) +import Ouroboros.Consensus.Block.SupportsPeras +import Test.Ouroboros.Storage.PerasCertDB.Model +import Test.QuickCheck.StateModel +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) + +tests :: TestTree +tests = undefined + +type Block = TestBlock +newtype Model = Model (PerasCertDBModel Block) deriving (Show, Generic) + +instance StateModel Model where + data Action Model a where + OpenDB :: Action Model () + CloseDB :: Action Model () + AddCert :: PerasCert Block -> Action Model () + GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block) + + arbitraryAction _ _ = error "arbitraryAction not implemented" + initialState = error "initialState not implemented" From ba2b453b2e706b1e61dcd3a02a87545ca929e965 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 8 Jul 2025 11:21:25 +0200 Subject: [PATCH 03/68] Fix missing instances --- .../Ouroboros/Storage/PerasCertDB/StateMachine.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) 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 1f635bec7f..2712b8698f 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 @@ -11,6 +11,7 @@ import Ouroboros.Consensus.Block.SupportsPeras import Test.Ouroboros.Storage.PerasCertDB.Model import Test.QuickCheck.StateModel import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) +import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDbError) tests :: TestTree tests = undefined @@ -22,8 +23,14 @@ instance StateModel Model where data Action Model a where OpenDB :: Action Model () CloseDB :: Action Model () - AddCert :: PerasCert Block -> Action Model () - GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block) + AddCert :: PerasCert Block -> Action Model (Either PerasCertDbError ()) + GetWeightSnapshot :: Action Model (Either PerasCertDbError (PerasWeightSnapshot Block)) arbitraryAction _ _ = error "arbitraryAction not implemented" initialState = error "initialState not implemented" + +deriving instance Show (Action Model a) + +instance HasVariables (Action Model a) where + getAllVariables _ = mempty + From 616776a2f30f278dfe4333d03d76b205344aa391 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 8 Jul 2025 13:01:39 +0200 Subject: [PATCH 04/68] Pairing --- .../Consensus/Block/SupportsPeras.hs | 1 + .../Consensus/Storage/PerasCertDB/API.hs | 6 +- .../Ouroboros/Storage/PerasCertDB/Model.hs | 104 ++++++++------- .../Storage/PerasCertDB/StateMachine.hs | 122 +++++++++++++++--- 4 files changed, 160 insertions(+), 73 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 e70914f5c3..d55a9cd214 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 , PerasWeight (..) , boostPerCert , BlockSupportsPeras (..) + , PerasCert (..) ) where import Data.Monoid (Sum (..)) 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 0f9eb80894..3d0c610887 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 @@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} module Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertDB (..) @@ -13,12 +13,12 @@ module Ouroboros.Consensus.Storage.PerasCertDB.API 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.Util.IOLike import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF -import GHC.Generics (Generic) data PerasCertDB m blk = PerasCertDB { addCert :: PerasCert blk -> m () @@ -30,7 +30,7 @@ data PerasCertDB m blk = PerasCertDB newtype PerasWeightSnapshot blk = PerasWeightSnapshot { getPerasWeightSnapshot :: Map (Point blk) PerasWeight } - deriving stock Show + deriving stock (Show, Eq) deriving Generic deriving newtype NoThunks 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 5cb66374f1..390ffe36bc 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 @@ -1,60 +1,58 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} + module Test.Ouroboros.Storage.PerasCertDB.Model - ( PerasCertDBModel, - initPerasCertDBModel, - openDBModel, - closeDBModel, - addCertModel, - getWeightSnapshotModel + ( Model (..) + , initModel + , openDB + , closeDB + , addCert + , getWeightSnapshot ) where -import Ouroboros.Consensus.Block (PerasCert, boostPerCert, perasCertBoostedBlock, StandardHash) + +import qualified Data.Map as Map import Data.Set (Set) -import GHC.Generics (Generic) -import Data.Proxy (Proxy) import qualified Data.Set as Set -import Ouroboros.Consensus.Storage.PerasCertDB.API -import qualified Data.Map as Map -import Data.Vector.Internal.Check (HasCallStack) -import Ouroboros.Consensus.Storage.PerasCertDB.Impl (PerasCertDbError(..)) -import Ouroboros.Consensus.Util.CallStack (prettyCallStack) - -data PerasCertDBModel blk = PerasCertDBModel - { - open :: Bool, - certs :: Set (PerasCert blk) - } deriving Generic - -deriving instance (StandardHash blk) => Show (PerasCertDBModel blk) - -initPerasCertDBModel :: Proxy blk -> PerasCertDBModel blk -initPerasCertDBModel _ = PerasCertDBModel - { open = False - , certs = Set.empty - } - -openDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk -openDBModel model = model { open = True } - -closeDBModel :: PerasCertDBModel blk -> PerasCertDBModel blk -closeDBModel model = model { open = False } - -addCertModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> PerasCert blk -> Either PerasCertDbError (PerasCertDBModel blk) -addCertModel model cert = - if open model - then Right model { certs = Set.insert cert (certs model) } - else Left (ClosedDBError prettyCallStack) - -getWeightSnapshotModel :: (HasCallStack, StandardHash blk) => PerasCertDBModel blk -> Either PerasCertDbError (PerasWeightSnapshot blk) -getWeightSnapshotModel model = - if open model - then - Right $ PerasWeightSnapshot { - getPerasWeightSnapshot = Set.fold - (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc) - Map.empty - (certs model) - } - else Left (ClosedDBError prettyCallStack) +import GHC.Generics (Generic) +import Ouroboros.Consensus.Block (PerasCert, StandardHash, boostPerCert, perasCertBoostedBlock) +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot (..)) + +data Model blk = Model + { certs :: Set (PerasCert 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 -> PerasCert blk -> Model blk +addCert model@Model{certs} cert = + model{certs = Set.insert cert certs} + +getWeightSnapshot :: + StandardHash blk => + Model blk -> PerasWeightSnapshot blk +getWeightSnapshot Model{certs} = snap + where + snap = + PerasWeightSnapshot + { getPerasWeightSnapshot = + Set.fold + (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc) + Map.empty + 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 2712b8698f..de815c8ffe 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 @@ -1,36 +1,124 @@ - -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where -import Test.Tasty (TestTree) -import Test.Ouroboros.Storage.TestBlock (TestBlock) -import Ouroboros.Consensus.Block.SupportsPeras -import Test.Ouroboros.Storage.PerasCertDB.Model + +import Control.Monad.State +import Control.Tracer (nullTracer) +import qualified Data.List.NonEmpty as NE +import Ouroboros.Consensus.Block +import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB, PerasWeightSnapshot) +import Ouroboros.Consensus.Util.IOLike +import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model +import Test.QuickCheck hiding (Some (..)) +import qualified Test.QuickCheck.Monadic as QC import Test.QuickCheck.StateModel -import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot) -import Ouroboros.Consensus.Storage.PerasCertDB (PerasCertDbError) +import Test.Tasty +import Test.Tasty.QuickCheck hiding (Some (..)) +import Test.Util.TestBlock (TestBlock, TestHash (..)) +import Test.Util.TestEnv (adjustQuickCheckTests) tests :: TestTree -tests = undefined +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") type Block = TestBlock -newtype Model = Model (PerasCertDBModel Block) deriving (Show, Generic) +newtype Model = Model (Model.Model Block) deriving (Show, Generic) instance StateModel Model where data Action Model a where OpenDB :: Action Model () CloseDB :: Action Model () - AddCert :: PerasCert Block -> Action Model (Either PerasCertDbError ()) - GetWeightSnapshot :: Action Model (Either PerasCertDbError (PerasWeightSnapshot Block)) + AddCert :: PerasCert Block -> Action Model () + GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block) + + arbitraryAction _ (Model model) + | model.open = + frequency + [ (1, pure $ Some CloseDB) + , (20, Some <$> genAddCert) + , (20, pure $ Some GetWeightSnapshot) + ] + | otherwise = pure $ Some OpenDB + where + genAddCert = do + pcCertRound <- PerasRoundNo <$> arbitrary + pcCertBoostedBlock <- arbitrary + pure $ AddCert PerasCert{pcCertRound, pcCertBoostedBlock} + + initialState = Model Model.initModel - arbitraryAction _ _ = error "arbitraryAction not implemented" - initialState = error "initialState not implemented" + nextState (Model model) action _ = Model $ case action of + OpenDB -> Model.openDB model + CloseDB -> Model.closeDB model + AddCert cert -> Model.addCert model cert + GetWeightSnapshot -> model -deriving instance Show (Action Model a) + precondition (Model model) = \case + OpenDB -> not model.open + action -> + model.open && case action of + CloseDB -> True + AddCert cert -> all p model.certs + where + p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert' + GetWeightSnapshot -> 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 $ PerasCertDB.getWeightSnapshot perasCertDB + + -- TODO: check open state consistency + 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 + +-- TODO very ugly +instance Arbitrary (Point TestBlock) where + arbitrary = + oneof + [ return GenesisPoint + , BlockPoint <$> (SlotNo <$> arbitrary) <*> (TestHash . NE.fromList . getNonEmpty <$> arbitrary) + ] From 0b8746e78e46b6592c5d17f07e9dd2a49bf380a4 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 9 Jul 2025 12:48:14 +0200 Subject: [PATCH 05/68] Minor polishing - Avoid orphans - We actually can't check that the open states are consistent directly as we would need to statefully get that info from the SUT. --- .../storage-test/Test/Ouroboros/Storage.hs | 3 +- .../Storage/PerasCertDB/StateMachine.hs | 29 +++++++++---------- 2 files changed, 15 insertions(+), 17 deletions(-) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs index c8deb68894..1153457c70 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs @@ -5,9 +5,8 @@ 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.VolatileDB as VolatileDB import qualified Test.Ouroboros.Storage.PerasCertDB as PerasCertDB - +import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB import Test.Tasty (TestTree, testGroup) -- 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 de815c8ffe..6a9d60d73a 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 @@ -11,7 +11,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Test.Ouroboros.Storage.PerasCertDB.StateMachine (tests) where @@ -44,15 +43,14 @@ prop_qd actions = QC.monadic f $ property () <$ runActions actions f :: StateT (PerasCertDB IO TestBlock) IO Property -> Property f = ioProperty . flip evalStateT (error "unreachable") -type Block = TestBlock -newtype Model = Model (Model.Model Block) deriving (Show, Generic) +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 :: PerasCert Block -> Action Model () - GetWeightSnapshot :: Action Model (PerasWeightSnapshot Block) + AddCert :: PerasCert TestBlock -> Action Model () + GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) arbitraryAction _ (Model model) | model.open = @@ -65,9 +63,18 @@ instance StateModel Model where where genAddCert = do pcCertRound <- PerasRoundNo <$> arbitrary - pcCertBoostedBlock <- arbitrary + pcCertBoostedBlock <- genPoint pure $ AddCert PerasCert{pcCertRound, pcCertBoostedBlock} + 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 @@ -81,6 +88,7 @@ instance StateModel Model where action -> model.open && case action of CloseDB -> True + -- Do not add equivocating certificates. AddCert cert -> all p model.certs where p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert' @@ -107,18 +115,9 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where perasCertDB <- get lift $ atomically $ PerasCertDB.getWeightSnapshot perasCertDB - -- TODO: check open state consistency 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 - --- TODO very ugly -instance Arbitrary (Point TestBlock) where - arbitrary = - oneof - [ return GenesisPoint - , BlockPoint <$> (SlotNo <$> arbitrary) <*> (TestHash . NE.fromList . getNonEmpty <$> arbitrary) - ] From d7afcadf4bd1a127451a3b5ea8cf01ae0045fcd3 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 9 Jul 2025 18:03:46 +0200 Subject: [PATCH 06/68] PerasCertDB: implement garbage collection --- .../Consensus/Storage/PerasCertDB/API.hs | 2 + .../Consensus/Storage/PerasCertDB/Impl.hs | 104 ++++++++++++++---- .../Ouroboros/Storage/PerasCertDB/Model.hs | 9 +- .../Storage/PerasCertDB/StateMachine.hs | 7 ++ 4 files changed, 100 insertions(+), 22 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 3d0c610887..030393dbbc 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 @@ -23,6 +23,8 @@ import qualified Ouroboros.Network.AnchoredFragment as AF data PerasCertDB m blk = PerasCertDB { addCert :: PerasCert blk -> m () , getWeightSnapshot :: STM m (PerasWeightSnapshot blk) + , garbageCollect :: SlotNo -> m () + -- ^ Garbage-collect state older than the given slot number. , closeDB :: m () } deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m 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 1369a691eb..ae35b03f67 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 @@ -23,10 +23,9 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl import Control.Monad (join) import Control.Tracer (Tracer, nullTracer, traceWith) import Data.Kind (Type) +import qualified Data.Map.Merge.Strict as Map import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as Set import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block @@ -58,13 +57,11 @@ openDB :: Complete PerasCertDbArgs m blk -> m (PerasCertDB m blk) openDB args = do - pcdbRoundNos <- newTVarIO Set.empty - pcdbWeightByPoint <- newTVarIO Map.empty + pcdbVolatileState <- newTVarIO initialPerasVolatileCertState let env = PerasCertDbEnv { pcdbTracer - , pcdbRoundNos - , pcdbWeightByPoint + , pcdbVolatileState } h <- PerasCertDbHandle <$> newTVarIO (PerasCertDbOpen env) traceWith pcdbTracer OpenedPerasCertDB @@ -72,6 +69,7 @@ openDB args = do PerasCertDB { addCert = getEnv1 h implAddCert , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot + , garbageCollect = getEnv1 h implGarbageCollect , closeDB = implCloseDB h } where @@ -93,13 +91,8 @@ data PerasCertDbState m blk data PerasCertDbEnv m blk = PerasCertDbEnv { pcdbTracer :: !(Tracer m (TraceEvent blk)) - , pcdbRoundNos :: !(StrictTVar m (Set PerasRoundNo)) + , pcdbVolatileState :: !(StrictTVar m (PerasVolatileCertState blk)) -- ^ The 'RoundNo's of all certificates currently in the db. - , pcdbWeightByPoint :: !(StrictTVar m (Map (Point blk) PerasWeight)) - -- ^ The weight of boosted blocks w.r.t. the certificates currently in the - -- db. - -- - -- INVARIANT: In sync with 'pcdbRoundNos'. } deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDbEnv" (PerasCertDbEnv m blk) @@ -154,20 +147,25 @@ implAddCert :: implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt join $ atomically $ do - roundNos <- readTVar pcdbRoundNos - if Set.member roundNo roundNos + PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} <- readTVar pcdbVolatileState + if Map.member roundNo pvcsCerts then do pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt else do - writeTVar pcdbRoundNos $ Set.insert roundNo roundNos - -- Note that the same block might be boosted by multiple points. - modifyTVar pcdbWeightByPoint $ Map.insertWith (<>) boostedPt boostPerCert + writeTVar + pcdbVolatileState + PerasVolatileCertState + { pvcsCerts = + Map.insert roundNo cert pvcsCerts + , -- Note that the same block might be boosted by multiple points. + pvcsWeightByPoint = + Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint + } pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt where PerasCertDbEnv { pcdbTracer - , pcdbRoundNos - , pcdbWeightByPoint + , pcdbVolatileState } = env roundNo = perasCertRound cert @@ -176,8 +174,72 @@ implAddCert env cert = do implGetWeightSnapshot :: IOLike m => PerasCertDbEnv m blk -> STM m (PerasWeightSnapshot blk) -implGetWeightSnapshot PerasCertDbEnv{pcdbWeightByPoint} = - PerasWeightSnapshot <$> readTVar pcdbWeightByPoint +implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} = + PerasWeightSnapshot . pvcsWeightByPoint <$> readTVar pcdbVolatileState + +implGarbageCollect :: + forall m blk. + (IOLike m, StandardHash blk) => + PerasCertDbEnv m blk -> SlotNo -> m () +implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = + atomically $ modifyTVar pcdbVolatileState gc + where + gc :: PerasVolatileCertState blk -> PerasVolatileCertState blk + gc PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} = + PerasVolatileCertState + { pvcsCerts = certsToKeep + , pvcsWeightByPoint = + Map.merge + -- Do not touch weight of boosted blocks that we do not subtract any + -- weight from. + Map.preserveMissing + -- Irrelevant, the key set of @weightToRemove@ is a subset of the + -- key set of @pvcsWeightByPoint@. + Map.dropMissing + (Map.zipWithMaybeMatched $ \_pt -> subtractWeight) + pvcsWeightByPoint + weightToRemove + } + where + (certsToRemove, certsToKeep) = + Map.partition isTooOld pvcsCerts + isTooOld cert = + pointSlot (perasCertBoostedBlock cert) < NotOrigin slot + weightToRemove = + Map.fromListWith + (<>) + [ (perasCertBoostedBlock cert, boostPerCert) + | cert <- Map.elems certsToRemove + ] + + subtractWeight :: PerasWeight -> PerasWeight -> Maybe PerasWeight + subtractWeight (PerasWeight w1) (PerasWeight w2) + | w1 > w2 = Just $ PerasWeight (w1 - w2) + | otherwise = Nothing + +{------------------------------------------------------------------------------- + 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 (PerasCert blk)) + -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db. + , pvcsWeightByPoint :: !(Map (Point blk) PerasWeight) + -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db. + -- + -- INVARIANT: In sync with 'pvcsCerts'. + } + deriving stock (Show, Generic) + deriving anyclass NoThunks + +initialPerasVolatileCertState :: PerasVolatileCertState blk +initialPerasVolatileCertState = + PerasVolatileCertState + { pvcsCerts = Map.empty + , pvcsWeightByPoint = Map.empty + } {------------------------------------------------------------------------------- Trace types 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 390ffe36bc..6b28875a2b 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,13 +11,14 @@ module Test.Ouroboros.Storage.PerasCertDB.Model , closeDB , addCert , getWeightSnapshot + , garbageCollect ) where import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) -import Ouroboros.Consensus.Block (PerasCert, StandardHash, boostPerCert, perasCertBoostedBlock) +import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot (..)) data Model blk = Model @@ -56,3 +57,9 @@ getWeightSnapshot Model{certs} = snap Map.empty certs } + +garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk +garbageCollect slot model@Model{certs} = + model{certs = Set.filter keepCert certs} + where + keepCert cert = pointSlot (perasCertBoostedBlock 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 index 6a9d60d73a..516883fcba 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 @@ -51,6 +51,7 @@ instance StateModel Model where CloseDB :: Action Model () AddCert :: PerasCert TestBlock -> Action Model () GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) + GarbageCollect :: SlotNo -> Action Model () arbitraryAction _ (Model model) | model.open = @@ -58,6 +59,7 @@ instance StateModel Model where [ (1, pure $ Some CloseDB) , (20, Some <$> genAddCert) , (20, pure $ Some GetWeightSnapshot) + , (5, Some . GarbageCollect . SlotNo <$> arbitrary) ] | otherwise = pure $ Some OpenDB where @@ -82,6 +84,7 @@ instance StateModel Model where 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 @@ -93,6 +96,7 @@ instance StateModel Model where where p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert' GetWeightSnapshot -> True + GarbageCollect _slot -> True deriving stock instance Show (Action Model a) deriving stock instance Eq (Action Model a) @@ -114,6 +118,9 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where GetWeightSnapshot -> do perasCertDB <- get lift $ atomically $ PerasCertDB.getWeightSnapshot perasCertDB + GarbageCollect slot -> do + perasCertDB <- get + lift $ PerasCertDB.garbageCollect perasCertDB slot postcondition (Model model, _) GetWeightSnapshot _ actual = do let expected = Model.getWeightSnapshot model From f32763ac0a7bc592a5845af11a66d9fa32d8a416 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Mon, 7 Jul 2025 11:53:33 +0200 Subject: [PATCH 07/68] Re-add how-to guide for micro-benchmarks --- docs/website/contents/howtos/benchmarks.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 docs/website/contents/howtos/benchmarks.md diff --git a/docs/website/contents/howtos/benchmarks.md b/docs/website/contents/howtos/benchmarks.md new file mode 100644 index 0000000000..48a93d5039 --- /dev/null +++ b/docs/website/contents/howtos/benchmarks.md @@ -0,0 +1,22 @@ +# 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 +``` From 54e41bcf42ccd2f6910b0ffbf606c1fc6b309632 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Mon, 7 Jul 2025 15:09:51 +0200 Subject: [PATCH 08/68] ouroboros-consensus: add Peras chain weight benchmark --- docs/website/contents/howtos/benchmarks.md | 10 ++ .../bench/PerasCertDB-bench/Main.hs | 102 ++++++++++++++++++ ouroboros-consensus/ouroboros-consensus.cabal | 14 +++ 3 files changed, 126 insertions(+) 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 index 48a93d5039..94ce7fc0c7 100644 --- a/docs/website/contents/howtos/benchmarks.md +++ b/docs/website/contents/howtos/benchmarks.md @@ -20,3 +20,13 @@ To aid the refactoring of the ChainSync client, we added a benchmark for it in [ ```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..99e730c5d6 --- /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.Storage.PerasCertDB.API.boostedWeightForFragment' +-- 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 Data.Map.Strict qualified as Map +import Numeric.Natural (Natural) +import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..)) +import Ouroboros.Consensus.Storage.PerasCertDB.API + ( PerasWeightSnapshot (..) + , boostedWeightForFragment + ) +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 benchBoostedWeightForFragment 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 + +benchBoostedWeightForFragment :: + (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark +benchBoostedWeightForFragment (i, (weightSnapshot, fragment)) = + bench ("boostedWeightForFragment of length " <> show i) $ + whnf (boostedWeightForFragment 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 PerasWeightSnapshot{getPerasWeightSnapshot = Map.fromList $ zip pointsToBoost 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 09bc9a2030..d1e705552e 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -834,6 +834,20 @@ 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, + containers, + ouroboros-consensus, + ouroboros-network-api, + tasty-bench, + unstable-consensus-testlib, + test-suite doctest import: common-test main-is: doctest.hs From 5cd4c37fffd4fc76aaf79dfeb304ab13785079c0 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 12:13:24 +0200 Subject: [PATCH 09/68] ChainDB: expose PerasCertDB functionality --- .../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 c0b0785d02..f1db247f96 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 @@ -284,6 +284,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 1d2482158243d710830da76133b647a20e7eba10 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 12:13:45 +0200 Subject: [PATCH 10/68] ChainDB: invoke PerasCertDB GC --- .../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 391f420ac1b77df763636d3762b460368ec4c50d Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 12:55:20 +0200 Subject: [PATCH 11/68] Move `PerasWeightSnapshot` to separate module It makes sense to use this without using an entire PerasCertDB, so decouple these. It might be nice to rename PerasCertDB-bench, but doesn't seem like a priority. --- .../bench/PerasCertDB-bench/Main.hs | 8 ++-- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Peras/Weight.hs | 45 +++++++++++++++++++ .../Consensus/Storage/ChainDB/API.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Query.hs | 2 +- .../Consensus/Storage/PerasCertDB/API.hs | 38 +--------------- .../Consensus/Storage/PerasCertDB/Impl.hs | 1 + .../Ouroboros/Storage/PerasCertDB/Model.hs | 2 +- .../Storage/PerasCertDB/StateMachine.hs | 3 +- 9 files changed, 57 insertions(+), 45 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs index 99e730c5d6..a72c1800c8 100644 --- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs +++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs @@ -1,9 +1,9 @@ {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} --- | This module contains benchmarks for Peras chain weight calculation as implemented by --- the by the 'Ouroboros.Consensus.Storage.PerasCertDB.API.boostedWeightForFragment' --- function. +-- | This module contains benchmarks for Peras chain weight calculation as +-- implemented by the by the +-- 'Ouroboros.Consensus.Peras.Weight.boostedWeightForFragment' 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 @@ -15,7 +15,7 @@ import Data.List (iterate') import Data.Map.Strict qualified as Map import Numeric.Natural (Natural) import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..)) -import Ouroboros.Consensus.Storage.PerasCertDB.API +import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot (..) , boostedWeightForFragment ) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index d1e705552e..afa233302f 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.Weight Ouroboros.Consensus.Protocol.Abstract Ouroboros.Consensus.Protocol.BFT Ouroboros.Consensus.Protocol.LeaderSchedule 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..a6cc93627a --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot (..) + , boostedWeightForPoint + , boostedWeightForFragment + ) where + +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 + +newtype PerasWeightSnapshot blk = PerasWeightSnapshot + { getPerasWeightSnapshot :: Map (Point blk) PerasWeight + } + deriving stock (Show, Eq) + deriving Generic + deriving newtype NoThunks + +boostedWeightForPoint :: + forall blk. + StandardHash blk => + PerasWeightSnapshot blk -> Point blk -> PerasWeight +boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt = + Map.findWithDefault mempty pt weightByPoint + +boostedWeightForFragment :: + forall blk. + HasHeader blk => + PerasWeightSnapshot blk -> + AnchoredFragment blk -> + PerasWeight +boostedWeightForFragment weightSnap frag = + -- TODO think about whether this could be done in sublinear complexity + foldMap + (boostedWeightForPoint weightSnap) + (blockPoint <$> AF.toOldestFirst frag) 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..ea83c72e7b 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 @@ -83,6 +83,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 @@ -90,7 +91,6 @@ 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 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..4e5dc818b0 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 @@ -44,6 +44,7 @@ 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) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( BlockComponent (..) @@ -54,7 +55,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.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (eitherToMaybe) 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 030393dbbc..f82dd751b6 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 @@ -1,24 +1,15 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertDB (..) - , PerasWeightSnapshot (..) - , boostedWeightForPoint - , boostedWeightForFragment ) where -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.Util.IOLike -import Ouroboros.Network.AnchoredFragment (AnchoredFragment) -import qualified Ouroboros.Network.AnchoredFragment as AF data PerasCertDB m blk = PerasCertDB { addCert :: PerasCert blk -> m () @@ -28,30 +19,3 @@ data PerasCertDB m blk = PerasCertDB , closeDB :: m () } deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk) - -newtype PerasWeightSnapshot blk = PerasWeightSnapshot - { getPerasWeightSnapshot :: Map (Point blk) PerasWeight - } - deriving stock (Show, Eq) - deriving Generic - deriving newtype NoThunks - -boostedWeightForPoint :: - forall blk. - StandardHash blk => - PerasWeightSnapshot blk -> Point blk -> PerasWeight -boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt = - Map.findWithDefault mempty pt weightByPoint - -boostedWeightForFragment :: - forall blk. - HasHeader blk => - PerasWeightSnapshot blk -> - AnchoredFragment blk -> - PerasWeight -boostedWeightForFragment weightSnap frag = - -- TODO think about whether this could be done in sublinear complexity - -- probably should write microbenchmarks at some point to see if this is a bottleneck - foldMap - (boostedWeightForPoint weightSnap) - (blockPoint <$> AF.toOldestFirst frag) 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 ae35b03f67..5c76c8fd0a 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 @@ -29,6 +29,7 @@ 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 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 6b28875a2b..63eeb91fdd 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,7 +19,7 @@ import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasWeightSnapshot (..)) +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot (..)) data Model blk = Model { certs :: Set (PerasCert blk) 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 516883fcba..6748f5ea2c 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 @@ -18,8 +18,9 @@ import Control.Monad.State import Control.Tracer (nullTracer) import qualified Data.List.NonEmpty as NE import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB -import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB, PerasWeightSnapshot) +import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB) import Ouroboros.Consensus.Util.IOLike import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model import Test.QuickCheck hiding (Some (..)) From 2797c541ea4656a60d1ed9e169f021d2e71beb5a Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 21 Jul 2025 11:58:09 +0200 Subject: [PATCH 12/68] PerasCertDB.getWeightSnapshot: add `Fingerprint` --- .../Consensus/Storage/ChainDB/API.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Query.hs | 3 +- .../Consensus/Storage/PerasCertDB/API.hs | 10 +++- .../Consensus/Storage/PerasCertDB/Impl.hs | 50 ++++++++++++------- .../Storage/PerasCertDB/StateMachine.hs | 3 +- 5 files changed, 45 insertions(+), 23 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 ea83c72e7b..e76fa7069c 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 @@ -389,7 +389,7 @@ data ChainDB m blk = ChainDB -- in the tables. , addPerasCert :: PerasCert blk -> m () -- ^ TODO - , getPerasWeightSnapshot :: STM m (PerasWeightSnapshot blk) + , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) -- ^ TODO , closeDB :: m () -- ^ Close the ChainDB 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 4e5dc818b0..37838d7c44 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 @@ -265,7 +265,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 {------------------------------------------------------------------------------- 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 f82dd751b6..4f2bb46140 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 @@ -10,10 +10,18 @@ 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 :: PerasCert blk -> m () - , getWeightSnapshot :: STM m (PerasWeightSnapshot blk) + , 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. , 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 5c76c8fd0a..0fdffc85d0 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 @@ -34,6 +34,7 @@ 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 @@ -92,7 +93,7 @@ data PerasCertDbState m blk data PerasCertDbEnv m blk = PerasCertDbEnv { pcdbTracer :: !(Tracer m (TraceEvent blk)) - , pcdbVolatileState :: !(StrictTVar m (PerasVolatileCertState 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) @@ -148,20 +149,27 @@ implAddCert :: implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt join $ atomically $ do - PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} <- readTVar pcdbVolatileState + WithFingerprint + PerasVolatileCertState + { pvcsCerts + , pvcsWeightByPoint + } + fp <- + readTVar pcdbVolatileState if Map.member roundNo pvcsCerts then do pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt else do - writeTVar - pcdbVolatileState - PerasVolatileCertState - { pvcsCerts = - Map.insert roundNo cert pvcsCerts - , -- Note that the same block might be boosted by multiple points. - pvcsWeightByPoint = - Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint - } + writeTVar pcdbVolatileState $ + WithFingerprint + PerasVolatileCertState + { pvcsCerts = + Map.insert roundNo cert pvcsCerts + , -- Note that the same block might be boosted by multiple points. + pvcsWeightByPoint = + Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint + } + (succ fp) pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt where PerasCertDbEnv @@ -174,16 +182,18 @@ implAddCert env cert = do implGetWeightSnapshot :: IOLike m => - PerasCertDbEnv m blk -> STM m (PerasWeightSnapshot blk) + PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} = - PerasWeightSnapshot . pvcsWeightByPoint <$> readTVar pcdbVolatileState + fmap (PerasWeightSnapshot . pvcsWeightByPoint) <$> readTVar pcdbVolatileState implGarbageCollect :: forall m blk. (IOLike m, StandardHash blk) => PerasCertDbEnv m blk -> SlotNo -> m () implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = - atomically $ modifyTVar pcdbVolatileState gc + -- 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} = @@ -235,12 +245,14 @@ data PerasVolatileCertState blk = PerasVolatileCertState deriving stock (Show, Generic) deriving anyclass NoThunks -initialPerasVolatileCertState :: PerasVolatileCertState blk +initialPerasVolatileCertState :: WithFingerprint (PerasVolatileCertState blk) initialPerasVolatileCertState = - PerasVolatileCertState - { pvcsCerts = Map.empty - , pvcsWeightByPoint = Map.empty - } + WithFingerprint + PerasVolatileCertState + { pvcsCerts = Map.empty + , pvcsWeightByPoint = Map.empty + } + (Fingerprint 0) {------------------------------------------------------------------------------- Trace types 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 6748f5ea2c..5a36d8795f 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 @@ -22,6 +22,7 @@ import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.PerasCertDB.API (PerasCertDB) import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.STM import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model import Test.QuickCheck hiding (Some (..)) import qualified Test.QuickCheck.Monadic as QC @@ -118,7 +119,7 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where lift $ PerasCertDB.addCert perasCertDB cert GetWeightSnapshot -> do perasCertDB <- get - lift $ atomically $ PerasCertDB.getWeightSnapshot perasCertDB + lift $ atomically $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB GarbageCollect slot -> do perasCertDB <- get lift $ PerasCertDB.garbageCollect perasCertDB slot From 43d023208401fe4ba2b276fda510492318897c50 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 21 Jul 2025 13:52:30 +0200 Subject: [PATCH 13/68] PerasCertDB.addCert: return whether we added the cert --- .../Ouroboros/Consensus/Storage/ChainDB/Impl.hs | 2 +- .../Ouroboros/Consensus/Storage/PerasCertDB/API.hs | 6 +++++- .../Consensus/Storage/PerasCertDB/Impl.hs | 14 ++++++++------ .../Ouroboros/Storage/PerasCertDB/StateMachine.hs | 11 +++++++++-- 4 files changed, 23 insertions(+), 10 deletions(-) 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 f1db247f96..94575db258 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,7 +285,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , getReadOnlyForkerAtPoint = getEnv2 h Query.getReadOnlyForkerAtPoint , getStatistics = getEnv h Query.getStatistics , addPerasCert = getEnv1 h $ \cdb@CDB{..} cert -> do - PerasCertDB.addCert cdbPerasCertDB cert + _ <- PerasCertDB.addCert cdbPerasCertDB cert -- TODO trigger chain selection in a more efficient way waitChainSelectionPromise =<< ChainSel.triggerChainSelectionAsync cdb , getPerasWeightSnapshot = getEnvSTM h Query.getPerasWeightSnapshot 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 4f2bb46140..18d50c82a7 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 @@ -4,6 +4,7 @@ module Ouroboros.Consensus.Storage.PerasCertDB.API ( PerasCertDB (..) + , AddPerasCertResult (..) ) where import NoThunks.Class @@ -13,7 +14,7 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) data PerasCertDB m blk = PerasCertDB - { addCert :: PerasCert blk -> m () + { addCert :: PerasCert blk -> m AddPerasCertResult , 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 @@ -27,3 +28,6 @@ data PerasCertDB m blk = PerasCertDB , closeDB :: m () } deriving NoThunks via OnlyCheckWhnfNamed "PerasCertDB" (PerasCertDB m blk) + +data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB + deriving stock (Show, Eq) 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 0fdffc85d0..4c455ddfcb 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 @@ -20,7 +20,6 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl , PerasCertDbError (..) ) where -import Control.Monad (join) import Control.Tracer (Tracer, nullTracer, traceWith) import Data.Kind (Type) import qualified Data.Map.Merge.Strict as Map @@ -145,10 +144,10 @@ implAddCert :: ) => PerasCertDbEnv m blk -> PerasCert blk -> - m () + m AddPerasCertResult implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt - join $ atomically $ do + res <- atomically $ do WithFingerprint PerasVolatileCertState { pvcsCerts @@ -157,8 +156,7 @@ implAddCert env cert = do fp <- readTVar pcdbVolatileState if Map.member roundNo pvcsCerts - then do - pure $ traceWith pcdbTracer $ IgnoredCertAlreadyInDB roundNo boostedPt + then pure PerasCertAlreadyInDB else do writeTVar pcdbVolatileState $ WithFingerprint @@ -170,7 +168,11 @@ implAddCert env cert = do Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint } (succ fp) - pure $ traceWith pcdbTracer $ AddedPerasCert roundNo boostedPt + pure AddedPerasCertToDB + traceWith pcdbTracer $ case res of + AddedPerasCertToDB -> AddedPerasCert roundNo boostedPt + PerasCertAlreadyInDB -> IgnoredCertAlreadyInDB roundNo boostedPt + pure res where PerasCertDbEnv { pcdbTracer 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 5a36d8795f..917c96eef6 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 @@ -17,10 +17,11 @@ 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 (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 @@ -51,7 +52,7 @@ instance StateModel Model where data Action Model a where OpenDB :: Action Model () CloseDB :: Action Model () - AddCert :: PerasCert TestBlock -> Action Model () + AddCert :: PerasCert TestBlock -> Action Model AddPerasCertResult GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) GarbageCollect :: SlotNo -> Action Model () @@ -124,6 +125,12 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where 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 From 644cb185a6a9d3751f5b123717e5139c4c427b00 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 23 Jul 2025 23:35:37 +0200 Subject: [PATCH 14/68] Peras: minor tweaks --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 5 ++--- .../Ouroboros/Consensus/Peras/Weight.hs | 9 +++++---- 2 files changed, 7 insertions(+), 7 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 d55a9cd214..5cdd95c992 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -23,12 +23,11 @@ import NoThunks.Class import Ouroboros.Consensus.Block.Abstract newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} - deriving stock Show - deriving Generic + deriving stock (Show, Generic) deriving newtype (Eq, Ord, NoThunks) newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} - deriving stock Show + deriving stock (Show, Generic) deriving newtype (Eq, Ord, NoThunks) deriving (Semigroup, Monoid) via Sum Word64 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 a6cc93627a..1931bd5cea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot (..) @@ -33,13 +34,13 @@ boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt = Map.findWithDefault mempty pt weightByPoint boostedWeightForFragment :: - forall blk. - HasHeader blk => + forall blk h. + (HasHeader blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => PerasWeightSnapshot blk -> - AnchoredFragment blk -> + AnchoredFragment h -> PerasWeight boostedWeightForFragment weightSnap frag = -- TODO think about whether this could be done in sublinear complexity foldMap (boostedWeightForPoint weightSnap) - (blockPoint <$> AF.toOldestFirst frag) + (castPoint . blockPoint <$> AF.toOldestFirst frag) From 52d77419bd3b05b05cb8fd53595e77fcbfbec9e8 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 24 Jul 2025 14:31:31 +0200 Subject: [PATCH 15/68] Make `PerasWeightSnapshot` opaque --- .../bench/PerasCertDB-bench/Main.hs | 6 +-- ouroboros-consensus/ouroboros-consensus.cabal | 1 - .../Ouroboros/Consensus/Peras/Weight.hs | 47 ++++++++++++++++++- .../Consensus/Storage/PerasCertDB/Impl.hs | 38 +++++---------- .../Ouroboros/Storage/PerasCertDB/Model.hs | 19 +++----- 5 files changed, 69 insertions(+), 42 deletions(-) diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs index a72c1800c8..94d0bdd408 100644 --- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs +++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs @@ -12,12 +12,12 @@ module Main (main) where import Data.List (iterate') -import Data.Map.Strict qualified as Map import Numeric.Natural (Natural) import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..)) import Ouroboros.Consensus.Peras.Weight - ( PerasWeightSnapshot (..) + ( PerasWeightSnapshot , boostedWeightForFragment + , mkPerasWeightSnapshot ) import Ouroboros.Network.AnchoredFragment qualified as AF import Test.Ouroboros.Storage.TestBlock (TestBlock (..), TestBody (..), TestHeader (..)) @@ -96,7 +96,7 @@ uniformWeightSnapshot fragment = . AF.toOldestFirst $ fragment weights = repeat (boostWeight benchmarkParams) - in PerasWeightSnapshot{getPerasWeightSnapshot = Map.fromList $ zip pointsToBoost weights} + 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 afa233302f..f0885a688b 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -843,7 +843,6 @@ benchmark PerasCertDB-bench other-modules: build-depends: base, - containers, ouroboros-consensus, ouroboros-network-api, tasty-bench, 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 1931bd5cea..ad53914bc2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -6,11 +6,18 @@ {-# LANGUAGE TypeOperators #-} module Ouroboros.Consensus.Peras.Weight - ( PerasWeightSnapshot (..) + ( -- * 'PerasWeightSnapshot' + PerasWeightSnapshot + , emptyPerasWeightSnapshot + , mkPerasWeightSnapshot + , perasWeightSnapshotToList + , addToPerasWeightSnapshot + , removeFromPerasWeightSnapshot , boostedWeightForPoint , boostedWeightForFragment ) where +import Data.Foldable as Foldable (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import GHC.Generics (Generic) @@ -26,6 +33,44 @@ newtype PerasWeightSnapshot blk = PerasWeightSnapshot deriving Generic deriving newtype NoThunks +emptyPerasWeightSnapshot :: PerasWeightSnapshot blk +emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty + +mkPerasWeightSnapshot :: + StandardHash blk => + [(Point blk, PerasWeight)] -> + PerasWeightSnapshot blk +mkPerasWeightSnapshot = + Foldable.foldl' + (\s (pt, weight) -> addToPerasWeightSnapshot pt weight s) + emptyPerasWeightSnapshot + +perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)] +perasWeightSnapshotToList = Map.toList . getPerasWeightSnapshot + +addToPerasWeightSnapshot :: + StandardHash blk => + Point blk -> + PerasWeight -> + PerasWeightSnapshot blk -> + PerasWeightSnapshot blk +addToPerasWeightSnapshot pt weight = + PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot + +removeFromPerasWeightSnapshot :: + StandardHash blk => + Point blk -> + PerasWeight -> + PerasWeightSnapshot blk -> + PerasWeightSnapshot blk +removeFromPerasWeightSnapshot pt (PerasWeight weight) = + PerasWeightSnapshot . Map.update subtractWeight pt . getPerasWeightSnapshot + where + subtractWeight :: PerasWeight -> Maybe PerasWeight + subtractWeight (PerasWeight w) + | w > weight = Just $ PerasWeight (w - weight) + | otherwise = Nothing + boostedWeightForPoint :: forall blk. StandardHash 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 4c455ddfcb..4471c6bd53 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 @@ -21,8 +21,8 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl ) where import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Foldable as Foldable (foldl') import Data.Kind (Type) -import qualified Data.Map.Merge.Strict as Map import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import GHC.Generics (Generic) @@ -165,7 +165,7 @@ implAddCert env cert = do Map.insert roundNo cert pvcsCerts , -- Note that the same block might be boosted by multiple points. pvcsWeightByPoint = - Map.insertWith (<>) boostedPt boostPerCert pvcsWeightByPoint + addToPerasWeightSnapshot boostedPt boostPerCert pvcsWeightByPoint } (succ fp) pure AddedPerasCertToDB @@ -186,7 +186,7 @@ implGetWeightSnapshot :: IOLike m => PerasCertDbEnv m blk -> STM m (WithFingerprint (PerasWeightSnapshot blk)) implGetWeightSnapshot PerasCertDbEnv{pcdbVolatileState} = - fmap (PerasWeightSnapshot . pvcsWeightByPoint) <$> readTVar pcdbVolatileState + fmap pvcsWeightByPoint <$> readTVar pcdbVolatileState implGarbageCollect :: forall m blk. @@ -202,33 +202,21 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = PerasVolatileCertState { pvcsCerts = certsToKeep , pvcsWeightByPoint = - Map.merge - -- Do not touch weight of boosted blocks that we do not subtract any - -- weight from. - Map.preserveMissing - -- Irrelevant, the key set of @weightToRemove@ is a subset of the - -- key set of @pvcsWeightByPoint@. - Map.dropMissing - (Map.zipWithMaybeMatched $ \_pt -> subtractWeight) + Foldable.foldl' + ( \s cert -> + removeFromPerasWeightSnapshot + (perasCertBoostedBlock cert) + boostPerCert + s + ) pvcsWeightByPoint - weightToRemove + certsToRemove } where (certsToRemove, certsToKeep) = Map.partition isTooOld pvcsCerts isTooOld cert = pointSlot (perasCertBoostedBlock cert) < NotOrigin slot - weightToRemove = - Map.fromListWith - (<>) - [ (perasCertBoostedBlock cert, boostPerCert) - | cert <- Map.elems certsToRemove - ] - - subtractWeight :: PerasWeight -> PerasWeight -> Maybe PerasWeight - subtractWeight (PerasWeight w1) (PerasWeight w2) - | w1 > w2 = Just $ PerasWeight (w1 - w2) - | otherwise = Nothing {------------------------------------------------------------------------------- Implementation-internal types @@ -239,7 +227,7 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = data PerasVolatileCertState blk = PerasVolatileCertState { pvcsCerts :: !(Map PerasRoundNo (PerasCert blk)) -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db. - , pvcsWeightByPoint :: !(Map (Point blk) PerasWeight) + , pvcsWeightByPoint :: !(PerasWeightSnapshot blk) -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db. -- -- INVARIANT: In sync with 'pvcsCerts'. @@ -252,7 +240,7 @@ initialPerasVolatileCertState = WithFingerprint PerasVolatileCertState { pvcsCerts = Map.empty - , pvcsWeightByPoint = Map.empty + , pvcsWeightByPoint = emptyPerasWeightSnapshot } (Fingerprint 0) 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 63eeb91fdd..a1cda0e044 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 @@ -14,12 +14,14 @@ module Test.Ouroboros.Storage.PerasCertDB.Model , garbageCollect ) where -import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot (..)) +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , mkPerasWeightSnapshot + ) data Model blk = Model { certs :: Set (PerasCert blk) @@ -47,16 +49,9 @@ addCert model@Model{certs} cert = getWeightSnapshot :: StandardHash blk => Model blk -> PerasWeightSnapshot blk -getWeightSnapshot Model{certs} = snap - where - snap = - PerasWeightSnapshot - { getPerasWeightSnapshot = - Set.fold - (\cert acc -> Map.insertWith (<>) (perasCertBoostedBlock cert) boostPerCert acc) - Map.empty - certs - } +getWeightSnapshot Model{certs} = + mkPerasWeightSnapshot + [(perasCertBoostedBlock cert, boostPerCert) | cert <- Set.toList certs] garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk garbageCollect slot model@Model{certs} = From 8886d71a290eb2416c60acd1a8c81e156c17d3ad Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 13:36:45 +0200 Subject: [PATCH 16/68] Nomenclature: "weight boost" instead of "boosted weight" --- .../bench/PerasCertDB-bench/Main.hs | 14 +++++++------- .../Ouroboros/Consensus/Peras/Weight.hs | 16 ++++++++-------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs index 94d0bdd408..40642021d4 100644 --- a/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs +++ b/ouroboros-consensus/bench/PerasCertDB-bench/Main.hs @@ -3,7 +3,7 @@ -- | This module contains benchmarks for Peras chain weight calculation as -- implemented by the by the --- 'Ouroboros.Consensus.Peras.Weight.boostedWeightForFragment' function. +-- '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 @@ -16,8 +16,8 @@ import Numeric.Natural (Natural) import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..)) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot - , boostedWeightForFragment , mkPerasWeightSnapshot + , weightBoostOfFragment ) import Ouroboros.Network.AnchoredFragment qualified as AF import Test.Ouroboros.Storage.TestBlock (TestBlock (..), TestBody (..), TestHeader (..)) @@ -49,7 +49,7 @@ benchmarkParams = main :: IO () main = - Test.Tasty.Bench.defaultMain $ map benchBoostedWeightForFragment inputs + 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 @@ -62,11 +62,11 @@ main = zip [0 ..] $ zip (map uniformWeightSnapshot fragments) fragments -benchBoostedWeightForFragment :: +benchWeightBoostOfFragment :: (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark -benchBoostedWeightForFragment (i, (weightSnapshot, fragment)) = - bench ("boostedWeightForFragment of length " <> show i) $ - whnf (boostedWeightForFragment weightSnapshot) fragment +benchWeightBoostOfFragment (i, (weightSnapshot, fragment)) = + bench ("weightBoostOfFragment of length " <> show i) $ + whnf (weightBoostOfFragment weightSnapshot) fragment -- | An infinite list of chain fragments fragments :: [AF.AnchoredFragment TestBlock] 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 ad53914bc2..7895f91ff9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -13,8 +13,8 @@ module Ouroboros.Consensus.Peras.Weight , perasWeightSnapshotToList , addToPerasWeightSnapshot , removeFromPerasWeightSnapshot - , boostedWeightForPoint - , boostedWeightForFragment + , weightBoostOfPoint + , weightBoostOfFragment ) where import Data.Foldable as Foldable (foldl') @@ -71,21 +71,21 @@ removeFromPerasWeightSnapshot pt (PerasWeight weight) = | w > weight = Just $ PerasWeight (w - weight) | otherwise = Nothing -boostedWeightForPoint :: +weightBoostOfPoint :: forall blk. StandardHash blk => PerasWeightSnapshot blk -> Point blk -> PerasWeight -boostedWeightForPoint (PerasWeightSnapshot weightByPoint) pt = +weightBoostOfPoint (PerasWeightSnapshot weightByPoint) pt = Map.findWithDefault mempty pt weightByPoint -boostedWeightForFragment :: +weightBoostOfFragment :: forall blk h. (HasHeader blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight -boostedWeightForFragment weightSnap frag = +weightBoostOfFragment weightSnap frag = -- TODO think about whether this could be done in sublinear complexity foldMap - (boostedWeightForPoint weightSnap) - (castPoint . blockPoint <$> AF.toOldestFirst frag) + (weightBoostOfPoint weightSnap . castPoint . blockPoint) + (AF.toOldestFirst frag) From 91a5cc98042b6e1a3c63059ebc9b7d6f8116cf99 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 13:36:48 +0200 Subject: [PATCH 17/68] Glossary: add Peras weight-related terms --- docs/website/contents/references/glossary.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) 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. From 337558ed74ac2da73fae1fb99c9758b44337f28f Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 13:36:51 +0200 Subject: [PATCH 18/68] PerasWeightSnapshot: minimize API --- .../Ouroboros/Consensus/Peras/Weight.hs | 18 +++++++----------- .../Consensus/Storage/PerasCertDB/Impl.hs | 14 ++------------ 2 files changed, 9 insertions(+), 23 deletions(-) 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 7895f91ff9..2711a779f5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -12,7 +12,7 @@ module Ouroboros.Consensus.Peras.Weight , mkPerasWeightSnapshot , perasWeightSnapshotToList , addToPerasWeightSnapshot - , removeFromPerasWeightSnapshot + , prunePerasWeightSnapshot , weightBoostOfPoint , weightBoostOfFragment ) where @@ -57,19 +57,15 @@ addToPerasWeightSnapshot :: addToPerasWeightSnapshot pt weight = PerasWeightSnapshot . Map.insertWith (<>) pt weight . getPerasWeightSnapshot -removeFromPerasWeightSnapshot :: - StandardHash blk => - Point blk -> - PerasWeight -> +prunePerasWeightSnapshot :: + SlotNo -> PerasWeightSnapshot blk -> PerasWeightSnapshot blk -removeFromPerasWeightSnapshot pt (PerasWeight weight) = - PerasWeightSnapshot . Map.update subtractWeight pt . getPerasWeightSnapshot +prunePerasWeightSnapshot slot = + PerasWeightSnapshot . Map.dropWhileAntitone isTooOld . getPerasWeightSnapshot where - subtractWeight :: PerasWeight -> Maybe PerasWeight - subtractWeight (PerasWeight w) - | w > weight = Just $ PerasWeight (w - weight) - | otherwise = Nothing + isTooOld :: Point blk -> Bool + isTooOld pt = pointSlot pt < NotOrigin slot weightBoostOfPoint :: forall 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 4471c6bd53..6547afa521 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 @@ -21,7 +21,6 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl ) where import Control.Tracer (Tracer, nullTracer, traceWith) -import Data.Foldable as Foldable (foldl') import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -201,19 +200,10 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = gc PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} = PerasVolatileCertState { pvcsCerts = certsToKeep - , pvcsWeightByPoint = - Foldable.foldl' - ( \s cert -> - removeFromPerasWeightSnapshot - (perasCertBoostedBlock cert) - boostPerCert - s - ) - pvcsWeightByPoint - certsToRemove + , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint } where - (certsToRemove, certsToKeep) = + (_, certsToKeep) = Map.partition isTooOld pvcsCerts isTooOld cert = pointSlot (perasCertBoostedBlock cert) < NotOrigin slot From a5456d9829c0a80d6f2cc54e3f0b0f61e0196951 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 13:36:54 +0200 Subject: [PATCH 19/68] PerasRoundNo/PerasWeight: terse output --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 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 5cdd95c992..e2d559d9c3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -21,13 +21,16 @@ import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract +import Quiet (Quiet (..)) newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} - deriving stock (Show, Generic) + deriving Show via Quiet PerasRoundNo + deriving stock Generic deriving newtype (Eq, Ord, NoThunks) newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} - deriving stock (Show, Generic) + deriving Show via Quiet PerasWeight + deriving stock Generic deriving newtype (Eq, Ord, NoThunks) deriving (Semigroup, Monoid) via Sum Word64 From facb6b7eb0b99c2fec6dea7c2ba7a0a4831ead20 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 13:36:57 +0200 Subject: [PATCH 20/68] O.C.Peras.Weight: add haddocks using cabal-docspec (not yet nixified) --- .../Ouroboros/Consensus/Peras/Weight.hs | 167 +++++++++++++++++- 1 file changed, 163 insertions(+), 4 deletions(-) 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 2711a779f5..baa72875a3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -5,14 +5,25 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +-- | Data structure for tracking the weight of blocks due to Peras boosts. module Ouroboros.Consensus.Peras.Weight - ( -- * 'PerasWeightSnapshot' + ( -- * 'PerasWeightSnapshot' type PerasWeightSnapshot + + -- * Construction , emptyPerasWeightSnapshot , mkPerasWeightSnapshot + + -- * Conversion , perasWeightSnapshotToList + + -- * Insertion , addToPerasWeightSnapshot + + -- * Pruning , prunePerasWeightSnapshot + + -- * Query , weightBoostOfPoint , weightBoostOfFragment ) where @@ -26,16 +37,37 @@ 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 (Show, Eq) + 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 +-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] mkPerasWeightSnapshot :: StandardHash blk => [(Point blk, PerasWeight)] -> @@ -45,9 +77,47 @@ mkPerasWeightSnapshot = (\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 +-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)] -perasWeightSnapshotToList = Map.toList . getPerasWeightSnapshot +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 +-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2)] +-- +-- >>> snap1 = addToPerasWeightSnapshot (BlockPoint 3 "bar") (PerasWeight 2) snap0 +-- >>> snap1 +-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- +-- >>> snap2 = addToPerasWeightSnapshot (BlockPoint 2 "foo") (PerasWeight 2) snap1 +-- >>> snap2 +-- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] addToPerasWeightSnapshot :: StandardHash blk => Point blk -> @@ -57,6 +127,29 @@ addToPerasWeightSnapshot :: 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 +-- [(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- +-- >>> prunePerasWeightSnapshot (SlotNo 3) snap +-- [(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] prunePerasWeightSnapshot :: SlotNo -> PerasWeightSnapshot blk -> @@ -67,6 +160,25 @@ prunePerasWeightSnapshot slot = 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 => @@ -74,9 +186,47 @@ weightBoostOfPoint :: 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. - (HasHeader blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => + (StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) => PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight @@ -85,3 +235,12 @@ weightBoostOfFragment weightSnap frag = foldMap (weightBoostOfPoint weightSnap . castPoint . blockPoint) (AF.toOldestFirst frag) + +-- $setup +-- >>> import Ouroboros.Consensus.Block +-- >>> import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq(..), Anchor(..)) +-- >>> import qualified Ouroboros.Network.AnchoredFragment as AF +-- >>> :set -XTypeFamilies +-- >>> data Blk = Blk +-- >>> type instance HeaderHash Blk = String +-- >>> instance StandardHash Blk From bdb618943688c5b265d7b48fb17e54894470ccbc Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 18:37:18 +0200 Subject: [PATCH 21/68] `SecurityParam`: mention weighted nature --- .../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 d8cbdebcb49b0face1518002777fa59085ecca15 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 29 Jul 2025 19:47:10 +0200 Subject: [PATCH 22/68] `PerasRoundNo`/`PerasWeight`: add `Condense` instances This is purely for concise QuickCheck counterexample output. --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 7 +++++++ 1 file changed, 7 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 e2d559d9c3..7709e759cf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -21,6 +21,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract +import Ouroboros.Consensus.Util.Condense import Quiet (Quiet (..)) newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} @@ -28,12 +29,18 @@ newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving stock Generic deriving newtype (Eq, Ord, NoThunks) +instance Condense PerasRoundNo where + condense = show . unPerasRoundNo + 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 boostPerCert :: PerasWeight boostPerCert = PerasWeight 15 From 2323685aa5056a7d05138b58e9b6b149c8eb9080 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 15:15:35 +0200 Subject: [PATCH 23/68] O.C.Peras.Weight: add `totalWeightForFragment`/`takeVolatileSuffix` --- .../Ouroboros/Consensus/Peras/Weight.hs | 135 +++++++++++++++++- 1 file changed, 134 insertions(+), 1 deletion(-) 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 baa72875a3..fed6d63844 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -26,14 +26,18 @@ module Ouroboros.Consensus.Peras.Weight -- * Query , 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 @@ -236,11 +240,140 @@ weightBoostOfFragment weightSnap frag = (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 + +-- | 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 -XTypeFamilies +-- >>> :set -XDataKinds -XTypeApplications -XTypeFamilies -- >>> data Blk = Blk -- >>> type instance HeaderHash Blk = String -- >>> instance StandardHash Blk From cb0877b9599cecfd1ea135051aca74aecb2aa006 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 29 Jul 2025 19:49:32 +0200 Subject: [PATCH 24/68] Add test for `PerasWeightSnapshot` --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../test/consensus-test/Main.hs | 2 + .../Test/Consensus/Peras/WeightSnapshot.hs | 176 ++++++++++++++++++ 3 files changed, 179 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 f0885a688b..8ed51171a5 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -601,6 +601,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..59fd52d636 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs @@ -0,0 +1,176 @@ +{-# 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 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) +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 + ] + , 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 + + weightBoostOfPointReference :: Point TestBlock -> PerasWeight + weightBoostOfPointReference pt = Map.findWithDefault mempty pt tsWeights + + weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight + weightBoostOfFragmentReference frag = + foldMap + (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 + +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 + tsSecParam <- arbitrary + pure + TestSetup + { tsWeights + , tsPoints + , tsFragments + , tsSecParam + } + + 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 + ] + , [ ts{tsSecParam = tsSecParam'} + | tsSecParam' <- shrink tsSecParam + ] + ] + where + w1 = PerasWeight 1 + + TestSetup + { tsWeights + , tsPoints + , tsFragments + , tsSecParam + } = ts From fe3c154345c26a6dec68f2b77953433a57a5cd6c Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 30 Jul 2025 18:33:51 +0200 Subject: [PATCH 25/68] ChainDB.StateMachine: check immutable tip monotonicity --- .../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 693a005e15..678ed36ab3 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 @@ -1233,16 +1233,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 => @@ -1272,7 +1289,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 e6aa0aed3a69771be7f98ee5137d87c869c79627 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 15:30:09 +0200 Subject: [PATCH 26/68] ChainDB: define `getCurrentChain` in terms of weight --- .../Consensus/Storage/ChainDB/Impl/Query.hs | 36 ++++++++++++++----- 1 file changed, 27 insertions(+), 9 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 37838d7c44..ac6fc0be81 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,7 +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) +import Ouroboros.Consensus.Peras.Weight + ( PerasWeightSnapshot + , takeVolatileSuffix + ) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API ( BlockComponent (..) @@ -86,29 +89,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 d9a542fcff51a54626954259ad36ebadb2e83e99 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 14:36:47 +0200 Subject: [PATCH 27/68] GSM: allow `candidateOverSelection` to be stateful This is in preparation for weighted chain comparisons. --- .../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 b9c53da498..d56dbf42c5 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 c5759cd9c2943925bcde068c8772eb65935bf324 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 28 Jul 2025 15:32:15 +0200 Subject: [PATCH 28/68] Add `WeightedSelectView` --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Peras/SelectView.hs | 137 ++++++++++++++++++ 2 files changed, 138 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 8ed51171a5..4902267c6d 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/Peras/SelectView.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs new file mode 100644 index 0000000000..9e125ee7dd --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# 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 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 + { wsvBlockNo :: !BlockNo + -- ^ The 'BlockNo' at the tip of a fragment. + , 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 'wsvBlockNo' and 'wsvBoostedWeight'. +wsvTotalWeight :: WeightedSelectView proto -> PerasWeight +-- could be cached, but then we need to be careful to maintain the invariant +wsvTotalWeight wsv = + PerasWeight (unBlockNo (wsvBlockNo 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 + { wsvBlockNo = blockNo hdr + , 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 From 37f9ae9d2b1d5f5663a5f40e5d7f8f543aa3e0e0 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 23 Jul 2025 19:26:54 +0200 Subject: [PATCH 29/68] ChainSel: make `rollbackExceedsSuffix` weight-aware Also remove the version for `ValidatedChainDiff` as it is unused. --- .../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 0912d45034a01cf846fe3d59271fbf568b8df578 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 17 Jul 2025 14:49:11 +0200 Subject: [PATCH 30/68] Introduce weighted chain comparisons --- .../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 d56dbf42c5..d7c460ba11 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 94575db258..36be9d59cd 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 @@ -182,6 +182,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 @@ -193,6 +194,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 2940f6b32d..9972957a12 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 (..) @@ -801,21 +802,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 7cd188cd32539d2f4fba37bd3d82f2e3d3133fd5 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 21 Jul 2025 11:58:14 +0200 Subject: [PATCH 31/68] Integrate weighted BlockFetch decision logic --- cabal.project | 9 ++++++ .../BlockFetch/ClientInterface.hs | 32 ++++++++++++------- .../Ouroboros/Consensus/Util/STM.hs | 24 +++----------- .../MiniProtocol/BlockFetch/Client.hs | 1 + 4 files changed, 35 insertions(+), 31 deletions(-) diff --git a/cabal.project b/cabal.project index 2162410163..9d63fd9fd4 100644 --- a/cabal.project +++ b/cabal.project @@ -56,6 +56,15 @@ allow-newer: , 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 + source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger 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 9130e3bee1..86687227c7 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 #-} @@ -36,10 +32,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 @@ -83,20 +81,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 From 4037e12ef44c1e3425289c7760366a4e7092aefa Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 21 Jul 2025 11:58:18 +0200 Subject: [PATCH 32/68] ChainDB: implement chain selection for certificates --- .../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 e76fa7069c..91b13c2502 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 (WithFingerprint (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 36be9d59cd..037f1189ed 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 (..) @@ -286,10 +287,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 9972957a12..de48f12b56 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 @@ -549,6 +551,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'. @@ -597,6 +604,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 => @@ -651,23 +680,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 @@ -680,6 +707,8 @@ processedChainSelMessage :: processedChainSelMessage ChainSelQueue{varChainSelPoints} = \case ChainSelAddBlock BlockToAdd{blockToAdd = blk} -> modifyTVar varChainSelPoints $ MultiSet.delete (blockRealPoint blk) + ChainSelAddPerasCert{} -> + pure () ChainSelReprocessLoEBlocks{} -> pure () @@ -724,6 +753,7 @@ data TraceEvent blk | TracePerasCertDbEvent (PerasCertDB.TraceEvent blk) | TraceLastShutdownUnclean | TraceChainSelStarvationEvent (TraceChainSelStarvationEvent blk) + | TraceAddPerasCertEvent (TraceAddPerasCertEvent blk) deriving Generic deriving instance @@ -1034,3 +1064,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 678ed36ab3..ab48e35597 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 @@ -1351,6 +1351,8 @@ 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) +deriving anyclass instance SOP.HasDatatypeInfo (TraceAddPerasCertEvent blk) data Tag = TagGetIsValidJust @@ -1778,6 +1780,7 @@ traceEventName = \case TracePerasCertDbEvent ev -> "PerasCertDB." <> constrName ev TraceLastShutdownUnclean -> "LastShutdownUnclean" TraceChainSelStarvationEvent ev -> "ChainSelStarvation." <> constrName ev + TraceAddPerasCertEvent ev -> "AddPerasCert." <> constrName ev mkArgs :: IOLike m => From 8192a51f9d53e4fe606d4bd34e4ba0f0b5004788 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 24 Jul 2025 14:39:00 +0200 Subject: [PATCH 33/68] MockChainSel: switch to weighted chain selection --- .../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 5b618694c5d75340e606ea89e325e1bda59c4312 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 24 Jul 2025 15:52:56 +0200 Subject: [PATCH 34/68] ChainDB q-s-m: test weighted chain selection --- .../Consensus/Util/AnchoredFragment.hs | 37 ++++-- .../Test/Util/Orphans/ToExpr.hs | 6 + .../Test/Ouroboros/Storage/ChainDB/Model.hs | 121 ++++++++++++------ .../Ouroboros/Storage/ChainDB/Model/Test.hs | 5 +- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 41 +++++- 5 files changed, 155 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/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index 6830141290..f883c7abdd 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,12 @@ 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) + {------------------------------------------------------------------------------- si-timers --------------------------------------------------------------------------------} 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 ab48e35597..b739d99526 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 @@ -179,6 +179,7 @@ import Test.Util.WithEq -- | Commands data Cmd blk it flr = AddBlock blk + | AddPerasCert (PerasCert blk) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -403,8 +404,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 @@ -639,6 +641,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) @@ -910,6 +913,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) @@ -1035,6 +1043,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 @@ -1359,6 +1381,7 @@ data Tag | TagGetIsValidNothing | TagChainSelReprocessChangedSelection | TagChainSelReprocessKeptSelection + | TagSwitchedToShorterChain deriving (Show, Eq) -- | Predicate on events @@ -1385,6 +1408,7 @@ tag = , tagGetIsValidNothing , tagChainSelReprocess TagChainSelReprocessChangedSelection (/=) , tagChainSelReprocess TagChainSelReprocessKeptSelection (==) + , tagSwitchedToShorterChain ] where tagGetIsValidJust :: EventPred m @@ -1409,6 +1433,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 6739048cc2b77f0a83c28674e6976196b50324eb Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 13 Aug 2025 18:53:09 +0200 Subject: [PATCH 35/68] Fix cabal-docspec --- .../Ouroboros/Consensus/Peras/Weight.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) 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 fed6d63844..783c3b6a04 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs @@ -71,7 +71,7 @@ emptyPerasWeightSnapshot = PerasWeightSnapshot Map.empty -- -- >>> snap = mkPerasWeightSnapshot weights -- >>> snap --- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- [(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)] -> @@ -96,7 +96,7 @@ mkPerasWeightSnapshot = -- -- >>> snap = mkPerasWeightSnapshot weights -- >>> perasWeightSnapshotToList snap --- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- [(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 @@ -113,15 +113,15 @@ perasWeightSnapshotToList = Map.toAscList . getPerasWeightSnapshot -- -- >>> snap0 = mkPerasWeightSnapshot weights -- >>> snap0 --- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2)] +-- [(Point Origin,PerasWeight 3),(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 2)] -- -- >>> snap1 = addToPerasWeightSnapshot (BlockPoint 3 "bar") (PerasWeight 2) snap0 -- >>> snap1 --- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 2),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- [(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 --- [(Origin,PerasWeight 3),(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- [(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 -> @@ -150,10 +150,10 @@ addToPerasWeightSnapshot pt weight = -- >>> snap = mkPerasWeightSnapshot weights -- -- >>> prunePerasWeightSnapshot (SlotNo 2) snap --- [(At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"}),PerasWeight 4),(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- [(Point (At (Block {blockPointSlot = SlotNo 2, blockPointHash = "foo"})),PerasWeight 4),(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] -- -- >>> prunePerasWeightSnapshot (SlotNo 3) snap --- [(At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"}),PerasWeight 2)] +-- [(Point (At (Block {blockPointSlot = SlotNo 3, blockPointHash = "bar"})),PerasWeight 2)] prunePerasWeightSnapshot :: SlotNo -> PerasWeightSnapshot blk -> From 82d9ba20ec248d8a90d5da527c1afac8be119142 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 6 Aug 2025 18:37:51 +0200 Subject: [PATCH 36/68] Modify PerasCertDB (and to some extent, ChainDB) to allow snapshot of PerasCerts --- .../Consensus/Storage/ChainDB/API.hs | 3 + .../Consensus/Storage/ChainDB/Impl.hs | 1 + .../Consensus/Storage/ChainDB/Impl/Query.hs | 6 ++ .../Consensus/Storage/PerasCertDB/API.hs | 24 ++++++++ .../Consensus/Storage/PerasCertDB/Impl.hs | 58 ++++++++++++++++--- 5 files changed, 83 insertions(+), 9 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 91b13c2502..582436e8a0 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 , ReadOnlyForker' , Statistics ) +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 (WithFingerprint (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 037f1189ed..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 @@ -289,6 +289,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 ac6fc0be81..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 @@ -20,6 +20,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Query , getMaxSlotNo , getPastLedger , getPerasWeightSnapshot + , getPerasCertSnapshot , getReadOnlyForkerAtPoint , getStatistics , getTipBlock @@ -58,6 +59,7 @@ 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 (PerasCertSnapshot) import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (eitherToMaybe) @@ -287,6 +289,10 @@ getPerasWeightSnapshot :: ChainDbEnv m blk -> STM m (WithFingerprint (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 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 18d50c82a7..6879576541 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 @@ -1,12 +1,19 @@ {-# 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 @@ -23,6 +30,7 @@ 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) , garbageCollect :: SlotNo -> m () -- ^ Garbage-collect state older than the given slot number. , closeDB :: m () @@ -31,3 +39,19 @@ data PerasCertDB m blk = PerasCertDB data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB deriving stock (Show, Eq) + +-- TODO: also move the weight snapshot in here? +data PerasCertSnapshot blk = PerasCertSnapshot + { containsCert :: PerasRoundNo -> Bool + -- ^ Do we have the certificate for this round? + , getCertsAfter :: PerasCertTicketNo -> [(PerasCert blk, PerasCertTicketNo)] + } + +-- TODO: Once we store historical certificates on disk, this should (also) track +-- round numbers, as we only have ticket numbers for in-memory certs. +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 index 6547afa521..3e86bf9df7 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 @@ -21,6 +21,7 @@ module Ouroboros.Consensus.Storage.PerasCertDB.Impl ) 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 @@ -69,6 +70,7 @@ openDB args = do PerasCertDB { addCert = getEnv1 h implAddCert , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot + , getCertSnapshot = getEnvSTM h implGetCertSnapshot , garbageCollect = getEnv1 h implGarbageCollect , closeDB = implCloseDB h } @@ -151,12 +153,15 @@ implAddCert env cert = do 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 @@ -165,6 +170,9 @@ implAddCert env cert = do , -- Note that the same block might be boosted by multiple points. pvcsWeightByPoint = addToPerasWeightSnapshot boostedPt boostPerCert pvcsWeightByPoint + , pvcsCertsByTicket = + Map.insert pvcsLastTicketNo' cert pvcsCertsByTicket + , pvcsLastTicketNo = pvcsLastTicketNo' } (succ fp) pure AddedPerasCertToDB @@ -187,6 +195,23 @@ implGetWeightSnapshot :: 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) => @@ -197,16 +222,22 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = atomically $ modifyTVar pcdbVolatileState (fmap gc) where gc :: PerasVolatileCertState blk -> PerasVolatileCertState blk - gc PerasVolatileCertState{pvcsCerts, pvcsWeightByPoint} = + gc PerasVolatileCertState - { pvcsCerts = certsToKeep - , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint - } - where - (_, certsToKeep) = - Map.partition isTooOld pvcsCerts - isTooOld cert = - pointSlot (perasCertBoostedBlock cert) < NotOrigin slot + { 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 (perasCertBoostedBlock cert) >= NotOrigin slot {------------------------------------------------------------------------------- Implementation-internal types @@ -221,6 +252,13 @@ data PerasVolatileCertState blk = PerasVolatileCertState -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db. -- -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (PerasCert 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 @@ -231,6 +269,8 @@ initialPerasVolatileCertState = PerasVolatileCertState { pvcsCerts = Map.empty , pvcsWeightByPoint = emptyPerasWeightSnapshot + , pvcsCertsByTicket = Map.empty + , pvcsLastTicketNo = zeroPerasCertTicketNo } (Fingerprint 0) From acdf1e967f9c5d37c599cefbc5f958fac4ffb4cc Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 11:17:03 +0200 Subject: [PATCH 37/68] Replace hardcoded miniprotocol parameters by default ones in unstable-diffusion-testlib --- .../Test/ThreadNet/Network.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) 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 d34e717e76..7dd6618146 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 c6a470c33e873ae14d33e1854ed7652f419b6a6e Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 18:30:13 +0200 Subject: [PATCH 38/68] Introduce the (generic) ObjectDiffusion protocol, ObjectPool, and the associated smoke tests --- cabal.project | 6 +- ouroboros-consensus/ouroboros-consensus.cabal | 4 + .../MiniProtocol/ObjectDiffusion/Inbound.hs | 461 ++++++++++++++++++ .../ObjectDiffusion/ObjectPool/API.hs | 38 ++ .../MiniProtocol/ObjectDiffusion/Outbound.hs | 252 ++++++++++ .../test/consensus-test/Main.hs | 2 + .../MiniProtocol/ObjectDiffusion/Smoke.hs | 333 +++++++++++++ 7 files changed, 1094 insertions(+), 2 deletions(-) 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 create mode 100644 ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs diff --git a/cabal.project b/cabal.project index 9d63fd9fd4..e92f12026c 100644 --- a/cabal.project +++ b/cabal.project @@ -59,9 +59,11 @@ allow-newer: source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: b07a86ed853b63881b5a83e57508902f1562ac01 - --sha256: sha256-n/XX0+cQegq2a1cAfmGx30T64eix4oEXzpVEFCKqmg0= + tag: c2e936f454a0026b9a854e5f230714de81b9965c + --sha256: sha256-139VtT1VJkBqIcqf+vak7h4Fh+Z748dHoHwaCCpKOy4= subdir: + ouroboros-network + ouroboros-network-protocols ouroboros-network-api ouroboros-network diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 4902267c6d..5a78f435a1 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 @@ -602,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/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..b6ad524e42 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE KindSignatures #-} +{-# 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.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 + | -- | Inbound received 'MsgDone' + TraceObjectInboundTerminated + | 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 -> + ObjectDiffusionInboundPipelined objectId object m () +objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) ObjectPoolWriter{..} _version = + 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 -> 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 <- 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) + + -- TODO: Certificate / Vote validation + + 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 + -- Our result if the outbound peer terminates the protocol + (traceWith tracer TraceObjectInboundTerminated) + ( \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 + } + ) + +------------------------------------------------------------------------------- +-- 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..0d74a6d94a --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/API.hs @@ -0,0 +1,38 @@ +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. + -- + -- TODO: This signature assume that we have all the IDs and ticketNos in + -- memory, but not the actual objects. This might change if IDs must be loaded + -- from disk too. + } + +-- | 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 :: 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..37b7e66748 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs @@ -0,0 +1,252 @@ +{-# 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.ControlMessage + ( ControlMessage + , ControlMessageSTM + , timeoutWithControlMessage + ) +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] + | TraceControlMessage ControlMessage + 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 -> + ControlMessageSTM m -> + ObjectDiffusionOutbound objectId object m () +objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version controlMessageSTM = + 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 + } + + 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 + + mbNewContent <- timeoutWithControlMessage controlMessageSTM $ + do + newObjectsWithTicketNos <- + oprObjectsAfter + lastTicketNo + (fromIntegral numIdsToReq) + check (not $ null newObjectsWithTicketNos) + pure newObjectsWithTicketNos + + case mbNewContent of + Nothing -> pure (SendMsgDone ()) + Just newContent -> do + 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)) 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..e751559939 --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -0,0 +1,333 @@ +{-# 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 + , objectDiffusionInboundClientPeerPipelined + , objectDiffusionInboundServerPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound + ( ObjectDiffusionOutbound + , objectDiffusionOutboundClientPeer + , objectDiffusionOutboundServerPeer + ) +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 (client inbound, server outbound)" + prop_smoke_init_inbound + , testProperty + "ObjectDiffusion smoke test with mock objects (client outbound, server inbound)" + prop_smoke_init_outbound + ] + +{------------------------------------------------------------------------------- + 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 <- atomically $ 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_init_inbound :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property +prop_smoke_init_inbound 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 + (objectDiffusionOutboundServerPeer outbound) + >> pure () + + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundClientPeerPipelined inbound) + >> pure () + +prop_smoke_init_outbound :: + ProtocolConstants -> ListWithUniqueIds SmokeObject SmokeObjectId -> Property +prop_smoke_init_outbound protocolConstants (ListWithUniqueIds objects) = + prop_smoke_object_diffusion + protocolConstants + objects + runOutboundPeer + runInboundPeer + (mkMockPoolInterfaces objects) + where + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundClientPeer outbound) + >> pure () + + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundServerPeerPipelined 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 initAgency objectId object)) -> + (Tracer m String) -> + m () + ) -> + ( forall m. + IOLike m => + ObjectDiffusionInboundPipelined objectId object m () -> + (Channel m (AnyMessage (ObjectDiffusion initAgency 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 + + outbound = + objectDiffusionOutbound + tracer + maxFifoSize + outboundPoolReader + nodeToNodeVersion + (readTVar controlMessage) + + 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 12b73adccd155452593af7d840dd1c3b4906c6f9 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 18:45:49 +0200 Subject: [PATCH 39/68] Introduce the PerasCertDiffusion protocol (instance of ObjectDiffusion), and the associated smoke test --- ouroboros-consensus/ouroboros-consensus.cabal | 3 + .../ObjectDiffusion/ObjectPool/PerasCert.hs | 76 +++++++++++ .../MiniProtocol/ObjectDiffusion/PerasCert.hs | 36 +++++ .../test/consensus-test/Main.hs | 2 + .../ObjectDiffusion/PerasCert/Smoke.hs | 126 ++++++++++++++++++ 5 files changed, 243 insertions(+) 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 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 5a78f435a1..e67214f5c7 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 @@ -605,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/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..2c734cff28 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -0,0 +1,76 @@ +-- | 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 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 = perasCertRound + , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo + , oprObjectsAfter = \lastKnown limit -> do + certSnapshot <- getCertSnapshot + pure $ + take (fromIntegral limit) $ + [ (ticketNo, perasCertRound cert, pure 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, MonadSTM m) => + PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromCertDB perasCertDB = + ObjectPoolWriter + { opwObjectId = perasCertRound + , opwAddObjects = + mapM_ $ PerasCertDB.addCert perasCertDB + , opwHasObject = do + certSnapshot <- atomically $ 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, MonadSTM m) => + ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m +makePerasCertPoolWriterFromChainDB chainDB = + ObjectPoolWriter + { opwObjectId = perasCertRound + , opwAddObjects = + mapM_ $ ChainDB.addPerasCertAsync chainDB + , opwHasObject = do + certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB + pure $ PerasCertDB.containsCert certSnapshot + } 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..004c38525b --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -0,0 +1,36 @@ +-- | 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 + ) 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) + +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 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..a04d6b97fa --- /dev/null +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -0,0 +1,126 @@ +{-# 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 + ( objectDiffusionInboundServerPeerPipelined + ) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundClientPeer) +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 + result <- PerasCertDB.addCert db cert + 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 + (objectDiffusionOutboundClientPeer outbound) + >> pure () + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundServerPeerPipelined 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 $ fst <$> rawContent + + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) From bf9d848d8178669a72d6c99df0066b1e55e327d4 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Wed, 6 Aug 2025 18:46:37 +0200 Subject: [PATCH 40/68] Wire-in the PerasCertDiffusion protocol in NodeToNode --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 33 +++++++++++++++++++ .../Ouroboros/Consensus/Node/Tracers.hs | 11 +++++++ 2 files changed, 44 insertions(+) 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..095c099ecc 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 @@ -197,6 +201,19 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ConnectionId addr -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m () + , hPerasCertDiffusionInbound :: + NodeToNodeVersion -> + ConnectionId addr -> + PerasCertDiffusionInboundPipelined blk m () + -- ^ TODO: We should pass 'hPerasCertDiffusionInbound' to the network + -- layer, as per https://github.com/tweag/cardano-peras/issues/78 + , hPerasCertDiffusionOutbound :: + NodeToNodeVersion -> + ControlMessageSTM m -> + ConnectionId addr -> + PerasCertDiffusionOutbound blk m () + -- ^ TODO: We should pass 'hPerasCertDiffusionOutbound' to the network + -- layer, as per https://github.com/tweag/cardano-peras/issues/78 , hKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m -> @@ -293,6 +310,22 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version + , hPerasCertDiffusionInbound = \version peer -> + objectDiffusionInbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers)) + ( perasCertDiffusionMaxFifoLength miniProtocolParameters + , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97 + , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97 + ) + (makePerasCertPoolWriterFromChainDB $ getChainDB) + version + , hPerasCertDiffusionOutbound = \version controlMessageSTM peer -> + objectDiffusionOutbound + (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) + (perasCertDiffusionMaxFifoLength miniProtocolParameters) + (makePerasCertPoolReaderFromChainDB $ getChainDB) + version + controlMessageSTM , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng , hKeepAliveServer = \_version _peer -> keepAliveServer , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM 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 24b82c331d..7cee89fa52 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.Network.Block (Tip) import Ouroboros.Network.BlockFetch @@ -87,6 +88,10 @@ data Tracers' remotePeer localPeer blk f = Tracers , csjTracer :: f (TraceLabelPeer remotePeer (CSJumping.TraceEventCsj remotePeer blk)) , dbfTracer :: f (CSJumping.TraceEventDbf remotePeer) + , perasCertDiffusionInboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionInbound blk)) + , perasCertDiffusionOutboundTracer :: + f (TraceLabelPeer remotePeer (TracePerasCertDiffusionOutbound blk)) } instance @@ -115,6 +120,8 @@ instance , gddTracer = f gddTracer , csjTracer = f csjTracer , dbfTracer = f dbfTracer + , perasCertDiffusionInboundTracer = f perasCertDiffusionInboundTracer + , perasCertDiffusionOutboundTracer = f perasCertDiffusionOutboundTracer } where f :: @@ -151,6 +158,8 @@ nullTracers = , gddTracer = nullTracer , csjTracer = nullTracer , dbfTracer = nullTracer + , perasCertDiffusionInboundTracer = nullTracer + , perasCertDiffusionOutboundTracer = nullTracer } showTracers :: @@ -189,6 +198,8 @@ showTracers tr = , gddTracer = showTracing tr , csjTracer = showTracing tr , dbfTracer = showTracing tr + , perasCertDiffusionInboundTracer = showTracing tr + , perasCertDiffusionOutboundTracer = showTracing tr } {------------------------------------------------------------------------------- From 64548be7b8ba629b050f6071d8d8f8379b7c2b43 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 2 Sep 2025 10:51:46 +0200 Subject: [PATCH 41/68] Change signature of `opwHasObject` to use `STM m` instead of `m` --- .../Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs | 2 +- .../MiniProtocol/ObjectDiffusion/ObjectPool/API.hs | 6 +----- .../MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs | 4 ++-- .../Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs | 2 +- 4 files changed, 5 insertions(+), 9 deletions(-) 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 index b6ad524e42..587036d87d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -287,7 +287,7 @@ objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq -- objectIds that we already have in the pool and thus don't need to -- request. let st' = st{numIdsInFlight = numIdsInFlight st - numIdsRequested} - poolHasObject <- opwHasObject + poolHasObject <- atomically $ opwHasObject continueWithStateM (go n) (preAcknowledge st' poolHasObject collectedIds) 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 index 0d74a6d94a..e10b43d1ee 100644 --- 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 @@ -19,10 +19,6 @@ data ObjectPoolReader objectId object ticketNo m -- 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. - -- - -- TODO: This signature assume that we have all the IDs and ticketNos in - -- memory, but not the actual objects. This might change if IDs must be loaded - -- from disk too. } -- | Interface used by the inbound side of object diffusion when receiving @@ -33,6 +29,6 @@ data ObjectPoolWriter objectId object m -- ^ Return the id of the specified object , opwAddObjects :: [object] -> m () -- ^ Add a batch of objects to the objectPool. - , opwHasObject :: m (objectId -> Bool) + , 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/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index 2c734cff28..c28189a780 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 @@ -52,7 +52,7 @@ makePerasCertPoolWriterFromCertDB perasCertDB = , opwAddObjects = mapM_ $ PerasCertDB.addCert perasCertDB , opwHasObject = do - certSnapshot <- atomically $ PerasCertDB.getCertSnapshot perasCertDB + certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB pure $ PerasCertDB.containsCert certSnapshot } @@ -71,6 +71,6 @@ makePerasCertPoolWriterFromChainDB chainDB = , opwAddObjects = mapM_ $ ChainDB.addPerasCertAsync chainDB , opwHasObject = do - certSnapshot <- atomically $ ChainDB.getPerasCertSnapshot chainDB + certSnapshot <- ChainDB.getPerasCertSnapshot chainDB pure $ PerasCertDB.containsCert certSnapshot } 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 index e751559939..d681c12016 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -139,7 +139,7 @@ makeObjectPoolWriter (SmokeObjectPool poolContentTvar) = atomically $ modifyTVar poolContentTvar (++ objects) return () , opwHasObject = do - poolContent <- atomically $ readTVar poolContentTvar + poolContent <- readTVar poolContentTvar pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent } From 6c4d5c4fc516ab9b96046114dd8adda330c4b740 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 2 Sep 2025 11:19:29 +0200 Subject: [PATCH 42/68] Add module docstring to ObjectPool API --- .../ObjectDiffusion/ObjectPool/API.hs | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) 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 index e10b43d1ee..2f949d8b3b 100644 --- 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 @@ -1,3 +1,28 @@ +-- | 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 (..) From 250127723da9957292dc419633c53100979c64fb Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 2 Sep 2025 16:57:35 +0200 Subject: [PATCH 43/68] Add codec for PerasCert and PerasCertDiffusion --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 51 +++++++++++-------- .../Test/ThreadNet/Network.hs | 5 ++ .../Consensus/Block/SupportsPeras.hs | 17 ++++++- .../MiniProtocol/ObjectDiffusion/PerasCert.hs | 5 ++ .../Ouroboros/Consensus/Node/Serialisation.hs | 40 +++++++++++++-- 5 files changed, 92 insertions(+), 26 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 095c099ecc..b0cdd043c5 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 @@ -85,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 @@ -128,6 +124,10 @@ 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 + ( codecObjectDiffusion + , codecObjectDiffusionId + ) import Ouroboros.Network.Protocol.PeerSharing.Client ( PeerSharingClient , peerSharingClientPeer @@ -337,7 +337,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 @@ -345,6 +345,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 } @@ -372,49 +373,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 @@ -434,6 +439,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 = @@ -443,6 +449,7 @@ identityCodecs = , cBlockFetchCodec = codecBlockFetchId , cBlockFetchCodecSerialised = codecBlockFetchId , cTxSubmission2Codec = codecTxSubmission2Id + , cPerasCertDiffusionCodec = codecObjectDiffusionId , cKeepAliveCodec = codecKeepAliveId , cPeerSharingCodec = codecPeerSharingId } @@ -620,7 +627,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 @@ -635,7 +642,7 @@ 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) -> + (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) -> ByteLimits bCS bBF bTX bKA -> -- Chain-Sync timeouts for chain-sync client (using `Header blk`) as well as -- the server (`SerialisedHeader 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 7dd6618146..e47cdbcb5b 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 @@ -1180,6 +1181,7 @@ runThreadNetwork Lazy.ByteString Lazy.ByteString (AnyMessage (TxSubmission2 (GenTxId blk) (GenTx blk))) + (AnyMessage (PerasCertDiffusion blk)) (AnyMessage KeepAlive) (AnyMessage (PeerSharing NodeId)) customNodeToNodeCodecs cfg ntnVersion = @@ -1199,6 +1201,9 @@ runThreadNetwork , cTxSubmission2Codec = mapFailureCodec CodecIdFailure $ NTN.cTxSubmission2Codec NTN.identityCodecs + , cPerasCertDiffusionCodec = + mapFailureCodec CodecIdFailure $ + NTN.cPerasCertDiffusionCodec NTN.identityCodecs , cKeepAliveCodec = mapFailureCodec CodecIdFailure $ NTN.cKeepAliveCodec NTN.identityCodecs 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 7709e759cf..cb9f1c3939 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -16,6 +17,9 @@ module Ouroboros.Consensus.Block.SupportsPeras , PerasCert (..) ) where +import Codec.Serialise (Serialise (..)) +import Codec.Serialise.Decoding (decodeListLenOf) +import Codec.Serialise.Encoding (encodeListLen) import Data.Monoid (Sum (..)) import Data.Word (Word64) import GHC.Generics (Generic) @@ -27,7 +31,7 @@ import Quiet (Quiet (..)) newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving Show via Quiet PerasRoundNo deriving stock Generic - deriving newtype (Eq, Ord, NoThunks) + deriving newtype (Eq, Ord, NoThunks, Serialise) instance Condense PerasRoundNo where condense = show . unPerasRoundNo @@ -66,3 +70,14 @@ instance StandardHash blk => BlockSupportsPeras blk where perasCertRound = pcCertRound perasCertBoostedBlock = pcCertBoostedBlock + +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} 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 index 004c38525b..f646fa27b4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -7,6 +7,7 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert , PerasCertPoolWriter , PerasCertDiffusionInboundPipelined , PerasCertDiffusionOutbound + , PerasCertDiffusion ) where import Ouroboros.Consensus.Block @@ -16,6 +17,7 @@ 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, OutboundAgency) type TracePerasCertDiffusionInbound blk = TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk) @@ -34,3 +36,6 @@ type PerasCertDiffusionInboundPipelined blk m a = type PerasCertDiffusionOutbound blk m a = ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a + +type PerasCertDiffusion blk = + ObjectDiffusion OutboundAgency 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 1f1bdeb2d1d4365a7489c880d0b210641b205145 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 4 Sep 2025 19:27:54 +0200 Subject: [PATCH 44/68] Integrate `NodeToNodeV_16` --- .../Ouroboros/Consensus/Cardano/Node.hs | 1 + .../Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs | 1 + 2 files changed, 2 insertions(+) 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 0edeb83eb6..e77eb7c114 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 @@ -432,6 +432,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 From 43bdef4d707044c6377716bc0f3d68b12ef96875 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 3 Sep 2025 20:03:16 +0200 Subject: [PATCH 45/68] Peras: add a few `ShowProxy` instances --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 9 +++++++++ 1 file changed, 9 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 cb9f1c3939..015981e1ae 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -21,10 +22,12 @@ 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 (..)) @@ -36,6 +39,9 @@ newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} 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 @@ -71,6 +77,9 @@ instance StandardHash blk => BlockSupportsPeras blk where perasCertRound = pcCertRound perasCertBoostedBlock = pcCertBoostedBlock +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 From d0799c85d6cb535ef6b5a76b4f348e49e8f80df7 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 4 Sep 2025 20:06:35 +0200 Subject: [PATCH 46/68] Adapt to removal of `initAgency` --- .../Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 index f646fa27b4..ba0ba934a2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -17,7 +17,7 @@ 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, OutboundAgency) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion) type TracePerasCertDiffusionInbound blk = TraceObjectDiffusionInbound PerasRoundNo (PerasCert blk) @@ -38,4 +38,4 @@ type PerasCertDiffusionOutbound blk m a = ObjectDiffusionOutbound PerasRoundNo (PerasCert blk) m a type PerasCertDiffusion blk = - ObjectDiffusion OutboundAgency PerasRoundNo (PerasCert blk) + ObjectDiffusion PerasRoundNo (PerasCert blk) From 5d82e49cae7bed345b91d2e749042eb3bc81c32f Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 4 Sep 2025 20:32:46 +0200 Subject: [PATCH 47/68] Adapt to changed agency of `MsgDone` The diff is actually quite small; it is recommended to review with sth like https://github.com/Wilfred/difftastic --- .../MiniProtocol/ObjectDiffusion/Inbound.hs | 578 +++++++++--------- .../MiniProtocol/ObjectDiffusion/Outbound.hs | 68 +-- 2 files changed, 331 insertions(+), 315 deletions(-) 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 index 587036d87d..bba2d07cb0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -7,6 +7,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -38,6 +39,7 @@ 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 @@ -55,8 +57,9 @@ data TraceObjectDiffusionInbound objectId object TraceObjectDiffusionCollected Int | -- | Just processed object pass/fail breakdown. TraceObjectDiffusionProcessed NumObjectsProcessed - | -- | Inbound received 'MsgDone' - TraceObjectInboundTerminated + | -- | Received a 'ControlMessage' from the outbound peer governor, and about + -- to act on it. + TraceObjectDiffusionControlMessage ControlMessage | TraceObjectInboundCanRequestMoreObjects Int | TraceObjectInboundCannotRequestMoreObjects Int deriving (Eq, Show) @@ -127,291 +130,312 @@ objectDiffusionInbound :: (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq) -> ObjectPoolWriter objectId object m -> NodeToNodeVersion -> + ControlMessageSTM m -> ObjectDiffusionInboundPipelined objectId object m () -objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) ObjectPoolWriter{..} _version = - 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 -> 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) - - -- TODO: Certificate / Vote validation - - opwAddObjects objectsToAck - traceWith tracer $ - TraceObjectDiffusionProcessed - (NumObjectsProcessed (fromIntegral $ length objectsToAck)) - continueWithStateM - (go n) +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 - { pendingObjects = pendingObjects'' - , outstandingFifo = outstandingFifo' + { canRequestNext = canRequestNext st <> (Set.fromList notYetObtained) + , 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 - -- Our result if the outbound peer terminates the protocol - (traceWith tracer TraceObjectInboundTerminated) - ( \neCollectedIds -> - collectAndContinueWithState - (goCollect Zero) - st - { numToAckOnNextReq = 0 - , numIdsInFlight = numIdsToRequest - } - (CollectObjectIds numIdsToRequest (NonEmpty.toList neCollectedIds)) + 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) + + -- TODO: Certificate / Vote validation + + 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) ) - - 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)) + $ SendMsgRequestObjectIdsBlocking + (numToAckOnNextReq st) + numIdsToRequest + ( \neCollectedIds -> + collectAndContinueWithState + (goCollect Zero) st - { numIdsInFlight = - numIdsInFlight st - + numIdsToRequest - , numToAckOnNextReq = 0 + { 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) 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 index 37b7e66748..34c90b9836 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Outbound.hs @@ -20,11 +20,6 @@ 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.ControlMessage - ( ControlMessage - , ControlMessageSTM - , timeoutWithControlMessage - ) import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound import Ouroboros.Network.Protocol.ObjectDiffusion.Type @@ -41,7 +36,8 @@ data TraceObjectDiffusionOutbound objectId object | -- | The objects to be sent in the response. TraceObjectDiffusionOutboundSendMsgReplyObjects [object] - | TraceControlMessage ControlMessage + | -- | Received 'MsgDone' + TraceObjectDiffusionOutboundTerminated deriving Show data ObjectDiffusionOutboundError @@ -90,9 +86,8 @@ objectDiffusionOutbound :: NumObjectsOutstanding -> ObjectPoolReader objectId object ticketNo m -> NodeToNodeVersion -> - ControlMessageSTM m -> ObjectDiffusionOutbound objectId object m () -objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version controlMessageSTM = +objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version = ObjectDiffusionOutbound (pure (makeBundle $ OutboundSt Seq.empty oprZeroTicketNo)) where makeBundle :: OutboundSt objectId object ticketNo -> OutboundStIdle objectId object m () @@ -100,6 +95,7 @@ objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version contr OutboundStIdle { recvMsgRequestObjectIds = recvMsgRequestObjectIds st , recvMsgRequestObjects = recvMsgRequestObjects st + , recvMsgDone = traceWith tracer TraceObjectDiffusionOutboundTerminated } updateStNewObjects :: @@ -158,36 +154,32 @@ objectDiffusionOutbound tracer maxFifoLength ObjectPoolReader{..} _version contr unless (Seq.null outstandingFifo') $ throwIO ProtocolErrorRequestBlocking - mbNewContent <- timeoutWithControlMessage controlMessageSTM $ - do - newObjectsWithTicketNos <- - oprObjectsAfter - lastTicketNo - (fromIntegral numIdsToReq) - check (not $ null newObjectsWithTicketNos) - pure newObjectsWithTicketNos - - case mbNewContent of - Nothing -> pure (SendMsgDone ()) - Just newContent -> do - 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'') + 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 From 935525dbb21d21a25736c81f8cf9c2dc924dc816 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Wed, 3 Sep 2025 20:03:23 +0200 Subject: [PATCH 48/68] `O.C.Network.NodeToNode`: plumbing for Peras cert diffusion --- cabal.project | 4 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 109 +++++++++++++++--- .../Ouroboros/Consensus/Node.hs | 2 + .../Test/ThreadNet/Network.hs | 1 + 4 files changed, 95 insertions(+), 21 deletions(-) diff --git a/cabal.project b/cabal.project index e92f12026c..90d4e52497 100644 --- a/cabal.project +++ b/cabal.project @@ -59,8 +59,8 @@ allow-newer: source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: c2e936f454a0026b9a854e5f230714de81b9965c - --sha256: sha256-139VtT1VJkBqIcqf+vak7h4Fh+Z748dHoHwaCCpKOy4= + tag: 8dfff7b8916f7a56b2a3773438d5e5530c780710 + --sha256: sha256-wMDq19G1SW4+puuQUUjgaULSou4+r7wJj6evnWoW/Xk= subdir: ouroboros-network ouroboros-network-protocols 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 b0cdd043c5..426a379b22 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 @@ -125,8 +125,16 @@ import Ouroboros.Network.Protocol.KeepAlive.Codec import Ouroboros.Network.Protocol.KeepAlive.Server import Ouroboros.Network.Protocol.KeepAlive.Type import Ouroboros.Network.Protocol.ObjectDiffusion.Codec - ( codecObjectDiffusion + ( 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 @@ -201,19 +209,15 @@ data Handlers m addr blk = Handlers NodeToNodeVersion -> ConnectionId addr -> TxSubmissionServerPipelined (GenTxId blk) (GenTx blk) m () - , hPerasCertDiffusionInbound :: + , hPerasCertDiffusionClient :: NodeToNodeVersion -> + ControlMessageSTM m -> ConnectionId addr -> PerasCertDiffusionInboundPipelined blk m () - -- ^ TODO: We should pass 'hPerasCertDiffusionInbound' to the network - -- layer, as per https://github.com/tweag/cardano-peras/issues/78 - , hPerasCertDiffusionOutbound :: + , hPerasCertDiffusionServer :: NodeToNodeVersion -> - ControlMessageSTM m -> ConnectionId addr -> PerasCertDiffusionOutbound blk m () - -- ^ TODO: We should pass 'hPerasCertDiffusionOutbound' to the network - -- layer, as per https://github.com/tweag/cardano-peras/issues/78 , hKeepAliveClient :: NodeToNodeVersion -> ControlMessageSTM m -> @@ -310,7 +314,7 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version - , hPerasCertDiffusionInbound = \version peer -> + , hPerasCertDiffusionClient = \version controlMessageSTM peer -> objectDiffusionInbound (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers)) ( perasCertDiffusionMaxFifoLength miniProtocolParameters @@ -319,13 +323,13 @@ mkHandlers ) (makePerasCertPoolWriterFromChainDB $ getChainDB) version - , hPerasCertDiffusionOutbound = \version controlMessageSTM peer -> + controlMessageSTM + , hPerasCertDiffusionServer = \version peer -> objectDiffusionOutbound (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) (perasCertDiffusionMaxFifoLength miniProtocolParameters) (makePerasCertPoolReaderFromChainDB $ getChainDB) version - controlMessageSTM , hKeepAliveClient = \_version -> keepAliveClient (Node.keepAliveClientTracer tracers) keepAliveRng , hKeepAliveServer = \_version _peer -> keepAliveServer , hPeerSharingClient = \_version controlMessageSTM _peer -> peerSharingClient controlMessageSTM @@ -472,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))) } @@ -484,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 } @@ -504,6 +510,7 @@ nullTracers = , tBlockFetchTracer = nullTracer , tBlockFetchSerialisedTracer = nullTracer , tTxSubmission2Tracer = nullTracer + , tPerasCertDiffusionTracer = nullTracer , tKeepAliveTracer = nullTracer , tPeerSharingTracer = nullTracer } @@ -525,6 +532,7 @@ showTracers tr = , tBlockFetchTracer = showTracing tr , tBlockFetchSerialisedTracer = showTracing tr , tTxSubmission2Tracer = showTracing tr + , tPerasCertDiffusionTracer = showTracing tr , tKeepAliveTracer = showTracing tr , tPeerSharingTracer = showTracing tr } @@ -549,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. @@ -565,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 @@ -580,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 @@ -596,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 @@ -643,7 +662,7 @@ mkApps :: StdGen -> Tracers m addrNTN blk e -> (NodeToNodeVersion -> Codecs blk addrNTN e m bCS bCS bBF bBF bTX bPCD bKA bPS) -> - ByteLimits bCS bBF bTX bKA -> + 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))) -> @@ -651,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 @@ -830,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 -> @@ -933,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 @@ -951,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 = @@ -969,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 @@ -990,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/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index e47cdbcb5b..42810dbfc1 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 @@ -1794,6 +1794,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 From a930796ae25d95a53a51aea4cceb6dcca1b0be5a Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 4 Sep 2025 21:00:09 +0200 Subject: [PATCH 49/68] Adapt tests --- .../ObjectDiffusion/PerasCert/Smoke.hs | 8 +-- .../MiniProtocol/ObjectDiffusion/Smoke.hs | 53 ++++--------------- 2 files changed, 15 insertions(+), 46 deletions(-) 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 a04d6b97fa..207d7f4cf2 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 @@ -28,9 +28,9 @@ 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 - ( objectDiffusionInboundServerPeerPipelined + ( objectDiffusionInboundPeerPipelined ) -import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundClientPeer) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( ListWithUniqueIds (..) , ProtocolConstants @@ -95,14 +95,14 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) codecObjectDiffusionId outboundChannel - (objectDiffusionOutboundClientPeer outbound) + (objectDiffusionOutboundPeer outbound) >> pure () runInboundPeer inbound inboundChannel tracer = runPipelinedPeer ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) codecObjectDiffusionId inboundChannel - (objectDiffusionInboundServerPeerPipelined inbound) + (objectDiffusionInboundPeerPipelined inbound) >> pure () mkPoolInterfaces :: forall m. 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 index d681c12016..d2f21c9b66 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -51,13 +51,11 @@ import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..)) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId) import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( ObjectDiffusionInboundPipelined - , objectDiffusionInboundClientPeerPipelined - , objectDiffusionInboundServerPeerPipelined + , objectDiffusionInboundPeerPipelined ) import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound ( ObjectDiffusionOutbound - , objectDiffusionOutboundClientPeer - , objectDiffusionOutboundServerPeer + , objectDiffusionOutboundPeer ) import Ouroboros.Network.Protocol.ObjectDiffusion.Type ( NumObjectIdsReq (..) @@ -76,11 +74,8 @@ tests = testGroup "ObjectDiffusion.Smoke" [ testProperty - "ObjectDiffusion smoke test with mock objects (client inbound, server outbound)" - prop_smoke_init_inbound - , testProperty - "ObjectDiffusion smoke test with mock objects (client outbound, server inbound)" - prop_smoke_init_outbound + "ObjectDiffusion smoke test with mock objects" + prop_smoke ] {------------------------------------------------------------------------------- @@ -185,8 +180,8 @@ instance Arbitrary ProtocolConstants where nodeToNodeVersion :: NodeToNodeVersion nodeToNodeVersion = NodeToNodeV_14 -prop_smoke_init_inbound :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property -prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) = +prop_smoke :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property +prop_smoke protocolConstants (ListWithUniqueIds objects) = prop_smoke_object_diffusion protocolConstants objects @@ -199,7 +194,7 @@ prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) = ((\x -> "Outbound (Server): " ++ show x) `contramap` tracer) codecObjectDiffusionId outboundChannel - (objectDiffusionOutboundServerPeer outbound) + (objectDiffusionOutboundPeer outbound) >> pure () runInboundPeer inbound inboundChannel tracer = @@ -207,33 +202,7 @@ prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) = ((\x -> "Inbound (Client): " ++ show x) `contramap` tracer) codecObjectDiffusionId inboundChannel - (objectDiffusionInboundClientPeerPipelined inbound) - >> pure () - -prop_smoke_init_outbound :: - ProtocolConstants -> ListWithUniqueIds SmokeObject SmokeObjectId -> Property -prop_smoke_init_outbound protocolConstants (ListWithUniqueIds objects) = - prop_smoke_object_diffusion - protocolConstants - objects - runOutboundPeer - runInboundPeer - (mkMockPoolInterfaces objects) - where - runOutboundPeer outbound outboundChannel tracer = - runPeer - ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) - codecObjectDiffusionId - outboundChannel - (objectDiffusionOutboundClientPeer outbound) - >> pure () - - runInboundPeer inbound inboundChannel tracer = - runPipelinedPeer - ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) - codecObjectDiffusionId - inboundChannel - (objectDiffusionInboundServerPeerPipelined inbound) + (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 @@ -251,14 +220,14 @@ prop_smoke_object_diffusion :: ( forall m. IOLike m => ObjectDiffusionOutbound objectId object m () -> - Channel m (AnyMessage (ObjectDiffusion initAgency objectId object)) -> + Channel m (AnyMessage (ObjectDiffusion objectId object)) -> (Tracer m String) -> m () ) -> ( forall m. IOLike m => ObjectDiffusionInboundPipelined objectId object m () -> - (Channel m (AnyMessage (ObjectDiffusion initAgency objectId object))) -> + (Channel m (AnyMessage (ObjectDiffusion objectId object))) -> (Tracer m String) -> m () ) -> @@ -297,6 +266,7 @@ prop_smoke_object_diffusion ) inboundPoolWriter nodeToNodeVersion + (readTVar controlMessage) outbound = objectDiffusionOutbound @@ -304,7 +274,6 @@ prop_smoke_object_diffusion maxFifoSize outboundPoolReader nodeToNodeVersion - (readTVar controlMessage) withRegistry $ \reg -> do (outboundChannel, inboundChannel) <- createConnectedChannels From 233f1b26b70b26ac62277b7061452f7f18694e59 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 2 Sep 2025 11:58:27 +0200 Subject: [PATCH 50/68] Add basic API for certificate validation --- .../Consensus/Block/SupportsPeras.hs | 76 +++++++++++++++++-- .../ObjectDiffusion/ObjectPool/PerasCert.hs | 47 +++++++++--- .../Consensus/Storage/ChainDB/API.hs | 6 +- .../Storage/ChainDB/Impl/Background.hs | 2 +- .../Storage/ChainDB/Impl/ChainSel.hs | 6 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 7 +- .../Consensus/Storage/PerasCertDB/API.hs | 5 +- .../Consensus/Storage/PerasCertDB/Impl.hs | 14 ++-- .../Test/Util/Orphans/ToExpr.hs | 2 + .../ObjectDiffusion/PerasCert/Smoke.hs | 9 ++- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 9 +-- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 21 ++--- .../Ouroboros/Storage/PerasCertDB/Model.hs | 10 ++- .../Storage/PerasCertDB/StateMachine.hs | 20 +++-- 14 files changed, 173 insertions(+), 61 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 015981e1ae..ec99788c63 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -16,6 +17,12 @@ module Ouroboros.Consensus.Block.SupportsPeras , boostPerCert , BlockSupportsPeras (..) , PerasCert (..) + , ValidatedPerasCert (..) + , makePerasCfg + , HasPerasCert (..) + , getPerasCertRound + , getPerasCertBoostedBlock + , getPerasCertBoost ) where import Codec.Serialise (Serialise (..)) @@ -55,18 +62,40 @@ instance Condense PerasWeight where 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 + class - NoThunks (PerasCert blk) => + ( Show (PerasCfg blk) + , NoThunks (PerasCert blk) + ) => BlockSupportsPeras blk where + data PerasCfg blk + data PerasCert blk - perasCertRound :: PerasCert blk -> PerasRoundNo + data PerasValidationErr blk - perasCertBoostedBlock :: PerasCert blk -> Point blk + validatePerasCert :: + PerasCfg blk -> + PerasCert blk -> + Either (PerasValidationErr blk) (ValidatedPerasCert blk) -- TODO degenerate instance for all blks to get things to compile instance StandardHash blk => BlockSupportsPeras blk where + newtype PerasCfg blk = PerasCfg + { -- TODO eventually, this will come from the + -- protocol parameters from the ledger state + perasCfgWeightBoost :: PerasWeight + } + deriving stock (Show, Eq) + data PerasCert blk = PerasCert { pcCertRound :: PerasRoundNo , pcCertBoostedBlock :: Point blk @@ -74,8 +103,19 @@ instance StandardHash blk => BlockSupportsPeras blk where deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks - perasCertRound = pcCertRound - perasCertBoostedBlock = pcCertBoostedBlock + -- TODO enrich with actual error types + data PerasValidationErr blk + = PerasValidationErr + deriving stock (Show, Eq) + + -- TODO perform actual validation against all + -- possible 'PerasValidationErr' variants + validatePerasCert cfg cert = + Right + ValidatedPerasCert + { vpcCert = cert + , vpcCertBoost = perasCfgWeightBoost cfg + } instance ShowProxy blk => ShowProxy (PerasCert blk) where showProxy _ = "PerasCert " <> showProxy (Proxy @blk) @@ -90,3 +130,29 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where 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 +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/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index c28189a780..99af93eac4 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 @@ -1,3 +1,6 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + -- | Instantiate 'ObjectPoolReader' and 'ObjectPoolWriter' using Peras -- certificates from the 'PerasCertDB' (or the 'ChainDB' which is wrapping the -- 'PerasCertDB'). @@ -8,6 +11,7 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where +import GHC.Exception (throw) import Ouroboros.Consensus.Block import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) @@ -26,13 +30,13 @@ makePerasCertPoolReaderFromSnapshot :: ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromSnapshot getCertSnapshot = ObjectPoolReader - { oprObjectId = perasCertRound + { oprObjectId = getPerasCertRound , oprZeroTicketNo = PerasCertDB.zeroPerasCertTicketNo , oprObjectsAfter = \lastKnown limit -> do certSnapshot <- getCertSnapshot pure $ take (fromIntegral limit) $ - [ (ticketNo, perasCertRound cert, pure cert) + [ (ticketNo, getPerasCertRound cert, pure (getPerasCert cert)) | (cert, ticketNo) <- PerasCertDB.getCertsAfter certSnapshot lastKnown ] } @@ -44,13 +48,14 @@ makePerasCertPoolReaderFromCertDB perasCertDB = makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) makePerasCertPoolWriterFromCertDB :: - (StandardHash blk, MonadSTM m) => + (StandardHash blk, IOLike m) => PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m makePerasCertPoolWriterFromCertDB perasCertDB = ObjectPoolWriter - { opwObjectId = perasCertRound - , opwAddObjects = - mapM_ $ PerasCertDB.addCert perasCertDB + { opwObjectId = getPerasCertRound + , opwAddObjects = \certs -> do + validatePerasCerts certs + >>= mapM_ (PerasCertDB.addCert perasCertDB) , opwHasObject = do certSnapshot <- PerasCertDB.getCertSnapshot perasCertDB pure $ PerasCertDB.containsCert certSnapshot @@ -63,14 +68,36 @@ makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) makePerasCertPoolWriterFromChainDB :: - (StandardHash blk, MonadSTM m) => + (StandardHash blk, IOLike m) => ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m makePerasCertPoolWriterFromChainDB chainDB = ObjectPoolWriter - { opwObjectId = perasCertRound - , opwAddObjects = - mapM_ $ ChainDB.addPerasCertAsync chainDB + { 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 + 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/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 582436e8a0..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 @@ -392,8 +392,8 @@ 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 + , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m) + -- ^ TODO docs , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) -- ^ TODO , getPerasCertSnapshot :: STM m (PerasCertSnapshot blk) @@ -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 de48f12b56..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 @@ -553,7 +553,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. @@ -609,7 +609,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 @@ -623,8 +623,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/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 6879576541..eebf03de47 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 @@ -21,7 +21,8 @@ import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) data PerasCertDB m blk = PerasCertDB - { addCert :: PerasCert blk -> m AddPerasCertResult + { addCert :: ValidatedPerasCert blk -> m AddPerasCertResult + -- ^ TODO docs , 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 @@ -44,7 +45,7 @@ data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB data PerasCertSnapshot blk = PerasCertSnapshot { containsCert :: PerasRoundNo -> Bool -- ^ Do we have the certificate for this round? - , getCertsAfter :: PerasCertTicketNo -> [(PerasCert blk, PerasCertTicketNo)] + , getCertsAfter :: PerasCertTicketNo -> [(ValidatedPerasCert blk, PerasCertTicketNo)] } -- TODO: Once we store historical certificates on disk, this should (also) track 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 3e86bf9df7..a05cb067ab 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 @@ -144,7 +144,7 @@ implAddCert :: , StandardHash blk ) => PerasCertDbEnv m blk -> - PerasCert blk -> + ValidatedPerasCert blk -> m AddPerasCertResult implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt @@ -169,7 +169,7 @@ implAddCert env cert = do Map.insert roundNo cert pvcsCerts , -- Note that the same block might be boosted by multiple points. pvcsWeightByPoint = - addToPerasWeightSnapshot boostedPt boostPerCert pvcsWeightByPoint + addToPerasWeightSnapshot boostedPt (getPerasCertBoost cert) pvcsWeightByPoint , pvcsCertsByTicket = Map.insert pvcsLastTicketNo' cert pvcsCertsByTicket , pvcsLastTicketNo = pvcsLastTicketNo' @@ -186,8 +186,8 @@ implAddCert env cert = do , pcdbVolatileState } = env - roundNo = perasCertRound cert - boostedPt = perasCertBoostedBlock cert + boostedPt = getPerasCertBoostedBlock cert + roundNo = getPerasCertRound cert implGetWeightSnapshot :: IOLike m => @@ -237,7 +237,7 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = } where keepCert cert = - pointSlot (perasCertBoostedBlock cert) >= NotOrigin slot + pointSlot (getPerasCertBoostedBlock cert) >= NotOrigin slot {------------------------------------------------------------------------------- Implementation-internal types @@ -246,13 +246,13 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- | Volatile Peras certificate state, i.e. certificates that could influence -- chain selection by boosting a volatile block. data PerasVolatileCertState blk = PerasVolatileCertState - { pvcsCerts :: !(Map PerasRoundNo (PerasCert blk)) + { 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 (PerasCert blk)) + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk)) -- ^ The certificates by 'PerasCertTicketNo'. -- -- INVARIANT: In sync with 'pvcsCerts'. 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 f883c7abdd..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 @@ -125,6 +125,8 @@ 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 --------------------------------------------------------------------------------} 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 207d7f4cf2..fbcf9af79a 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 @@ -78,7 +78,12 @@ newCertDB certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do - result <- PerasCertDB.addCert db cert + 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") @@ -121,6 +126,6 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = getAllInboundPoolContent = do snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) - pure $ fst <$> rawContent + pure $ getPerasCert . fst <$> rawContent return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) 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 b739d99526..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 @@ -179,7 +179,7 @@ import Test.Util.WithEq -- | Commands data Cmd blk it flr = AddBlock blk - | AddPerasCert (PerasCert blk) + | AddPerasCert (ValidatedPerasCert blk) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -1043,19 +1043,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 = 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 a1cda0e044..f6e7f5cb27 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 @@ -24,7 +24,7 @@ import Ouroboros.Consensus.Peras.Weight ) data Model blk = Model - { certs :: Set (PerasCert blk) + { certs :: Set (ValidatedPerasCert blk) , open :: Bool } deriving Generic @@ -42,7 +42,7 @@ closeDB _ = Model{open = False, certs = Set.empty} addCert :: StandardHash blk => - Model blk -> PerasCert blk -> Model blk + Model blk -> ValidatedPerasCert blk -> Model blk addCert model@Model{certs} cert = model{certs = Set.insert cert certs} @@ -51,10 +51,12 @@ getWeightSnapshot :: Model blk -> PerasWeightSnapshot blk getWeightSnapshot Model{certs} = mkPerasWeightSnapshot - [(perasCertBoostedBlock cert, boostPerCert) | cert <- Set.toList certs] + [ (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 (perasCertBoostedBlock cert) >= NotOrigin slot + 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 index 917c96eef6..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 @@ -5,7 +5,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} @@ -52,7 +51,7 @@ instance StateModel Model where data Action Model a where OpenDB :: Action Model () CloseDB :: Action Model () - AddCert :: PerasCert TestBlock -> Action Model AddPerasCertResult + AddCert :: ValidatedPerasCert TestBlock -> Action Model AddPerasCertResult GetWeightSnapshot :: Action Model (PerasWeightSnapshot TestBlock) GarbageCollect :: SlotNo -> Action Model () @@ -67,9 +66,18 @@ instance StateModel Model where | otherwise = pure $ Some OpenDB where genAddCert = do - pcCertRound <- PerasRoundNo <$> arbitrary - pcCertBoostedBlock <- genPoint - pure $ AddCert PerasCert{pcCertRound, pcCertBoostedBlock} + roundNo <- PerasRoundNo <$> arbitrary + boostedBlock <- genPoint + pure $ + AddCert + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = boostedBlock + } + , vpcCertBoost = boostPerCert + } genPoint :: Gen (Point TestBlock) genPoint = @@ -97,7 +105,7 @@ instance StateModel Model where -- Do not add equivocating certificates. AddCert cert -> all p model.certs where - p cert' = perasCertRound cert /= perasCertRound cert' || cert == cert' + p cert' = getPerasCertRound cert /= getPerasCertRound cert' || cert == cert' GetWeightSnapshot -> True GarbageCollect _slot -> True From 36d8f014739c532b7c3e12d09aaea17129813321 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Tue, 22 Jul 2025 09:13:31 +0200 Subject: [PATCH 51/68] 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 --- .../Consensus/Byron/Ledger/Ledger.hs | 2 + .../Consensus/Shelley/Ledger/Ledger.hs | 4 + .../Test/Consensus/Cardano/Generators.hs | 10 +- .../Test/Consensus/HardFork/Combinator.hs | 1 + .../test/mock-test/Test/ThreadNet/BFT.hs | 1 + .../Consensus/Block/SupportsPeras.hs | 20 +++- .../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 ++++++++++++- 16 files changed, 401 insertions(+), 27 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..4dbc168cef 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,8 @@ shelleyEraParams genesis = , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis , eraSafeZone = HardFork.StandardSafeZone stabilityWindow , eraGenesisWin = GenesisWindow stabilityWindow + , -- TODO(geo2a): enabled Peras conditionally in the Dijkstra era + eraPerasRoundLength = HardFork.NoPerasEnabled } where stabilityWindow = @@ -183,6 +186,7 @@ shelleyEraParamsNeverHardForks genesis = , eraSlotLength = mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis , eraSafeZone = HardFork.UnsafeIndefiniteSafeZone , eraGenesisWin = GenesisWindow stabilityWindow + , eraPerasRoundLength = HardFork.NoPerasEnabled } where stabilityWindow = 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 e613b0c0f3..66d077a344 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 549de0f352..5821c0a534 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-diffusion/test/mock-test/Test/ThreadNet/BFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs index 3f82ec83e3..80b1eff97d 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 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 ec99788c63..f46ffc92a3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -23,6 +23,10 @@ module Ouroboros.Consensus.Block.SupportsPeras , getPerasCertRound , getPerasCertBoostedBlock , getPerasCertBoost + + -- * Ouroboros Peras round length + , PerasRoundLength (..) + , defaultPerasRoundLength ) where import Codec.Serialise (Serialise (..)) @@ -41,7 +45,7 @@ import Quiet (Quiet (..)) newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving Show via Quiet PerasRoundNo deriving stock Generic - deriving newtype (Eq, Ord, NoThunks, Serialise) + deriving newtype (Enum, Eq, Ord, NoThunks, Serialise) instance Condense PerasRoundNo where condense = show . unPerasRoundNo @@ -70,6 +74,20 @@ data ValidatedPerasCert blk = ValidatedPerasCert 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 +defaultPerasRoundLength :: PerasRoundLength +defaultPerasRoundLength = 90 + class ( Show (PerasCfg blk) , NoThunks (PerasCert blk) 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 591445ee8f12604bfd7ec6e910cc1da3c76ff96d Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 9 Sep 2025 14:03:54 +0200 Subject: [PATCH 52/68] 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. --- .../Ouroboros/Consensus/Peras/SelectView.hs | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs index 9e125ee7dd..7895a38a93 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/SelectView.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -20,6 +21,7 @@ module Ouroboros.Consensus.Peras.SelectView ) where import Data.Function (on) +import Data.Word (Word64) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Protocol.Abstract @@ -33,8 +35,12 @@ import qualified Ouroboros.Network.AnchoredFragment as AF -- | Information from a non-empty chain fragment for a weighted chain comparison -- against other fragments with the same anchor. data WeightedSelectView proto = WeightedSelectView - { wsvBlockNo :: !BlockNo - -- ^ The 'BlockNo' at the tip of a fragment. + { 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 @@ -48,11 +54,11 @@ deriving stock instance Eq (TiebreakerView proto) => Eq (WeightedSelectView prot -- 'WeightedSelectView's obtained from fragments with different anchors? -- Something ST-trick like? --- | The total weight, ie the sum of 'wsvBlockNo' and 'wsvBoostedWeight'. +-- | 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 (unBlockNo (wsvBlockNo wsv)) <> wsvWeightBoost wsv + PerasWeight (wsvLength wsv) <> wsvWeightBoost wsv instance Ord (TiebreakerView proto) => Ord (WeightedSelectView proto) where compare = @@ -90,7 +96,7 @@ weightedSelectView bcfg weights = \case frag@(_ AF.:> (getHeader1 -> hdr)) -> NonEmptyFragment WeightedSelectView - { wsvBlockNo = blockNo hdr + { wsvLength = fromIntegral @Int @Word64 $ AF.length frag , wsvWeightBoost = weightBoostOfFragment weights frag , wsvTiebreaker = tiebreakerView bcfg hdr } From e99d251051bae23244242881a0555654ad80ee0a Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 10 Sep 2025 20:13:54 +0200 Subject: [PATCH 53/68] Avoid exposing Peras boostPerCert in tests Since the Peras boost per certificate will likely become a protocol parameter, we proactively avoid exposing the current hardcoded value, replacing it with an instantiation of (currently trivial) the PerasCfg builder. In the special cases where it's interesting to vary the boost dynamically (ChainDB q-s-m), validated Peras certs now contain randomly generated boost weights. --- .../Ouroboros/Consensus/Block/SupportsPeras.hs | 2 +- .../ObjectDiffusion/PerasCert/Smoke.hs | 14 +++++++++----- .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs | 3 ++- .../Ouroboros/Storage/PerasCertDB/StateMachine.hs | 5 ++++- 4 files changed, 16 insertions(+), 8 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 f46ffc92a3..6ed874325f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -14,9 +14,9 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) , PerasWeight (..) - , boostPerCert , BlockSupportsPeras (..) , PerasCert (..) + , PerasCfg (..) , ValidatedPerasCert (..) , makePerasCfg , HasPerasCert (..) 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 fbcf9af79a..1a41002f91 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 @@ -50,6 +50,9 @@ tests = [ testProperty "PerasCertDiffusion smoke test" prop_smoke ] +perasTestCfg :: PerasCfg TestBlock +perasTestCfg = makePerasCfg Nothing + instance Arbitrary (Point TestBlock) where arbitrary = -- Sometimes pick the genesis point @@ -73,15 +76,16 @@ instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where instance WithId (PerasCert blk) PerasRoundNo where getId = pcCertRound -newCertDB :: (IOLike m, StandardHash blk) => [PerasCert blk] -> m (PerasCertDB m blk) -newCertDB certs = do +newCertDB :: + (IOLike m, StandardHash blk) => PerasCfg blk -> [PerasCert blk] -> m (PerasCertDB m blk) +newCertDB perasCfg certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do let validatedCert = ValidatedPerasCert { vpcCert = cert - , vpcCertBoost = boostPerCert + , vpcCertBoost = perasCfgWeightBoost perasCfg } result <- PerasCertDB.addCert db validatedCert case result of @@ -118,8 +122,8 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = , m [PerasCert TestBlock] ) mkPoolInterfaces = do - outboundPool <- newCertDB certs - inboundPool <- newCertDB [] + outboundPool <- newCertDB perasTestCfg certs + inboundPool <- newCertDB perasTestCfg [] let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool 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..9320f52c5c 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 @@ -1050,6 +1050,7 @@ generator loe genBlock m@Model{..} = let roundNo = case Model.maxPerasRoundNo dbModel of Nothing -> PerasRoundNo 0 Just (PerasRoundNo r) -> PerasRoundNo (r + 1) + boost <- PerasWeight <$> choose (2, 4) pure $ ValidatedPerasCert { vpcCert = @@ -1057,7 +1058,7 @@ generator loe genBlock m@Model{..} = { pcCertRound = roundNo , pcCertBoostedBlock = blockPoint blk } - , vpcCertBoost = boostPerCert + , vpcCertBoost = boost } genBounds :: Gen (StreamFrom blk, StreamTo blk) 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 756fcf967d..81f4b066bb 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 @@ -39,6 +39,9 @@ tests = [ adjustQuickCheckTests (* 100) $ testProperty "q-d" $ prop_qd ] +perasTestCfg :: PerasCfg TestBlock +perasTestCfg = makePerasCfg Nothing + prop_qd :: Actions Model -> Property prop_qd actions = QC.monadic f $ property () <$ runActions actions where @@ -76,7 +79,7 @@ instance StateModel Model where { pcCertRound = roundNo , pcCertBoostedBlock = boostedBlock } - , vpcCertBoost = boostPerCert + , vpcCertBoost = perasCfgWeightBoost perasTestCfg } genPoint :: Gen (Point TestBlock) From 283fcfd4c0b94f83e173c245fe0f91cc76782233 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 10 Sep 2025 21:30:49 +0200 Subject: [PATCH 54/68] Refactor ChainDB q-s-m test to carry gap blocks between commands Extends the ChainDB model with generator state to support carrying gap blocks in state machine tests. This increases the chances of generating and adding (possibly out-of-order) branching sequences of blocks. This, in turn increases the chances of observing the event where the chain selection logic switches from a longer to a shorter (but heavier) chain containing a boosted block. --- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 224 +++++++++++++----- 1 file changed, 163 insertions(+), 61 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 9320f52c5c..045891aa0b 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 @@ -89,6 +89,7 @@ import Data.Functor.Classes (Eq1, Show1) import Data.Functor.Identity (Identity) import Data.List (sortOn) import qualified Data.List.NonEmpty as NE +import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Ord (Down (..)) @@ -176,10 +177,18 @@ import Test.Util.WithEq Abstract model -------------------------------------------------------------------------------} +-- | A randomly generated value that gets persisted between steps, so that we +-- can carry generator state forward between commands. See 'GenState' below for +-- more details. +newtype Persistent a = Persistent {unPersistent :: a} + deriving (Eq, Show, Functor) + -- | Commands data Cmd blk it flr - = AddBlock blk - | AddPerasCert (ValidatedPerasCert blk) + = -- | Add a block, with (possibly) some gap blocks before it being created. + AddBlock blk (Persistent [blk]) + | -- | Add a Peras cert for a block, with (possibly) some gap blocks before it being created. + AddPerasCert (ValidatedPerasCert blk) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -405,8 +414,8 @@ run :: m (Success blk (TestIterator m blk) (TestFollower m blk)) run cfg env@ChainDBEnv{varDB, ..} cmd = readTVarIO varDB >>= \st@ChainDBState{chainDB = chainDB@ChainDB{..}, internal} -> case cmd of - AddBlock blk -> Point <$> advanceAndAdd st blk - AddPerasCert cert -> Unit <$> addPerasCertSync chainDB cert + AddBlock blk _ -> Point <$> advanceAndAdd st blk + AddPerasCert cert _ -> Unit <$> addPerasCertSync chainDB cert GetCurrentChain -> Chain <$> atomically getCurrentChain GetTipBlock -> MbBlock <$> getTipBlock GetTipHeader -> MbHeader <$> getTipHeader @@ -611,7 +620,7 @@ instance Eq IsValidResult where (Just _, Nothing) -> False {------------------------------------------------------------------------------- - Instantiating the semantics + Responses -------------------------------------------------------------------------------} -- | Responses are either successful termination or an error. @@ -628,6 +637,26 @@ instance (TestConstraints blk, Eq it, Eq flr) => Eq (Resp blk it flr) where Resp (Right a) == Resp (Right a') = a == a' _ == _ = False +{------------------------------------------------------------------------------- + Bitraversable instances +-------------------------------------------------------------------------------} + +TH.deriveBifunctor ''Cmd +TH.deriveBifoldable ''Cmd +TH.deriveBitraversable ''Cmd + +TH.deriveBifunctor ''Success +TH.deriveBifoldable ''Success +TH.deriveBitraversable ''Success + +TH.deriveBifunctor ''Resp +TH.deriveBifoldable ''Resp +TH.deriveBitraversable ''Resp + +{------------------------------------------------------------------------------- + Instantiating the semantics +-------------------------------------------------------------------------------} + type DBModel blk = Model.Model blk -- We can't reuse 'run' because the 'ChainDB' API uses 'STM'. Instead, we call @@ -640,8 +669,8 @@ runPure :: DBModel blk -> (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) + 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) @@ -728,22 +757,6 @@ iters = bifoldMap (: []) (const []) flrs :: Bitraversable t => t it flr -> [flr] flrs = bifoldMap (const []) (: []) -{------------------------------------------------------------------------------- - Bitraversable instances --------------------------------------------------------------------------------} - -TH.deriveBifunctor ''Cmd -TH.deriveBifoldable ''Cmd -TH.deriveBitraversable ''Cmd - -TH.deriveBifunctor ''Success -TH.deriveBifoldable ''Success -TH.deriveBitraversable ''Success - -TH.deriveBifunctor ''Resp -TH.deriveBifoldable ''Resp -TH.deriveBitraversable ''Resp - {------------------------------------------------------------------------------- Model -------------------------------------------------------------------------------} @@ -760,12 +773,69 @@ type FollowerRef blk m r = Reference (Opaque (TestFollower m blk)) r -- | Mapping between iterator references and mocked followers type KnownFollowers blk m r = RefEnv (Opaque (TestFollower m blk)) FollowerId r +-- | Generator state to be carried forward between commands +-- +-- NOTE: some of our generators benefit from carrying state between commands. +-- However, 'quickcheck-state-machine' does not provide much support for this, +-- so we manually carry it around as part of the evolving SUT's model--even if +-- it's technically not part of the actual model we are trying to test against. +-- +-- TODO: Explore if this can be improved by tweaking the API of +-- 'quickcheck-state-machine' to allow for the same functionality to exist +-- under the hood. +data GenState blk + = GenState + { seenBlocks :: Map (HeaderHash blk) blk + -- ^ Blocks that have been generated but not yet added to the ChainDB, e.g., + -- gap blocks generated by 'genBlockAfterGap', or boosted blocks generated by + -- 'genAddPerasCert'. We don't want to discard these because they can be used + -- to fill gaps between existing blocks added via 'AddBlock', simulating + -- blocks and certificates arriving out of order. + } + deriving Generic + +deriving instance + ( ToExpr blk + , ToExpr (HeaderHash blk) + ) => + ToExpr (GenState blk) + +deriving instance (Show blk, Show (HeaderHash blk)) => Show (GenState blk) + +emptyGenState :: GenState blk +emptyGenState = + GenState + { seenBlocks = Map.empty + } + +-- | Use the extra state stored in a generated command to update a model's +-- 'GenState' accordingly. +updateGenState :: + HasHeader blk => + At Cmd blk m r -> + GenState blk -> + GenState blk +updateGenState cmd gs = + case unAt cmd of + AddBlock _ (Persistent blks) -> saveSeenBlocks blks gs + AddPerasCert _ (Persistent blks) -> saveSeenBlocks blks gs + _ -> gs + where + saveSeenBlocks blks gs' = + gs' + { seenBlocks = + Map.union + (Map.fromList [(blockHash blk, blk) | blk <- blks]) + (seenBlocks gs') + } + -- | Execution model data Model blk m r = Model { dbModel :: DBModel blk , knownIters :: KnownIters blk m r , knownFollowers :: KnownFollowers blk m r , modelConfig :: Opaque (TopLevelConfig blk) + , genState :: GenState blk } deriving Generic @@ -784,6 +854,7 @@ initModel loe cfg initLedger = , knownIters = RE.empty , knownFollowers = RE.empty , modelConfig = QSM.Opaque cfg + , genState = emptyGenState } -- | Key property of the model is that we can go from real to mock responses @@ -871,6 +942,7 @@ lockstep model@Model{..} cmd (At resp) = } where (mockResp, dbModel') = step model cmd + genState' = updateGenState cmd genState newIters = RE.fromList $ zip (iters resp) (iters mockResp) newFollowers = RE.fromList $ zip (flrs resp) (flrs mockResp) model' = case unAt cmd of @@ -879,18 +951,21 @@ lockstep model@Model{..} cmd (At resp) = Close -> model { dbModel = dbModel' + , genState = genState' , knownIters = RE.empty , knownFollowers = RE.empty } WipeVolatileDB -> model { dbModel = dbModel' + , genState = genState' , knownIters = RE.empty , knownFollowers = RE.empty } _ -> model { dbModel = dbModel' + , genState = genState' , knownIters = knownIters `RE.union` newIters , knownFollowers = knownFollowers `RE.union` newFollowers } @@ -899,14 +974,12 @@ lockstep model@Model{..} cmd (At resp) = Generator -------------------------------------------------------------------------------} -type BlockGen blk m = Model blk m Symbolic -> Gen blk - -- | Generate a 'Cmd' generator :: forall blk m. TestConstraints blk => LoE () -> - BlockGen blk m -> + (Model blk m Symbolic -> Gen (blk, Persistent [blk])) -> Model blk m Symbolic -> Gen (At Cmd blk m Symbolic) generator loe genBlock m@Model{..} = @@ -917,7 +990,7 @@ generator loe genBlock m@Model{..} = LoEDisabled -> 10 -- The LoE does not yet support Peras. LoEEnabled () -> 0 - in (freq, AddPerasCert <$> genAddPerasCert) + in (freq, 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) @@ -973,7 +1046,7 @@ generator loe genBlock m@Model{..} = followers = RE.keys knownFollowers genRandomPoint :: Gen (RealPoint blk) - genRandomPoint = blockRealPoint <$> genBlock m + genRandomPoint = blockRealPoint . fst <$> genBlock m blocksInDB :: Map.Map (HeaderHash blk) blk blocksInDB = Model.blocks dbModel @@ -994,7 +1067,7 @@ generator loe genBlock m@Model{..} = anchor <- elements $ AF.AnchorGenesis : fmap AF.anchorFromBlock immutableBlocks - blk <- genBlock m + (blk, _) <- genBlock m tip <- frequency [ (1, pure $ Chain.headHash immutableChain) @@ -1033,6 +1106,7 @@ generator loe genBlock m@Model{..} = genGetIsValid :: Gen (Cmd blk it flr) genGetIsValid = GetIsValid <$> genRealPoint + genGetBlockComponent :: Gen (Cmd blk it flr) genGetBlockComponent = do pt <- genRealPoint @@ -1041,25 +1115,41 @@ generator loe genBlock m@Model{..} = then GetGCedBlockComponent pt else GetBlockComponent pt - genAddBlock = AddBlock <$> genBlock m + genAddBlock :: Gen (Cmd blk it flr) + genAddBlock = do + (blk, gapBlks) <- genBlock m + pure $ AddBlock blk gapBlks - genAddPerasCert :: Gen (ValidatedPerasCert blk) + genAddPerasCert :: Gen (Cmd blk it flr) genAddPerasCert = do -- TODO chain condition? - blk <- genBlock m + (blk, gapBlks) <- genBlock m let roundNo = case Model.maxPerasRoundNo dbModel of Nothing -> PerasRoundNo 0 Just (PerasRoundNo r) -> PerasRoundNo (r + 1) - boost <- PerasWeight <$> choose (2, 4) + -- Generate an almost-always-valid boost, i.e., below the maximum rollback + let k = unPerasWeight (maxRollbackWeight secParam) + boost <- + PerasWeight + <$> frequency + [ (10, choose (1, k - 1)) + , (1, choose (k, k + 1)) + ] + -- Include the boosted block itself in the persisted seenBlocks + let seenBlks = fmap (blk :) gapBlks + pure $ - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk - } - , vpcCertBoost = boost - } + AddPerasCert + ( ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boost + } + ) + seenBlks genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = @@ -1302,7 +1392,7 @@ sm :: TestConstraints blk => LoE () -> ChainDBEnv IO blk -> - BlockGen blk IO -> + (Model blk IO Symbolic -> Gen (blk, Persistent [blk])) -> TopLevelConfig blk -> ExtLedgerState blk EmptyMK -> StateMachine @@ -1486,21 +1576,25 @@ type Blk = TestBlock -- ChainDB, blocks are added /out of order/, while in the ImmutableDB, they -- must be added /in order/. This generator can thus not be reused for the -- ImmutableDB. -genBlk :: ImmutableDB.ChunkInfo -> BlockGen Blk m +genBlk :: ImmutableDB.ChunkInfo -> Model Blk m r -> Gen (TestBlock, Persistent [TestBlock]) genBlk chunkInfo Model{..} = frequency - [ (if empty then 0 else 1, genAlreadyInChain) - , (5, genAppendToCurrentChain) - , (5, genFitsOnSomewhere) - , (3, genGap) + [ (if noBlocksInChainDB then 0 else 1, withoutGapBlocks genAlreadyInChain) + , (if noSavedGapBlocks then 0 else 20, withoutGapBlocks genGapBlock) + , (5, withoutGapBlocks genAppendToCurrentChain) + , (5, withoutGapBlocks genFitsOnSomewhere) + , (3, genBlockAfterGap) ] where blocksInChainDB = Model.blocks dbModel + noBlocksInChainDB = Map.null blocksInChainDB + + savedGapBlocks = seenBlocks genState + noSavedGapBlocks = Map.null savedGapBlocks + withoutGapBlocks = fmap (,Persistent []) + modelSupportsEBBs = ImmutableDB.chunkInfoSupportsEBBs chunkInfo canContainEBB = const modelSupportsEBBs -- TODO: we could be more precise - empty :: Bool - empty = Map.null blocksInChainDB - genBody :: Gen TestBody genBody = do isValid <- @@ -1533,20 +1627,28 @@ genBlk chunkInfo Model{..} = Nothing -> genFirstBlock Just _ -> genAlreadyInChain >>= genFitsOn - -- A block that doesn't fit onto a block in the ChainDB, but it creates a - -- gap of a couple of blocks between genesis or an existing block in the - -- ChainDB. We generate it by generating a few intermediary blocks first, - -- which we don't add. But the chance exists that we will generate them - -- again later on. - genGap :: Gen TestBlock - genGap = do + -- A block that doesn't fit onto a block in the ChainDB, but it creates a gap + -- of a couple of blocks between genesis or an existing block in the ChainDB. + -- We generate it by generating a few intermediary blocks first, which we + -- don't add just yet. These are in turn returned and stored as seen blocks + -- in the generator state of the model. We can sample from these later on to + -- (hopefully) fill the gaps. + genBlockAfterGap :: Gen (TestBlock, Persistent [TestBlock]) + genBlockAfterGap = do gapSize <- choose (1, 3) start <- genFitsOnSomewhere - go gapSize start + go gapSize start [] where - go :: Int -> TestBlock -> Gen TestBlock - go 0 b = return b - go n b = genFitsOn b >>= go (n - 1) + go :: Int -> TestBlock -> [TestBlock] -> Gen (TestBlock, Persistent [TestBlock]) + go 0 tip gapBlks = return (tip, Persistent gapBlks) + go n tip gapBlks = do + tip' <- genFitsOn tip + go (n - 1) tip' (tip : gapBlks) + + -- An intermediate gap block that was generated by 'genGap' but stored for + -- later in the model's generator state. + genGapBlock :: Gen TestBlock + genGapBlock = elements (Map.elems savedGapBlocks) -- Generate a block or EBB fitting on genesis genFirstBlock :: Gen TestBlock From 495247e65652e7ffe1111e3e8030c1a75e0db100 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Fri, 12 Sep 2025 13:53:54 +0200 Subject: [PATCH 55/68] Tweak generation frequencies in ChainDB q-s-m tests This commit increases the generation frequencies of both the 'genAddBlock' and 'genAddPerasCert' constructions to help producing denser chains of blocks. This way, some of the events that were harder to trigger (especially TagSwitchedToShorterChain) are much more common now: * Before: Tags (5784 in total): 39.83% TagGetIsValidJust 29.72% TagChainSelReprocessKeptSelection 27.92% TagGetIsValidNothing 2.42% TagChainSelReprocessChangedSelection 0.10% TagSwitchedToShorterChain * After: Tags (5202 in total): 38.66% TagGetIsValidJust 27.87% TagChainSelReprocessKeptSelection 26.43% TagGetIsValidNothing 5.71% TagChainSelReprocessChangedSelection 1.33% TagSwitchedToShorterChain --- .../Test/Ouroboros/Storage/ChainDB/StateMachine.hs | 4 ++-- 1 file changed, 2 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 045891aa0b..de18ad79d3 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 @@ -985,9 +985,9 @@ generator :: generator loe genBlock m@Model{..} = At <$> frequency - [ (30, genAddBlock) + [ (100, genAddBlock) , let freq = case loe of - LoEDisabled -> 10 + LoEDisabled -> 100 -- The LoE does not yet support Peras. LoEEnabled () -> 0 in (freq, genAddPerasCert) From 17b913274c35c7e5fc76e8e19b5f1e0d9ae7c55d Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 15 Sep 2025 12:50:05 +0200 Subject: [PATCH 56/68] Generate security parameter for ChainDB q-s-m test on the fly After analysing the effect of varying the security parameter (`k`) of the ChainDB state machine tests (currently hardcoded with 2), we have observed a tension between: 1) generating enough tests exercising the new Peras behavior where the chain selection mechanism switches to a shorter but heavier chain (cert boost is derived from k and must be large enough to overcome the weight of a longer chain), and 2) generating enough tests exercising the ImmutableDB logic (the chain must have at least k blocks) Here are some empirical results: k -> P(switch to shorter chain), P(generate a chain with >= k blocks) k=2 -> ~1.3%, ~40% k=3 -> ~1.9%, ~20% k=4 -> ~2.4%, ~9% k=5 -> ~2.5%, ~3% k=10 -> ~3%, ~0.05% We believe that the sweet spot between both desiderata appears to be around `k=2` and `k=4`. This commit introduces a random generator for `k` using a geometric distribution to bias the randomly generated `k`s to be relatively small, while still allowing larger ones to appear from time to time. Under the current parameters, roughly 75% of the tests use `k<=4`; ``` Security Parameter (k) (10000 in total): 50.82% 2 23.83% 3 12.62% 4 6.69% 5 3.08% 6 1.54% 7 0.74% 8 0.37% 9 0.16% 10 0.06% 11 0.05% 12 0.02% 13 0.01% 14 0.01% 17 ``` Yielding the following distributions for 1) and 2), respectively: ``` Tags (5161 in total): 39.35% TagGetIsValidJust 29.22% TagChainSelReprocessKeptSelection 25.91% TagGetIsValidNothing 3.88% TagChainSelReprocessChangedSelection 1.65% TagSwitchedToShorterChain <- HERE ``` ``` Chain length >= k (10000 in total): 73.25% False 26.75% True <- HERE ``` --- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 78 ++++++++++++------- .../ChainDB/StateMachine/Utils/RunOnRepl.hs | 6 +- .../Test/Ouroboros/Storage/ChainDB/Unit.hs | 10 ++- 3 files changed, 63 insertions(+), 31 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 de18ad79d3..6feac5f35a 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 @@ -73,7 +73,7 @@ module Test.Ouroboros.Storage.ChainDB.StateMachine , tests ) where -import Cardano.Ledger.BaseTypes (knownNonZeroBounded) +import Cardano.Ledger.BaseTypes (unNonZero, unsafeNonZero) import Codec.Serialise (Serialise) import Control.Monad (replicateM, void) import Control.ResourceRegistry @@ -151,6 +151,7 @@ import qualified Test.Ouroboros.Storage.ChainDB.Model as Model import Test.Ouroboros.Storage.Orphans () import Test.Ouroboros.Storage.TestBlock import Test.QuickCheck hiding (forAll) +import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC import Test.StateMachine import qualified Test.StateMachine.Labelling as C @@ -1709,40 +1710,59 @@ genBlk chunkInfo Model{..} = ) ] +genSecurityParam :: Gen SecurityParam +genSecurityParam = + SecurityParam + . unsafeNonZero + . fromIntegral + . (+ 2) -- shift to the right to avoid degenerate cases + <$> geometric 0.5 -- range in [0, +inf); mean = 1/p = 2 + where + geometric :: Double -> Gen Int + geometric p + | p <= 0 || p > 1 = error "p must be in (0,1]" + | otherwise = do + u <- choose (0.0, 1.0) + let k = floor (log u / log (1 - p)) + return k + {------------------------------------------------------------------------------- Top-level tests -------------------------------------------------------------------------------} -mkTestCfg :: ImmutableDB.ChunkInfo -> TopLevelConfig TestBlock -mkTestCfg (ImmutableDB.UniformChunkSize chunkSize) = - mkTestConfig (SecurityParam $ knownNonZeroBounded @2) chunkSize +mkTestCfg :: SecurityParam -> ImmutableDB.ChunkInfo -> TopLevelConfig TestBlock +mkTestCfg k (ImmutableDB.UniformChunkSize chunkSize) = + mkTestConfig k chunkSize envUnused :: ChainDBEnv m blk envUnused = error "ChainDBEnv used during command generation" smUnused :: LoE () -> + SecurityParam -> ImmutableDB.ChunkInfo -> StateMachine (Model Blk IO) (At Cmd Blk IO) IO (At Resp Blk IO) -smUnused loe chunkInfo = +smUnused loe k chunkInfo = sm loe envUnused (genBlk chunkInfo) - (mkTestCfg chunkInfo) + (mkTestCfg k chunkInfo) testInitExtLedger prop_sequential :: LoE () -> SmallChunkInfo -> Property prop_sequential loe smallChunkInfo@(SmallChunkInfo chunkInfo) = - forAllCommands (smUnused loe chunkInfo) Nothing $ - runCmdsLockstep loe smallChunkInfo + QC.forAll genSecurityParam $ \k -> + forAllCommands (smUnused loe k chunkInfo) Nothing $ + runCmdsLockstep loe k smallChunkInfo runCmdsLockstep :: LoE () -> + SecurityParam -> SmallChunkInfo -> QSM.Commands (At Cmd Blk IO) (At Resp Blk IO) -> Property -runCmdsLockstep loe (SmallChunkInfo chunkInfo) cmds = +runCmdsLockstep loe k (SmallChunkInfo chunkInfo) cmds = QC.monadicIO $ do let -- Current test case command names. @@ -1750,15 +1770,15 @@ runCmdsLockstep loe (SmallChunkInfo chunkInfo) cmds = ctcCmdNames = fmap (show . cmdName . QSM.getCommand) $ QSM.unCommands cmds (hist, prop) <- QC.run $ test cmds - prettyCommands (smUnused loe chunkInfo) hist + prettyCommands (smUnused loe k chunkInfo) hist $ tabulate "Tags" - (map show $ tag (execCmds (QSM.initModel (smUnused loe chunkInfo)) cmds)) + (map show $ tag (execCmds (QSM.initModel (smUnused loe k chunkInfo)) cmds)) $ tabulate "Command sequence length" [show $ length ctcCmdNames] $ tabulate "Commands" ctcCmdNames $ prop where - testCfg = mkTestCfg chunkInfo + testCfg = mkTestCfg k chunkInfo test :: QSM.Commands (At Cmd Blk IO) (At Resp Blk IO) -> @@ -1821,26 +1841,30 @@ runCmdsLockstep loe (SmallChunkInfo chunkInfo) cmds = fses <- atomically $ traverse readTMVar nodeDBs let modelChain = Model.currentChain $ dbModel model + secParam = unNonZero (maxRollbacks (configSecurityParam testCfg)) prop = counterexample (show (configSecurityParam testCfg)) $ counterexample ("Model chain: " <> condense modelChain) $ counterexample ("TraceEvents: " <> unlines (map show trace)) $ tabulate "Chain length" [show (Chain.length modelChain)] $ - tabulate "TraceEvents" (map traceEventName trace) $ - res === Ok - .&&. prop_trace testCfg (dbModel model) trace - .&&. counterexample - "ImmutableDB is leaking file handles" - (Mock.numOpenHandles (nodeDBsImm fses) === 0) - .&&. counterexample - "VolatileDB is leaking file handles" - (Mock.numOpenHandles (nodeDBsVol fses) === 0) - .&&. counterexample - "LedgerDB is leaking file handles" - (Mock.numOpenHandles (nodeDBsLgr fses) === 0) - .&&. counterexample - "There were registered clean-up actions" - (remainingCleanups === 0) + tabulate "Security Parameter (k)" [show secParam] $ + tabulate "Chain length >= k" [show (Chain.length modelChain >= fromIntegral secParam)] $ + tabulate "TraceEvents" (map traceEventName trace) $ + res + === Ok + .&&. prop_trace testCfg (dbModel model) trace + .&&. counterexample + "ImmutableDB is leaking file handles" + (Mock.numOpenHandles (nodeDBsImm fses) === 0) + .&&. counterexample + "VolatileDB is leaking file handles" + (Mock.numOpenHandles (nodeDBsVol fses) === 0) + .&&. counterexample + "LedgerDB is leaking file handles" + (Mock.numOpenHandles (nodeDBsLgr fses) === 0) + .&&. counterexample + "There were registered clean-up actions" + (remainingCleanups === 0) return (hist, prop) prop_trace :: TopLevelConfig Blk -> DBModel Blk -> [TraceEvent Blk] -> Property diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs index 96055b09ee..369f3974cd 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine/Utils/RunOnRepl.hs @@ -87,6 +87,7 @@ import Ouroboros.Consensus.Block , EpochNo (EpochNo) , SlotNo (SlotNo) ) +import Ouroboros.Consensus.Config (SecurityParam) import Ouroboros.Consensus.Storage.ChainDB ( ChainType (TentativeChain) , LoE @@ -142,8 +143,9 @@ pattern Command cmd rsp xs = quickCheckCmdsLockStep :: LoE () -> + SecurityParam -> SmallChunkInfo -> Commands (StateMachine.At Cmd TestBlock IO) (StateMachine.At Resp TestBlock IO) -> IO () -quickCheckCmdsLockStep loe chunkInfo cmds = - quickCheck $ runCmdsLockstep loe chunkInfo cmds +quickCheckCmdsLockStep loe k chunkInfo cmds = + quickCheck $ runCmdsLockstep loe k chunkInfo cmds diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs index 6811e7c427..4bf1a91c21 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Unit.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,12 +8,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Test.Ouroboros.Storage.ChainDB.Unit (tests) where +import Cardano.Ledger.BaseTypes (knownNonZeroBounded) import Cardano.Slotting.Slot (WithOrigin (..)) import Control.Monad (replicateM, unless, void) import Control.Monad.Except @@ -35,6 +38,7 @@ import Ouroboros.Consensus.Config ( TopLevelConfig , configSecurityParam ) +import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Ledger.SupportsProtocol @@ -243,8 +247,9 @@ runModelIO :: API.LoE () -> ModelM TestBlock a -> IO () runModelIO loe expr = toAssertion (runModel newModel topLevelConfig expr) where chunkInfo = ImmutableDB.simpleChunkInfo 100 + k = SecurityParam (knownNonZeroBounded @2) newModel = Model.empty loe testInitExtLedger - topLevelConfig = mkTestCfg chunkInfo + topLevelConfig = mkTestCfg k chunkInfo -- | Helper function to run the test against the actual chain database and -- translate to something that HUnit likes. @@ -252,7 +257,8 @@ runSystemIO :: SystemM TestBlock IO a -> IO () runSystemIO expr = runSystem withChainDbEnv expr >>= toAssertion where chunkInfo = ImmutableDB.simpleChunkInfo 100 - topLevelConfig = mkTestCfg chunkInfo + k = SecurityParam (knownNonZeroBounded @2) + topLevelConfig = mkTestCfg k chunkInfo withChainDbEnv = withTestChainDbEnv topLevelConfig chunkInfo $ convertMapKind testInitExtLedger newtype TestFailure = TestFailure String deriving Show From 5fad77766828e06762061c2eec864d8195671be7 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Oct 2025 14:30:15 +0200 Subject: [PATCH 57/68] Propagate feature flags down to NodeKernelArgs Brings in cardano-base and propagates a set of `CardanoFeatureFlag`s from the top-level `RunNodeArgs` down to the `NodeKernelArgs`. This is currently needed by an upcoming PR to the GSM to distinguish whether having an established PerasCertDiffusion connection with a given peer is necessary or not when trying to decide if such peer is idling. --- cabal.project | 2 +- flake.lock | 6 +++--- .../ouroboros-consensus-diffusion.cabal | 1 + .../Ouroboros/Consensus/Node.hs | 13 +++++++++++++ .../Ouroboros/Consensus/NodeKernel.hs | 3 +++ .../Test/ThreadNet/Network.hs | 1 + 6 files changed, 22 insertions(+), 4 deletions(-) diff --git a/cabal.project b/cabal.project index 90d4e52497..2f020dd837 100644 --- a/cabal.project +++ b/cabal.project @@ -16,7 +16,7 @@ index-state: -- Bump this if you need newer packages from Hackage , hackage.haskell.org 2025-07-22T09:13:54Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-08-21T09:41:03Z + , cardano-haskell-packages 2025-10-07T11:20:00Z packages: ouroboros-consensus diff --git a/flake.lock b/flake.lock index 70f4df31ec..3ced387e4d 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1755770112, - "narHash": "sha256-BE9+swBBPBi9iRQNqsUNUjS02nyRF+OwfCkhIjted6I=", + "lastModified": 1759837865, + "narHash": "sha256-g8SMcVN1v51Muz6a+xJkB92mPx1jsg+sjHKvQ3Wj/jY=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "7af503772adf627cd23be5431440a0ffae74de52", + "rev": "9a46cacd941c108492cd4cee5d29735e8cd8ee65", "type": "github" }, "original": { diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 1ffccbe235..3db1710ae1 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -77,6 +77,7 @@ library build-depends: base >=4.14 && <4.22, bytestring >=0.10 && <0.13, + cardano-base, cardano-slotting, cborg ^>=0.2.2, containers >=0.5 && <0.8, 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 6d3d649d6b..0dfa364333 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 @@ -60,6 +60,7 @@ module Ouroboros.Consensus.Node , openChainDB ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag) import qualified Cardano.Network.Diffusion as Cardano.Diffusion import Cardano.Network.Diffusion.Configuration (ChainSyncIdleTimeout (..)) import qualified Cardano.Network.Diffusion.Policies as Cardano.Diffusion @@ -84,6 +85,7 @@ import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing) +import Data.Set (Set) import Data.Time (NominalDiffTime) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block @@ -232,6 +234,8 @@ data RunNodeArgs m addrNTN addrNTC blk = RunNodeArgs -- ^ Network PeerSharing miniprotocol willingness flag , rnGetUseBootstrapPeers :: STM m UseBootstrapPeers , rnGenesisConfig :: GenesisConfig + , rnFeatureFlags :: Set CardanoFeatureFlag + -- ^ Enabled experimental features } -- | Arguments that usually only tests /directly/ specify. @@ -319,6 +323,8 @@ data LowLevelRunNodeArgs m addrNTN addrNTC blk , llrnPublicPeerSelectionStateVar :: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN) , llrnLdbFlavorArgs :: Complete LedgerDbFlavorArgs m -- ^ The flavor arguments + , llrnFeatureFlags :: Set CardanoFeatureFlag + -- ^ Enabled experimental features } data NodeDatabasePaths @@ -570,6 +576,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = gsmAntiThunderingHerd keepAliveRng cfg + llrnFeatureFlags rnTraceConsensus btime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) @@ -847,6 +854,7 @@ mkNodeKernelArgs :: StdGen -> StdGen -> TopLevelConfig blk -> + Set CardanoFeatureFlag -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockchainTime m -> InFutureCheck.SomeHeaderInFutureCheck m blk -> @@ -866,6 +874,7 @@ mkNodeKernelArgs gsmAntiThunderingHerd rng cfg + featureFlags tracers btime chainSyncFutureCheck @@ -885,6 +894,7 @@ mkNodeKernelArgs { tracers , registry , cfg + , featureFlags , btime , chainDB , initChainDB = nodeInitChainDB @@ -1003,6 +1013,7 @@ stdLowLevelRunNodeArgsIO { rnProtocolInfo , rnPeerSharing , rnGenesisConfig + , rnFeatureFlags } $(SafeWildCards.fields 'StdRunNodeArgs) = do llrnBfcSalt <- stdBfcSaltIO @@ -1053,6 +1064,8 @@ stdLowLevelRunNodeArgsIO Diffusion.dcPublicPeerSelectionVar srnDiffusionConfiguration , llrnLdbFlavorArgs = srnLdbFlavorArgs + , llrnFeatureFlags = + rnFeatureFlags } where networkMagic :: NetworkMagic 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 d7c460ba11..f529392bcf 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 @@ -27,6 +27,7 @@ module Ouroboros.Consensus.NodeKernel , toConsensusMode ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag) import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Cardano.Network.PeerSelection.LocalRootPeers @@ -51,6 +52,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust, mapMaybe) import Data.Proxy +import Data.Set (Set) import qualified Data.Text as Text import Data.Void (Void) import Ouroboros.Consensus.Block hiding (blockMatchesHeader) @@ -195,6 +197,7 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs { tracers :: Tracers m (ConnectionId addrNTN) addrNTC blk , registry :: ResourceRegistry m , cfg :: TopLevelConfig blk + , featureFlags :: Set CardanoFeatureFlag , btime :: BlockchainTime m , chainDB :: ChainDB m blk , initChainDB :: StorageConfig blk -> InitChainDB m blk -> m () 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 42810dbfc1..d4bfe1eb5d 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 @@ -1045,6 +1045,7 @@ runThreadNetwork { tracers , registry , cfg = pInfoConfig + , featureFlags = mempty , btime , chainDB , initChainDB = nodeInitChainDB From 69d709d0e42db16c2c182e306c5dc652d6f4cc9d Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 18:50:03 +0200 Subject: [PATCH 58/68] Bump ouroboros-network to match peras-staging/pr-5202 Bumps the external ouroboros-network source-repository-package to the updated peras-staging/pr-5202, which incorporates the changes from: https://github.com/IntersectMBO/ouroboros-network/pull/5202 In addition, it tweak call sites of `nodeToNodeProtocols` to match its updated signature, passing down the enabled feature flags. --- cabal.project | 4 ++-- .../Ouroboros/Consensus/Network/NodeToNode.hs | 14 ++++++++++++-- .../Ouroboros/Consensus/Node.hs | 4 ++-- 3 files changed, 16 insertions(+), 6 deletions(-) diff --git a/cabal.project b/cabal.project index 2f020dd837..17c612c568 100644 --- a/cabal.project +++ b/cabal.project @@ -59,8 +59,8 @@ allow-newer: source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: 8dfff7b8916f7a56b2a3773438d5e5530c780710 - --sha256: sha256-wMDq19G1SW4+puuQUUjgaULSou4+r7wJj6evnWoW/Xk= + tag: peras-staging/pr-5202 + --sha256: sha256-nTbjunQaqt6/syzSKw24Lne50083dI2SZFirG2/1T9U= subdir: ouroboros-network ouroboros-network-protocols 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 426a379b22..f6e2d2e4ba 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 @@ -39,6 +39,7 @@ module Ouroboros.Consensus.Network.NodeToNode , initiatorAndResponder ) where +import Cardano.Base.FeatureFlags (CardanoFeatureFlag) import Codec.CBOR.Decoding (Decoder) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) @@ -54,6 +55,7 @@ import qualified Data.ByteString.Lazy as BSL import Data.Hashable (Hashable) import Data.Int (Int64) import Data.Map.Strict (Map) +import Data.Set (Set) import Data.Void (Void) import qualified Network.Mux as Mux import Network.TypedProtocol.Codec @@ -994,13 +996,15 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke -- on the protocol version, but it eventually may; this is why @_version@ is -- currently unused. initiator :: + Set CardanoFeatureFlag -> MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorMode addr b m a Void -initiator miniProtocolParameters version versionData Apps{..} = +initiator featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols + featureFlags miniProtocolParameters -- TODO: currently consensus is using 'ConnectionId' for its 'peer' type. -- This is currently ok, as we might accept multiple connections from the @@ -1017,6 +1021,8 @@ initiator miniProtocolParameters version versionData Apps{..} = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aTxSubmission2Client version ctx))) , perasCertDiffusionProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aPerasCertDiffusionClient version ctx))) + , perasVoteDiffusionProtocol = + error "perasVoteDiffusionProtocol: not implemented" , keepAliveProtocol = (InitiatorProtocolOnly (MiniProtocolCb (\ctx -> aKeepAliveClient version ctx))) , peerSharingProtocol = @@ -1032,13 +1038,15 @@ initiator miniProtocolParameters version versionData Apps{..} = -- on the protocol version, but it eventually may; this is why @_version@ is -- currently unused. initiatorAndResponder :: + Set CardanoFeatureFlag -> MiniProtocolParameters -> NodeToNodeVersion -> NodeToNodeVersionData -> Apps m addr b b b b b b a c -> OuroborosBundleWithExpandedCtx 'Mux.InitiatorResponderMode addr b m a c -initiatorAndResponder miniProtocolParameters version versionData Apps{..} = +initiatorAndResponder featureFlags miniProtocolParameters version versionData Apps{..} = nodeToNodeProtocols + featureFlags miniProtocolParameters ( NodeToNodeProtocols { chainSyncProtocol = @@ -1061,6 +1069,8 @@ initiatorAndResponder miniProtocolParameters version versionData Apps{..} = (MiniProtocolCb (\initiatorCtx -> aPerasCertDiffusionClient version initiatorCtx)) (MiniProtocolCb (\responderCtx -> aPerasCertDiffusionServer version responderCtx)) ) + , perasVoteDiffusionProtocol = + error "perasVoteDiffusionProtocol: not implemented" , 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 0dfa364333..69c68903fb 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 @@ -740,7 +740,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = version llrnVersionDataNTN ( \versionData -> - NTN.initiator miniProtocolParams version versionData + NTN.initiator llrnFeatureFlags miniProtocolParams version versionData -- Initiator side won't start responder side of Peer -- Sharing protocol so we give a dummy implementation -- here. @@ -755,7 +755,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = version llrnVersionDataNTN ( \versionData -> - NTN.initiatorAndResponder miniProtocolParams version versionData $ + NTN.initiatorAndResponder llrnFeatureFlags miniProtocolParams version versionData $ ntnApps blockVersion ) | (version, blockVersion) <- Map.toList llrnNodeToNodeVersions From 31706610ef7f0f3ea8e93c62ffe83bd5d0fbacc3 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 6 Oct 2025 20:31:42 +0200 Subject: [PATCH 59/68] Break Idling into its own module --- .../bench/ChainSync-client-bench/Main.hs | 3 +- ouroboros-consensus/ouroboros-consensus.cabal | 2 ++ .../MiniProtocol/ChainSync/Client.hs | 22 +------------ .../Ouroboros/Consensus/MiniProtocol/Util.hs | 5 +++ .../Consensus/MiniProtocol/Util/Idling.hs | 31 +++++++++++++++++++ 5 files changed, 41 insertions(+), 22 deletions(-) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index 70854581a8..9d983608d2 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -37,6 +37,7 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck import Ouroboros.Consensus.MiniProtocol.ChainSync.Server ( chainSyncServerForFollower ) +import qualified Ouroboros.Consensus.MiniProtocol.Util.Idling as Idling import Ouroboros.Consensus.Node.NetworkProtocolVersion ( NodeToNodeVersion ) @@ -158,7 +159,7 @@ oneBenchRun , CSClient.headerMetricsTracer = nullTracer , CSClient.setCandidate = writeTVar varCandidate , CSClient.setLatestSlot = \_ -> pure () - , CSClient.idling = CSClient.noIdling + , CSClient.idling = Idling.noIdling , CSClient.loPBucket = CSClient.noLoPBucket , CSClient.jumping = CSClient.noJumping } diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index e67214f5c7..8ffffe4c72 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -196,6 +196,8 @@ library Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + Ouroboros.Consensus.MiniProtocol.Util + Ouroboros.Consensus.MiniProtocol.Util.Idling Ouroboros.Consensus.Node.GsmState Ouroboros.Consensus.Node.InitStorage Ouroboros.Consensus.Node.NetworkProtocolVersion 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 fcb0e25388..0c0d46c4ee 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 @@ -73,7 +73,6 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client , Jumping.noJumping , chainSyncStateFor , newChainSyncClientHandleCollection - , noIdling , noLoPBucket , viewChainSyncState ) where @@ -122,6 +121,7 @@ import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCh import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State +import Ouroboros.Consensus.MiniProtocol.Util.Idling (Idling (..)) import Ouroboros.Consensus.Node.GsmState (GsmState (..)) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Peras.Weight (emptyPerasWeightSnapshot) @@ -272,26 +272,6 @@ chainSyncStateFor :: chainSyncStateFor varHandles peer = readTVar . cschState . (Map.! peer) =<< readTVar varHandles --- | Interface for the ChainSync client to manipulate the idling flag in --- 'ChainSyncState'. -data Idling m = Idling - { idlingStart :: !(m ()) - -- ^ Mark the peer as being idle. - , idlingStop :: !(m ()) - -- ^ Mark the peer as not being idle. - } - deriving stock Generic - -deriving anyclass instance IOLike m => NoThunks (Idling m) - --- | No-op implementation, for tests. -noIdling :: Applicative m => Idling m -noIdling = - Idling - { idlingStart = pure () - , idlingStop = pure () - } - -- | Interface to the LoP implementation for the ChainSync client. data LoPBucket m = LoPBucket { lbPause :: !(m ()) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs new file mode 100644 index 0000000000..58fa7d2161 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util.hs @@ -0,0 +1,5 @@ +module Ouroboros.Consensus.MiniProtocol.Util + ( module Ouroboros.Consensus.MiniProtocol.Util.Idling + ) where + +import Ouroboros.Consensus.MiniProtocol.Util.Idling diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs new file mode 100644 index 0000000000..3962d26dd6 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/Util/Idling.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Ouroboros.Consensus.MiniProtocol.Util.Idling + ( Idling (..) + , noIdling + ) where + +import GHC.Generics (Generic) +import Ouroboros.Consensus.Util.IOLike (IOLike, NoThunks) + +-- | Interface to manipulate the idling flag in the client state of a peer. +data Idling m = Idling + { idlingStart :: !(m ()) + -- ^ Mark the peer as being idle. + , idlingStop :: !(m ()) + -- ^ Mark the peer as not being idle. + } + deriving stock Generic + +deriving anyclass instance IOLike m => NoThunks (Idling m) + +-- | No-op implementation, for tests. +noIdling :: Applicative m => Idling m +noIdling = + Idling + { idlingStart = pure () + , idlingStop = pure () + } From df386c5894ad8b5003b8e0a693ef0fba2b11facf Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 6 Oct 2025 20:44:07 +0200 Subject: [PATCH 60/68] Introduce O.C.MiniProtocol.ObjectDiffusion.Inbound.State --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../ObjectDiffusion/Inbound/State.hs | 127 ++++++++++++++++++ 2 files changed, 128 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 8ffffe4c72..acbca582c1 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -192,6 +192,7 @@ library Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs new file mode 100644 index 0000000000..83d8d26c8f --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundState (..) + , initObjectDiffusionInboundState + , ObjectDiffusionInboundHandle (..) + , ObjectDiffusionInboundHandleCollection (..) + , ObjectDiffusionInboundStateView (..) + , newObjectDiffusionInboundHandleCollection + , bracketObjectDiffusionInbound + ) +where + +import Control.Monad.Class.MonadThrow (bracket) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block (BlockSupportsProtocol, HasHeader, Header) +import Ouroboros.Consensus.MiniProtocol.Util.Idling (Idling (..)) +import Ouroboros.Consensus.Util.IOLike + ( IOLike (..) + , MonadSTM (..) + , StrictTVar + , modifyTVar + , newTVar + , newTVarIO + , readTVar + ) + +-- | An ObjectDiffusion inbound client state that's used by other components. +-- +-- NOTE: 'blk' is not needed for now, but we keep it for future use. +data ObjectDiffusionInboundState blk = ObjectDiffusionInboundState + { odisIdling :: !Bool + -- ^ Whether we have received all objects from a peer + } + deriving stock Generic + +deriving anyclass instance + ( HasHeader blk + , NoThunks (Header blk) + ) => + NoThunks (ObjectDiffusionInboundState blk) + +initObjectDiffusionInboundState :: ObjectDiffusionInboundState blk +initObjectDiffusionInboundState = ObjectDiffusionInboundState{odisIdling = True} + +-- | An interface to an ObjectDiffusion inbound client that's used by other components. +data ObjectDiffusionInboundHandle m blk = ObjectDiffusionInboundHandle + { odihState :: !(StrictTVar m (ObjectDiffusionInboundState blk)) + -- ^ Data shared between the client and external components. + } + deriving stock Generic + +deriving anyclass instance + ( IOLike m + , HasHeader blk + , NoThunks (Header blk) + ) => + NoThunks (ObjectDiffusionInboundHandle m blk) + +-- | A collection of ObjectDiffusion inbound client handles for the peers of this node. +data ObjectDiffusionInboundHandleCollection peer m blk = ObjectDiffusionInboundHandleCollection + { odihcMap :: !(STM m (Map peer (ObjectDiffusionInboundHandle m blk))) + -- ^ A map containing the handles for the peers in the collection + , odihcAddHandle :: !(peer -> ObjectDiffusionInboundHandle m blk -> STM m ()) + -- ^ Add the handle for the given peer to the collection + , odihcRemoveHandle :: !(peer -> STM m ()) + -- ^ Remove the handle for the given peer from the collection + } + deriving stock Generic + +newObjectDiffusionInboundHandleCollection :: + (Ord peer, IOLike m, NoThunks peer, BlockSupportsProtocol blk) => + STM m (ObjectDiffusionInboundHandleCollection peer m blk) +newObjectDiffusionInboundHandleCollection = do + handlesMap <- newTVar mempty + return + ObjectDiffusionInboundHandleCollection + { odihcMap = readTVar handlesMap + , odihcAddHandle = \peer handle -> + modifyTVar handlesMap (Map.insert peer handle) + , odihcRemoveHandle = \peer -> + modifyTVar handlesMap (Map.delete peer) + } + +-- | Interface for the ObjectDiffusion client to its state allocated by +-- 'bracketObjectDiffusionInbound'. +data ObjectDiffusionInboundStateView m = ObjectDiffusionInboundStateView + { odisvIdling :: !(Idling m) + } + deriving stock Generic + +bracketObjectDiffusionInbound :: + forall m peer blk a. + (IOLike m, HasHeader blk, NoThunks (Header blk)) => + ObjectDiffusionInboundHandleCollection peer m blk -> + peer -> + (ObjectDiffusionInboundStateView m -> m a) -> + m a +bracketObjectDiffusionInbound handles peer body = do + odiState <- newTVarIO initObjectDiffusionInboundState + bracket (acquireContext odiState) releaseContext body + where + acquireContext odiState = atomically $ do + odihcAddHandle handles peer $ + ObjectDiffusionInboundHandle + { odihState = odiState + } + return + ObjectDiffusionInboundStateView + { odisvIdling = + Idling + { idlingStart = atomically $ modifyTVar odiState $ \s -> s{odisIdling = True} + , idlingStop = atomically $ modifyTVar odiState $ \s -> s{odisIdling = False} + } + } + + releaseContext _ = atomically $ do + odihcRemoveHandle handles peer From 46451bbb3431fadc889a0d6d84d98a726343cdda Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 10:29:46 +0200 Subject: [PATCH 61/68] Introduce PerasCertDiffusion type synonyms --- .../MiniProtocol/ObjectDiffusion/PerasCert.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) 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 index ba0ba934a2..5c024618b0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasCert.hs @@ -8,10 +8,14 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert , PerasCertDiffusionInboundPipelined , PerasCertDiffusionOutbound , PerasCertDiffusion + , PerasCertDiffusionInboundState + , PerasCertDiffusionInboundHandle + , PerasCertDiffusionInboundHandleCollection ) where import Ouroboros.Consensus.Block import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound import Ouroboros.Consensus.Storage.PerasCertDB.API @@ -39,3 +43,12 @@ type PerasCertDiffusionOutbound blk m a = type PerasCertDiffusion blk = ObjectDiffusion PerasRoundNo (PerasCert blk) + +type PerasCertDiffusionInboundState blk = + ObjectDiffusionInboundState blk + +type PerasCertDiffusionInboundHandle m blk = + ObjectDiffusionInboundHandle m blk + +type PerasCertDiffusionInboundHandleCollection peer m blk = + ObjectDiffusionInboundHandleCollection peer m blk From 587c5665d8f1b9f71b18d90165b16876183f5b10 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Oct 2025 10:20:04 +0200 Subject: [PATCH 62/68] Generalize chainSyncState to peerState in the GSM --- .../Ouroboros/Consensus/Node/GSM.hs | 32 ++++++++----------- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- .../test/consensus-test/Test/Consensus/GSM.hs | 2 +- .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 2 +- 4 files changed, 17 insertions(+), 21 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 780602118b..6608ade58c 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 @@ -56,8 +56,6 @@ import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry import qualified Ouroboros.Consensus.Ledger.Basics as L import Ouroboros.Consensus.Node.GsmState import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) -import Ouroboros.Consensus.Util.NormalForm.StrictTVar (StrictTVar) -import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as StrictSTM import System.FS.API ( HasFS , createDirectoryIfMissing @@ -97,7 +95,7 @@ data CandidateVersusSelection WhetherCandidateIsBetter !Bool deriving (Eq, Show) -data GsmView m upstreamPeer selection chainSyncState = GsmView +data GsmView m upstreamPeer selection peerState = GsmView { antiThunderingHerd :: Maybe StdGen -- ^ An initial seed used to randomly increase 'minCaughtUpDuration' by up -- to 15% every transition from Syncing to CaughtUp, in order to avoid a @@ -108,13 +106,13 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView STM m ( selection -> - chainSyncState -> + peerState -> 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 + , peerIsIdle :: peerState -> Bool , durationUntilTooOld :: Maybe (selection -> m DurationFromNow) -- ^ How long from now until the selection will be so old that the node -- should exit the @CaughtUp@ state @@ -123,10 +121,8 @@ data GsmView m upstreamPeer selection chainSyncState = GsmView , equivalent :: selection -> selection -> Bool -- ^ Whether the two selections are equivalent for the purpose of the -- Genesis State Machine - , getChainSyncStates :: - STM m (Map.Map upstreamPeer (StrictTVar m chainSyncState)) - -- ^ The current ChainSync state with the latest candidates from the - -- upstream peers + , getPeerStates :: STM m (Map.Map upstreamPeer peerState) + -- ^ The current peer state with the latest candidates from the upstream peers , getCurrentSelection :: STM m selection -- ^ The node's current selection , minCaughtUpDuration :: NominalDiffTime @@ -244,7 +240,7 @@ realGsmEntryPoints tracerArgs gsmView = , peerIsIdle , durationUntilTooOld , equivalent - , getChainSyncStates + , getPeerStates , getCurrentSelection , minCaughtUpDuration , setCaughtUpPersistentMark @@ -370,12 +366,13 @@ realGsmEntryPoints tracerArgs gsmView = blockUntilCaughtUp :: STM m (TraceGsmEvent tracedSelection) blockUntilCaughtUp = do - -- STAGE 1: all ChainSync clients report no subsequent headers - varsState <- getChainSyncStates - states <- traverse StrictSTM.readTVar varsState + -- STAGE 1: all peers are idle, which means that + -- * all ChainSync clients report no subsequent headers, and + -- * all PerasCertDiffusion clients report no subsequent certificates + peerStates <- getPeerStates check $ - not (Map.null states) - && all peerIsIdle states + not (Map.null peerStates) + && all peerIsIdle peerStates -- STAGE 2: no candidate is better than the node's current -- selection @@ -388,16 +385,15 @@ realGsmEntryPoints tracerArgs gsmView = -- block; general Praos reasoning ensures that won't take particularly -- long. selection <- getCurrentSelection - candidates <- traverse StrictSTM.readTVar varsState candidateOverSelection <- getCandidateOverSelection let ok candidate = WhetherCandidateIsBetter False == candidateOverSelection selection candidate - check $ all ok candidates + check $ all ok peerStates pure $ GsmEventEnterCaughtUp - (Map.size states) + (Map.size peerStates) (cnvSelection selection) -- STAGE 3: the previous stages weren't so slow that the idler 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 f529392bcf..02363263aa 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 @@ -292,7 +292,7 @@ initNodeKernel <&> \wd (_headers, lst) -> GSM.getDurationUntilTooOld wd (getTipSlot lst) , GSM.equivalent = (==) `on` (AF.headPoint . fst) - , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles + , GSM.getPeerStates = traverse (readTVar . cschState) =<< cschcMap varChainSyncHandles , GSM.getCurrentSelection = do headers <- ChainDB.getCurrentChainWithTime chainDB extLedgerState <- ChainDB.getCurrentLedger chainDB 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 44a57f4c32..8941958814 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs @@ -142,7 +142,7 @@ setupGsm isHaaSatisfied vars = do , GSM.peerIsIdle = isIdling , GSM.durationUntilTooOld = Just durationUntilTooOld , GSM.equivalent = (==) -- unsound, but harmless in this test - , GSM.getChainSyncStates = readTVar varStates + , GSM.getPeerStates = traverse readTVar =<< readTVar varStates , GSM.getCurrentSelection = readTVar varSelection , GSM.minCaughtUpDuration = thrashLimit , GSM.setCaughtUpPersistentMark = \b -> 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 a58923bd60..6ae1c4d0d4 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 @@ -283,7 +283,7 @@ mkGsmEntryPoints varChainSyncHandles chainDB writeGsmState = { GSM.getCandidateOverSelection = pure candidateOverSelection , GSM.peerIsIdle = csIdling , GSM.equivalent = (==) `on` AF.headPoint - , GSM.getChainSyncStates = fmap cschState <$> cschcMap varChainSyncHandles + , GSM.getPeerStates = traverse readTVar =<< fmap cschState <$> cschcMap varChainSyncHandles , GSM.getCurrentSelection = ChainDB.getCurrentChain chainDB , -- Make sure that we stay in CaughtUp for the duration of the test once we -- have entered it. From 78f7e5c7a464d207f1edaf81be70e91329d1d26a Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Oct 2025 16:42:10 +0200 Subject: [PATCH 63/68] Store NodeToNodeVersion in GSM peer state components --- .../Ouroboros/Consensus/NodeKernel.hs | 2 +- .../Genesis/Tests/DensityDisconnect.hs | 2 ++ .../Consensus/Genesis/Tests/LoE/CaughtUp.hs | 10 ++++----- .../MiniProtocol/ChainSync/Client.hs | 1 + .../MiniProtocol/ChainSync/Client/State.hs | 6 ++++++ .../ObjectDiffusion/Inbound/State.hs | 21 ++++++++++++++----- .../Ouroboros/Consensus/Util/Orphans.hs | 4 ++++ 7 files changed, 35 insertions(+), 11 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 02363263aa..f9260688f2 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 @@ -27,7 +27,7 @@ module Ouroboros.Consensus.NodeKernel , toConsensusMode ) where -import Cardano.Base.FeatureFlags (CardanoFeatureFlag) +import Cardano.Base.FeatureFlags (CardanoFeatureFlag (..)) import Cardano.Network.ConsensusMode (ConsensusMode (..)) import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Cardano.Network.PeerSelection.LocalRootPeers diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs index bacebe644f..eeb39af6f7 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs @@ -192,6 +192,7 @@ prop_densityDisconnectStatic = { csCandidate = frag , csLatestSlot = SJust (AF.headSlot frag) , csIdling = False + , csNodeToNodeVersion = maxBound } gen = do gt <- genChains (QC.choose (1, 4)) @@ -431,6 +432,7 @@ evolveBranches EvolvingPeers{k, sgen, peers = initialPeers, fullTree} = { csCandidate = attachTimeUsingTestConfig csCandidate , csIdling = False , csLatestSlot = SJust (AF.headSlot csCandidate) + , csNodeToNodeVersion = maxBound } -- Run GDD. (loeFrag, suffixes) = 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 6ae1c4d0d4..e87ca885ec 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 @@ -142,16 +142,15 @@ run = withRegistry \registry -> do -- Then, send C. atomically $ modifyTVar (cschState hdl) $ \s -> - ChainSyncState + s { csCandidate = csCandidate s AF.:> attachSlotTime cfg (getHeader blkC) , csLatestSlot = pure $ NotOrigin $ blockSlot blkC - , csIdling = csIdling s } addBlk blkC -- Finally, roll back to the initial fragment and idle. - atomically $ modifyTVar (cschState hdl) $ \_s -> - ChainSyncState + atomically $ modifyTVar (cschState hdl) $ \s -> + s { csCandidate = initialFrag , csLatestSlot = pure $ AF.headSlot initialFrag , csIdling = True @@ -169,7 +168,7 @@ run = withRegistry \registry -> do -- Finally, idle. atomically $ modifyTVar (cschState hdl) $ \s -> - ChainSyncState + s { csCandidate = csCandidate s , csLatestSlot = csLatestSlot s , csIdling = True @@ -223,6 +222,7 @@ mkTestChainSyncClientHandle frag = do { csCandidate = frag , csIdling = False , csLatestSlot = pure $ AF.headSlot frag + , csNodeToNodeVersion = maxBound } varJumping <- newTVar $ Disengaged DisengagedDone varJumpInfo <- newTVar Nothing 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 0c0d46c4ee..85b0b1a487 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 @@ -385,6 +385,7 @@ bracketChainSyncClient { csCandidate = AF.Empty AF.AnchorGenesis , csLatestSlot = SNothing , csIdling = False + , csNodeToNodeVersion = version } withCSJCallbacks :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs index d7dd82db7b..7077aba1b4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs @@ -37,6 +37,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) import Ouroboros.Consensus.Node.GsmState (GsmState) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) import Ouroboros.Consensus.Util.IOLike ( IOLike , NoThunks (..) @@ -74,6 +75,11 @@ data ChainSyncState blk = ChainSyncState -- processing it further, and the latest slot may refer to a header beyond -- the forecast horizon while the candidate fragment isn't extended yet, to -- signal to GDD that the density is known up to this slot. + , csNodeToNodeVersion :: !NodeToNodeVersion + -- ^ Negotiated version of the protocol with the peer. + -- + -- This is used to determine later on whether other mini-protocols are + -- expected to run in parallel with this one. } deriving stock Generic diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs index 83d8d26c8f..58402da64f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound/State.hs @@ -24,6 +24,7 @@ import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block (BlockSupportsProtocol, HasHeader, Header) import Ouroboros.Consensus.MiniProtocol.Util.Idling (Idling (..)) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) import Ouroboros.Consensus.Util.IOLike ( IOLike (..) , MonadSTM (..) @@ -39,7 +40,12 @@ import Ouroboros.Consensus.Util.IOLike -- NOTE: 'blk' is not needed for now, but we keep it for future use. data ObjectDiffusionInboundState blk = ObjectDiffusionInboundState { odisIdling :: !Bool - -- ^ Whether we have received all objects from a peer + -- ^ Whether the client is currently idling + , odisNodeToNodeVersion :: !NodeToNodeVersion + -- ^ Negotiated version of the protocol with the peer. + -- + -- This is used to determine later on whether other mini-protocols are + -- expected to run in parallel with this one. } deriving stock Generic @@ -49,8 +55,12 @@ deriving anyclass instance ) => NoThunks (ObjectDiffusionInboundState blk) -initObjectDiffusionInboundState :: ObjectDiffusionInboundState blk -initObjectDiffusionInboundState = ObjectDiffusionInboundState{odisIdling = True} +initObjectDiffusionInboundState :: NodeToNodeVersion -> ObjectDiffusionInboundState blk +initObjectDiffusionInboundState version = + ObjectDiffusionInboundState + { odisIdling = True + , odisNodeToNodeVersion = version + } -- | An interface to an ObjectDiffusion inbound client that's used by other components. data ObjectDiffusionInboundHandle m blk = ObjectDiffusionInboundHandle @@ -101,12 +111,13 @@ data ObjectDiffusionInboundStateView m = ObjectDiffusionInboundStateView bracketObjectDiffusionInbound :: forall m peer blk a. (IOLike m, HasHeader blk, NoThunks (Header blk)) => + NodeToNodeVersion -> ObjectDiffusionInboundHandleCollection peer m blk -> peer -> (ObjectDiffusionInboundStateView m -> m a) -> m a -bracketObjectDiffusionInbound handles peer body = do - odiState <- newTVarIO initObjectDiffusionInboundState +bracketObjectDiffusionInbound version handles peer body = do + odiState <- newTVarIO (initObjectDiffusionInboundState version) bracket (acquireContext odiState) releaseContext body where acquireContext odiState = atomically $ do diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index a623d0b9a9..71bc19a5f8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -31,6 +31,7 @@ import NoThunks.Class , OnlyCheckWhnfNamed (..) , allNoThunks ) +import Ouroboros.Consensus.Node.NetworkProtocolVersion (NodeToNodeVersion) import Ouroboros.Network.Util.ShowProxy import System.FS.API (SomeHasFS) import System.FS.API.Types (FsPath, Handle) @@ -85,6 +86,9 @@ instance NoThunks a => NoThunks (MultiSet a) where showTypeOf _ = "MultiSet" wNoThunks ctxt = wNoThunks ctxt . MultiSet.toMap +-- NOTE: fixed in https://github.com/IntersectMBO/ouroboros-network/pull/5214 +instance NoThunks NodeToNodeVersion + {------------------------------------------------------------------------------- fs-api -------------------------------------------------------------------------------} From 7ca058f23c8ad225e61f4d926557a2ce0489e13e Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 10:40:42 +0200 Subject: [PATCH 64/68] Introduce O.C.Node.GSM.PeerState --- .../ouroboros-consensus-diffusion.cabal | 3 + .../Ouroboros/Consensus/Node/GSM/PeerState.hs | 78 +++++++++++++++++++ 2 files changed, 81 insertions(+) create mode 100644 ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 3db1710ae1..8f4159e77e 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -63,6 +63,7 @@ library Ouroboros.Consensus.Node.Exit Ouroboros.Consensus.Node.ExitPolicy Ouroboros.Consensus.Node.GSM + Ouroboros.Consensus.Node.GSM.PeerState Ouroboros.Consensus.Node.Genesis Ouroboros.Consensus.Node.Recovery Ouroboros.Consensus.Node.RethrowPolicy @@ -97,8 +98,10 @@ library random, resource-registry ^>=0.1, safe-wild-cards ^>=1.0, + semialign, serialise ^>=0.2, text, + these, time, transformers, typed-protocols:{stateful, typed-protocols}, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs new file mode 100644 index 0000000000..defc3abe33 --- /dev/null +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM/PeerState.hs @@ -0,0 +1,78 @@ +module Ouroboros.Consensus.Node.GSM.PeerState + ( GsmPeerState (..) + , maybeChainSyncState + , maybePerasCertDiffusionState + , mkGsmPeerStates + , gsmPeerIsIdle + ) +where + +import Cardano.Base.FeatureFlags (CardanoFeatureFlag (..)) +import Data.Align (Semialign (..)) +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.These (These (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State + ( ChainSyncClientHandle (..) + , ChainSyncClientHandleCollection (..) + , ChainSyncState (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundHandle (..) + , ObjectDiffusionInboundHandleCollection (..) + , ObjectDiffusionInboundState (..) + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert (PerasCertDiffusionInboundState) +import Ouroboros.Consensus.Util.IOLike (MonadSTM (..), readTVar) +import Ouroboros.Network.NodeToNode.Version (isPerasEnabled) + +-- | State about peers we are connected to during initialization. +newtype GsmPeerState blk = GsmPeerState + { unGsmPeerState :: + These + (ChainSyncState blk) + (PerasCertDiffusionInboundState blk) + } + +-- | Retrieve the 'ChainSync' state of this peer, if such a connection is established. +maybeChainSyncState :: GsmPeerState blk -> Maybe (ChainSyncState blk) +maybeChainSyncState (GsmPeerState these) = + case these of + This csState -> Just csState + That _ -> Nothing + These csState _ -> Just csState + +-- | Retrieve the 'PerasCertDiffusion' state of this peer, if such a connection is established. +maybePerasCertDiffusionState :: GsmPeerState blk -> Maybe (PerasCertDiffusionInboundState blk) +maybePerasCertDiffusionState (GsmPeerState these) = + case these of + This _ -> Nothing + That pcdState -> Just pcdState + These _ pcdState -> Just pcdState + +-- | Construct a 'GsmPeerState' for all peers we are connected to. +mkGsmPeerStates :: + (Ord peer, MonadSTM m) => + ChainSyncClientHandleCollection peer m blk -> + ObjectDiffusionInboundHandleCollection peer m blk -> + STM m (Map peer (GsmPeerState blk)) +mkGsmPeerStates csHandles pcdHandles = do + csPeerStates <- traverse (readTVar . cschState) =<< cschcMap csHandles + pcdPeerStates <- traverse (readTVar . odihState) =<< odihcMap pcdHandles + pure (GsmPeerState <$> align csPeerStates pcdPeerStates) + +-- | Determine whether our connections to this peer are idle. +gsmPeerIsIdle :: Set CardanoFeatureFlag -> GsmPeerState blk -> Bool +gsmPeerIsIdle featureFlags (GsmPeerState these) = + case these of + -- We have both ChainSync and PerasCertDiffusion connections => idle if both are idling + These csState pcdState -> csIdling csState && odisIdling pcdState + -- Only a ChainSync connection is available => idle if the ChainSync connection is idling + This csState | not (perasIsEnabled csState) -> csIdling csState + -- We will soon establish a PerasCertDiffusion connection => not idling + This _ -> False + -- We will soon establish a ChainSync connection => not idling + That _ -> False + where + -- Is the Peras feature flag enabled and the peer is compatible with it? + perasIsEnabled csState = isPerasEnabled featureFlags (csNodeToNodeVersion csState) From 4e3115c7c5415c30b1633f280fe242e889b3f91a Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Oct 2025 11:39:03 +0200 Subject: [PATCH 65/68] Enhance GSM view with PerasCertDiffusion information --- .../Ouroboros/Consensus/Network/NodeToNode.hs | 35 ++++++++---- .../Ouroboros/Consensus/NodeKernel.hs | 56 ++++++++++++++----- .../MiniProtocol/ObjectDiffusion/Inbound.hs | 24 +++++++- .../MiniProtocol/ObjectDiffusion/Smoke.hs | 10 ++++ 4 files changed, 97 insertions(+), 28 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 f6e2d2e4ba..8b8f27b7b2 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 @@ -71,6 +71,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.Inbound.State + ( ObjectDiffusionInboundStateView + , bracketObjectDiffusionInbound + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert @@ -214,6 +218,7 @@ data Handlers m addr blk = Handlers , hPerasCertDiffusionClient :: NodeToNodeVersion -> ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> ConnectionId addr -> PerasCertDiffusionInboundPipelined blk m () , hPerasCertDiffusionServer :: @@ -316,7 +321,7 @@ mkHandlers (mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader getMempool) (getMempoolWriter getMempool) version - , hPerasCertDiffusionClient = \version controlMessageSTM peer -> + , hPerasCertDiffusionClient = \version controlMessageSTM state peer -> objectDiffusionInbound (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionInboundTracer tracers)) ( perasCertDiffusionMaxFifoLength miniProtocolParameters @@ -326,6 +331,7 @@ mkHandlers (makePerasCertPoolWriterFromChainDB $ getChainDB) version controlMessageSTM + state , hPerasCertDiffusionServer = \version peer -> objectDiffusionOutbound (contramap (TraceLabelPeer peer) (Node.perasCertDiffusionOutboundTracer tracers)) @@ -864,17 +870,22 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke } channel = do labelThisThread "PerasCertDiffusionClient" - ((), trailing) <- - runPipelinedPeerWithLimits - (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) - (cPerasCertDiffusionCodec (mkCodecs version)) - blPerasCertDiffusion - timeLimitsObjectDiffusion - channel - ( objectDiffusionInboundPeerPipelined - (hPerasCertDiffusionClient version controlMessageSTM them) - ) - return (NoInitiatorResult, trailing) + bracketObjectDiffusionInbound + version + (getPerasCertDiffusionHandles kernel) + them + $ \state -> do + ((), trailing) <- + runPipelinedPeerWithLimits + (TraceLabelPeer them `contramap` tPerasCertDiffusionTracer) + (cPerasCertDiffusionCodec (mkCodecs version)) + blPerasCertDiffusion + timeLimitsObjectDiffusion + channel + ( objectDiffusionInboundPeerPipelined + (hPerasCertDiffusionClient version controlMessageSTM state them) + ) + return (NoInitiatorResult, trailing) aPerasCertDiffusionServer :: NodeToNodeVersion -> 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 f9260688f2..cff137e5a6 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 @@ -50,7 +50,7 @@ import Data.Functor ((<&>)) import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (isJust, isNothing, mapMaybe) import Data.Proxy import Data.Set (Set) import qualified Data.Text as Text @@ -82,8 +82,16 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck import Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck ( SomeHeaderInFutureCheck ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundHandleCollection (..) + , newObjectDiffusionInboundHandleCollection + ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + ( PerasCertDiffusionInboundHandleCollection + ) import Ouroboros.Consensus.Node.GSM (GsmNodeKernelArgs (..)) import qualified Ouroboros.Consensus.Node.GSM as GSM +import Ouroboros.Consensus.Node.GSM.PeerState (gsmPeerIsIdle, maybeChainSyncState, mkGsmPeerStates) import Ouroboros.Consensus.Node.Genesis ( GenesisNodeKernelArgs (..) , LoEAndGDDConfig (..) @@ -175,6 +183,9 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel -- from it with 'GSM.gsmStateToLedgerJudgement'. , getChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk -- ^ The kill handle and exposed state for each ChainSync client. + , getPerasCertDiffusionHandles :: + ObjectDiffusionInboundHandleCollection (ConnectionId addrNTN) m blk + -- ^ The exposed state for each Peras CertDiffusion client. , getPeerSharingRegistry :: PeerSharingRegistry addrNTN m -- ^ Read the current peer sharing registry, used for interacting with -- the PeerSharing protocol @@ -235,6 +246,7 @@ initNodeKernel args@NodeKernelArgs { registry , cfg + , featureFlags , tracers , chainDB , initChainDB @@ -257,6 +269,7 @@ initNodeKernel , mempool , peerSharingRegistry , varChainSyncHandles + , varPerasCertDiffusionHandles , varGsmState } = st @@ -275,24 +288,34 @@ initNodeKernel GSM.GsmView { GSM.antiThunderingHerd = Just gsmAntiThunderingHerd , 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 + weights <- forgetFingerprint <$> ChainDB.getPerasWeightSnapshot chainDB + pure $ \(headers, _lst) peerState -> do + case csCandidate <$> maybeChainSyncState peerState of + Just candidate + -- The candidate does not intersect with our current chain. + -- This is a precondition for 'WhetherCandidateIsBetter'. + | isNothing (AF.intersectionPoint headers candidate) -> + GSM.CandidateDoesNotIntersect + -- The candidate is better than our current chain. + | preferAnchoredCandidate (configBlock cfg) weights headers candidate -> + GSM.WhetherCandidateIsBetter True + -- The candidate is not better than our current chain. + | otherwise -> + GSM.WhetherCandidateIsBetter False + Nothing -> + -- We don't have an established ChainSync connection with this peer. + -- We conservatively assume that its candidate is not better than ours. + GSM.WhetherCandidateIsBetter False + , GSM.peerIsIdle = gsmPeerIsIdle featureFlags , GSM.durationUntilTooOld = gsmDurationUntilTooOld <&> \wd (_headers, lst) -> GSM.getDurationUntilTooOld wd (getTipSlot lst) , GSM.equivalent = (==) `on` (AF.headPoint . fst) - , GSM.getPeerStates = traverse (readTVar . cschState) =<< cschcMap varChainSyncHandles + , GSM.getPeerStates = + mkGsmPeerStates + varChainSyncHandles + varPerasCertDiffusionHandles , GSM.getCurrentSelection = do headers <- ChainDB.getCurrentChainWithTime chainDB extLedgerState <- ChainDB.getCurrentLedger chainDB @@ -369,6 +392,7 @@ initNodeKernel , getFetchMode = readFetchMode blockFetchInterface , getGsmState = readTVar varGsmState , getChainSyncHandles = varChainSyncHandles + , getPerasCertDiffusionHandles = varPerasCertDiffusionHandles , getPeerSharingRegistry = peerSharingRegistry , getTracers = tracers , setBlockForging = \a -> atomically . LazySTM.putTMVar blockForgingVar $! a @@ -419,6 +443,8 @@ data InternalState m addrNTN addrNTC blk = IS BlockFetchConsensusInterface (ConnectionId addrNTN) (HeaderWithTime blk) blk m , fetchClientRegistry :: FetchClientRegistry (ConnectionId addrNTN) (HeaderWithTime blk) blk m , varChainSyncHandles :: ChainSyncClientHandleCollection (ConnectionId addrNTN) m blk + , varPerasCertDiffusionHandles :: + PerasCertDiffusionInboundHandleCollection (ConnectionId addrNTN) m blk , varGsmState :: StrictTVar m GSM.GsmState , mempool :: Mempool m blk , peerSharingRegistry :: PeerSharingRegistry addrNTN m @@ -457,6 +483,8 @@ initInternalState newTVarIO gsmState varChainSyncHandles <- atomically newChainSyncClientHandleCollection + varPerasCertDiffusionHandles <- atomically newObjectDiffusionInboundHandleCollection + mempool <- openMempool registry 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 index bba2d07cb0..a368682c40 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/Inbound.hs @@ -38,7 +38,11 @@ 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.Inbound.State + ( ObjectDiffusionInboundStateView (..) + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API +import Ouroboros.Consensus.MiniProtocol.Util.Idling qualified as Idling import Ouroboros.Network.ControlMessage import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound @@ -62,6 +66,8 @@ data TraceObjectDiffusionInbound objectId object TraceObjectDiffusionControlMessage ControlMessage | TraceObjectInboundCanRequestMoreObjects Int | TraceObjectInboundCannotRequestMoreObjects Int + | TraceObjectInboundStartedIdling + | TraceObjectInboundStoppedIdling deriving (Eq, Show) data ObjectDiffusionInboundError @@ -131,13 +137,15 @@ objectDiffusionInbound :: ObjectPoolWriter objectId object m -> NodeToNodeVersion -> ControlMessageSTM m -> + ObjectDiffusionInboundStateView m -> ObjectDiffusionInboundPipelined objectId object m () objectDiffusionInbound tracer (maxFifoLength, maxNumIdsToReq, maxNumObjectsToReq) ObjectPoolWriter{..} _version - controlMessageSTM = + controlMessageSTM + state = ObjectDiffusionInboundPipelined $ do continueWithStateM (go Zero) initialInboundSt where @@ -242,6 +250,12 @@ objectDiffusionInbound -- objectIds. Since this is the only thing to do now, we make this a -- blocking call. traceWith tracer (TraceObjectInboundCannotRequestMoreObjects (natToInt n)) + -- Before blocking, signal to the protocol client that we are idling + -- + -- NOTE this change of state should be made explicit: + -- https://github.com/tweag/cardano-peras/issues/144 + Idling.idlingStart (odisvIdling state) + traceWith tracer TraceObjectInboundStartedIdling pure $ continueWithState goReqObjectIdsBlocking st -- We have pipelined some requests, so there are some replies in flight. @@ -378,7 +392,13 @@ objectDiffusionInbound $ SendMsgRequestObjectIdsBlocking (numToAckOnNextReq st) numIdsToRequest - ( \neCollectedIds -> + ( \neCollectedIds -> do + -- We just got some new object id's, so we are no longer idling + -- + -- NOTE this change of state should be made explicit: + -- https://github.com/tweag/cardano-peras/issues/144 + Idling.idlingStop (odisvIdling state) + traceWith tracer TraceObjectInboundStoppedIdling collectAndContinueWithState (goCollect Zero) st 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 index d2f21c9b66..8e12f01d6d 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs @@ -31,11 +31,15 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound ( objectDiffusionInbound ) +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State + ( ObjectDiffusionInboundStateView (..) + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API ( ObjectPoolReader (..) , ObjectPoolWriter (..) ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound) +import qualified Ouroboros.Consensus.MiniProtocol.Util.Idling as Idling import Ouroboros.Consensus.Util.IOLike ( IOLike , MonadDelay (..) @@ -257,6 +261,11 @@ prop_smoke_object_diffusion controlMessage <- uncheckedNewTVarM Continue let + inboundState = + ObjectDiffusionInboundStateView + { odisvIdling = Idling.noIdling + } + inbound = objectDiffusionInbound tracer @@ -267,6 +276,7 @@ prop_smoke_object_diffusion inboundPoolWriter nodeToNodeVersion (readTVar controlMessage) + inboundState outbound = objectDiffusionOutbound From a14fed3336b622946d4c40d9f5d75df5d2756912 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 09:21:38 +0200 Subject: [PATCH 66/68] Define WithArrivalTime combinator --- .../BlockchainTime/WallClock/Types.hs | 26 +++++++++++++++++++ 1 file changed, 26 insertions(+) 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 e0288d48474e90640d85d4e2b4a88934640df49a Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 12:14:51 +0200 Subject: [PATCH 67/68] Tweak and extend Peras cert field projection typeclasses --- .../Consensus/Block/SupportsPeras.hs | 32 ++++++++++++------- 1 file changed, 21 insertions(+), 11 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 6ed874325f..41adcb03fa 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 #-} @@ -38,6 +38,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.Util import Ouroboros.Consensus.Util.Condense import Quiet (Quiet (..)) @@ -157,20 +158,29 @@ makePerasCfg _ = { perasCfgWeightBoost = boostPerCert } -class StandardHash blk => HasPerasCert cert blk where - getPerasCert :: cert blk -> PerasCert blk +class StandardHash blk => HasPerasCert cert blk | cert -> blk where + getPerasCert :: cert -> PerasCert blk -instance StandardHash blk => HasPerasCert PerasCert blk where +getPerasCertRound :: HasPerasCert cert blk => cert -> PerasRoundNo +getPerasCertRound = pcCertRound . getPerasCert + +getPerasCertBoostedBlock :: HasPerasCert cert blk => cert -> Point blk +getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert + +instance StandardHash blk => HasPerasCert (PerasCert blk) blk where getPerasCert = id -instance StandardHash blk => HasPerasCert ValidatedPerasCert blk where +instance StandardHash blk => HasPerasCert (ValidatedPerasCert blk) blk where getPerasCert = vpcCert -getPerasCertRound :: HasPerasCert cert blk => cert blk -> PerasRoundNo -getPerasCertRound = pcCertRound . getPerasCert +instance HasPerasCert cert blk => HasPerasCert (WithArrivalTime cert) blk where + getPerasCert = getPerasCert . forgetArrivalTime -getPerasCertBoostedBlock :: HasPerasCert cert blk => cert blk -> Point blk -getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert +class HasPerasCertBoost cert blk | cert -> blk where + getPerasCertBoost :: cert -> PerasWeight + +instance HasPerasCertBoost (ValidatedPerasCert blk) blk where + getPerasCertBoost = vpcCertBoost -getPerasCertBoost :: ValidatedPerasCert blk -> PerasWeight -getPerasCertBoost = vpcCertBoost +instance HasPerasCertBoost cert blk => HasPerasCertBoost (WithArrivalTime cert) blk where + getPerasCertBoost = getPerasCertBoost . forgetArrivalTime From a9094193007ab9531e47b1796fa2e65e522faf8f Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Wed, 15 Oct 2025 12:25:09 +0200 Subject: [PATCH 68/68] Wrap validated Peras certificates with arrival time --- .../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 | 43 ++++++++++++++----- .../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 | 7 +-- .../Test/Util/Orphans/ToExpr.hs | 5 +++ .../ObjectDiffusion/PerasCert/Smoke.hs | 36 +++++++++++++--- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 5 ++- .../Ouroboros/Storage/ChainDB/StateMachine.hs | 41 ++++++++++++------ .../Test/Ouroboros/Storage/Orphans.hs | 10 +++++ .../Ouroboros/Storage/PerasCertDB/Model.hs | 5 ++- .../Storage/PerasCertDB/StateMachine.hs | 38 +++++++++++----- 17 files changed, 162 insertions(+), 57 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 8b8f27b7b2..57956f5537 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 @@ -269,6 +269,7 @@ mkHandlers , keepAliveRng , miniProtocolParameters , getDiffusionPipeliningSupport + , systemTime } NodeKernel { getChainDB @@ -328,7 +329,7 @@ mkHandlers , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97 , 10 -- TODO https://github.com/tweag/cardano-peras/issues/97 ) - (makePerasCertPoolWriterFromChainDB $ getChainDB) + (makePerasCertPoolWriterFromChainDB systemTime getChainDB) version controlMessageSTM state 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 69c68903fb..a868b6724a 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 @@ -579,6 +579,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = llrnFeatureFlags rnTraceConsensus btime + systemTime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) historicityCheck chainDB @@ -857,6 +858,7 @@ mkNodeKernelArgs :: Set CardanoFeatureFlag -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockchainTime m -> + SystemTime m -> InFutureCheck.SomeHeaderInFutureCheck m blk -> (m GSM.GsmState -> HistoricityCheck m blk) -> ChainDB m blk -> @@ -877,6 +879,7 @@ mkNodeKernelArgs featureFlags tracers btime + systemTime chainSyncFutureCheck chainSyncHistoricityCheck chainDB @@ -896,6 +899,7 @@ mkNodeKernelArgs , cfg , featureFlags , 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 cff137e5a6..29533108c6 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 @@ -210,6 +210,7 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs , cfg :: TopLevelConfig blk , featureFlags :: Set CardanoFeatureFlag , 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 d4bfe1eb5d..937f705109 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 @@ -1047,6 +1047,7 @@ runThreadNetwork , cfg = pInfoConfig , featureFlags = mempty , 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 99af93eac4..f4f0cb5562 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,8 +11,11 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where +import Control.Monad ((>=>)) import GHC.Exception (throw) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime (WithArrivalTime) +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemTime (..), addArrivalTime) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB @@ -49,13 +52,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 @@ -69,13 +72,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 @@ -101,3 +104,23 @@ validatePerasCerts certs = do case traverse (validatePerasCert perasCfg) 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 f4acfef2a4..a7c5a61665 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 (..) ) @@ -392,7 +393,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) -- ^ TODO docs , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) -- ^ TODO @@ -530,7 +531,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 eb4f9f23ed..9babf8a400 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, HasHeader blk) => 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 f65eee1eee..17a6e941cb 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, StandardHash blk) => 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 eebf03de47..db9b51be67 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 @@ -16,12 +16,13 @@ module Ouroboros.Consensus.Storage.PerasCertDB.API 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 -- ^ TODO docs , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) -- ^ Return the Peras weights in order compare the current selection against @@ -45,7 +46,9 @@ data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB data PerasCertSnapshot blk = PerasCertSnapshot { containsCert :: PerasRoundNo -> Bool -- ^ Do we have the certificate for this round? - , getCertsAfter :: PerasCertTicketNo -> [(ValidatedPerasCert blk, PerasCertTicketNo)] + , getCertsAfter :: + PerasCertTicketNo -> + [(WithArrivalTime (ValidatedPerasCert blk), PerasCertTicketNo)] } -- TODO: Once we store historical certificates on disk, this should (also) track 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 a05cb067ab..3428ce5f64 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 @@ -28,6 +28,7 @@ import qualified Data.Map.Strict as Map 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 @@ -144,7 +145,7 @@ implAddCert :: , StandardHash blk ) => PerasCertDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt @@ -246,13 +247,13 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- | 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)) + { 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. -- -- INVARIANT: In sync with 'pvcsCerts'. - , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk)) + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))) -- ^ The certificates by 'PerasCertTicketNo'. -- -- INVARIANT: In sync with 'pvcsCerts'. 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 1a41002f91..c0db35ff1a 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 @@ -14,6 +14,12 @@ 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.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , SystemTime (..) + , addArrivalTime + , systemTimeCurrent + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert import Ouroboros.Consensus.Storage.PerasCertDB.API @@ -23,7 +29,7 @@ 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 +import Ouroboros.Consensus.Util.IOLike (IOLike, atomically, newTVarIO, stateTVar, throwIO) import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo), StandardHash) import Ouroboros.Network.Point (Block (Block), WithOrigin (..)) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec @@ -76,9 +82,24 @@ instance Arbitrary (Point blk) => Arbitrary (PerasCert blk) where instance WithId (PerasCert blk) PerasRoundNo where getId = pcCertRound +mockSystemTime :: IOLike m => m (SystemTime m) +mockSystemTime = do + varTime <- newTVarIO 0 + return $ + SystemTime + { systemTimeCurrent = + RelativeTime <$> atomically (stateTVar varTime (\t -> (t, t + 1))) + , systemTimeWait = + pure () + } + newCertDB :: - (IOLike m, StandardHash blk) => PerasCfg blk -> [PerasCert blk] -> m (PerasCertDB m blk) -newCertDB perasCfg certs = do + (IOLike m, StandardHash blk) => + PerasCfg blk -> + SystemTime m -> + [PerasCert blk] -> + m (PerasCertDB m blk) +newCertDB perasCfg systemTime certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do @@ -87,7 +108,7 @@ newCertDB perasCfg certs = do { vpcCert = cert , vpcCertBoost = perasCfgWeightBoost perasCfg } - 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") @@ -122,11 +143,12 @@ prop_smoke protocolConstants (ListWithUniqueIds certs) = , m [PerasCert TestBlock] ) mkPoolInterfaces = do - outboundPool <- newCertDB perasTestCfg certs - inboundPool <- newCertDB perasTestCfg [] + systemTime <- mockSystemTime + outboundPool <- newCertDB perasTestCfg systemTime certs + inboundPool <- newCertDB perasTestCfg systemTime [] let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool - inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB systemTime inboundPool getAllInboundPoolContent = do snap <- atomically $ PerasCertDB.getCertSnapshot inboundPool let rawContent = PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) 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..1d04c09b4e 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 6feac5f35a..c66b781c87 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,17 @@ 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 (..) + , SystemTime (..) + , WithArrivalTime + , addArrivalTime + ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -189,7 +195,7 @@ data Cmd blk it flr = -- | Add a block, with (possibly) some gap blocks before it being created. AddBlock blk (Persistent [blk]) | -- | Add a Peras cert for a block, with (possibly) some gap blocks before it being created. - AddPerasCert (ValidatedPerasCert blk) (Persistent [blk]) + AddPerasCert (WithArrivalTime (ValidatedPerasCert blk)) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -1090,6 +1096,11 @@ generator loe genBlock m@Model{..} = empty :: Bool empty = null pointsInDB + genSystemTime :: Gen (SystemTime Gen) + genSystemTime = do + current <- RelativeTime . fromIntegral <$> arbitrary @Word64 + pure $ SystemTime{systemTimeCurrent = return current, systemTimeWait = pure ()} + genRealPoint :: Gen (RealPoint blk) genRealPoint = frequency @@ -1136,21 +1147,23 @@ generator loe genBlock m@Model{..} = [ (10, choose (1, k - 1)) , (1, choose (k, k + 1)) ] + -- Put together the certificate and attach a random arrival time + systemTime <- genSystemTime + validatedCert <- + addArrivalTime systemTime $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boost + } + -- 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 + pure $ AddPerasCert validatedCert 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 f6e7f5cb27..812e031c78 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 @@ -18,13 +18,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 @@ -42,7 +43,7 @@ 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 = model{certs = Set.insert cert 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 81f4b066bb..c301937031 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 @@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -17,12 +18,21 @@ import Control.Monad.State import Control.Tracer (nullTracer) 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 (..) + , SystemTime (..) + , WithArrivalTime + , addArrivalTime + ) 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 @@ -54,7 +64,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 () @@ -68,19 +78,25 @@ instance StateModel Model where ] | otherwise = pure $ Some OpenDB where + genSystemTime :: Gen (SystemTime Gen) + genSystemTime = do + current <- RelativeTime . fromIntegral <$> arbitrary @Word64 + pure $ SystemTime{systemTimeCurrent = return current, systemTimeWait = pure ()} + genAddCert = do roundNo <- PerasRoundNo <$> arbitrary boostedBlock <- genPoint - pure $ - AddCert - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = boostedBlock - } - , vpcCertBoost = perasCfgWeightBoost perasTestCfg - } + systemTime <- genSystemTime + let validatedCert = + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = boostedBlock + } + , vpcCertBoost = perasCfgWeightBoost perasTestCfg + } + AddCert <$> addArrivalTime systemTime validatedCert genPoint :: Gen (Point TestBlock) genPoint =