Scaffolding for Peras certs and PerasCertDB

amesgen · amesgen · commit ea2901f21eb8 · 2025-07-03T15:58:10.000+02:00
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -75,6 +75,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
@@ -254,6 +255,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
@@ -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
@@ -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
@@ -78,6 +78,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
@@ -168,6 +169,8 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
         (Query.getAnyKnownBlock immutableDB volatileDB)
     traceWith tracer $ TraceOpenEvent OpenedLgrDB
 
+    perasCertDB <- PerasCertDB.openDB argsPerasCertDB
+
     varInvalid <- newTVarIO (WithFingerprint Map.empty (Fingerprint 0))
 
     let initChainSelTracer = TraceInitChainSelEvent >$< tracer
@@ -245,6 +248,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do
             , cdbChainSelQueue = chainSelQueue
             , cdbLoE = Args.cdbsLoE cdbSpecificArgs
             , cdbChainSelStarvation = varChainSelStarvation
+            , cdbPerasCertDB = perasCertDB
             }
     h <- fmap CDBHandle $ newTVarIO $ ChainDbOpen env
     let chainDB =
@@ -300,7 +304,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
 
 -- | We use 'runInnerWithTempRegistry' for the component databases.
 innerOpenCont ::
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
@@ -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
@@ -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
 
@@ -719,6 +722,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
@@ -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
@@ -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
diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs
