[Peras 9] Peras voting rules prep: parameters, arrival times, and CertDB updates

ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md

@@ -0,0 +1,25 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+
+### Non-Breaking
+
+- Add plumbing to provide a SystemTime to the PerasCertDB to record certificate
+  arrival times.
+
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -263,6 +263,7 @@ mkHandlers
     , keepAliveRng
     , miniProtocolParameters
     , getDiffusionPipeliningSupport
+    , systemTime
     }
   NodeKernel
     { getChainDB
@@ -322,7 +323,7 @@ mkHandlers
             , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97
             , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97
             )
-            (makePerasCertPoolWriterFromChainDB $ getChainDB)
+            (makePerasCertPoolWriterFromChainDB systemTime getChainDB)
             version
             controlMessageSTM
       , hPerasCertDiffusionServer = \version peer ->

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs

@@ -585,6 +585,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} =
                   llrnFeatureFlags
                   rnTraceConsensus
                   btime
+                  systemTime
                   (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime)
                   historicityCheck
                   chainDB
@@ -863,6 +864,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 ->
@@ -883,6 +885,7 @@ mkNodeKernelArgs
   featureFlags
   tracers
   btime
+  systemTime
   chainSyncFutureCheck
   chainSyncHistoricityCheck
   chainDB
@@ -902,6 +905,7 @@ mkNodeKernelArgs
           , cfg
           , featureFlags
           , btime
+          , systemTime
           , chainDB
           , initChainDB = nodeInitChainDB
           , chainSyncFutureCheck

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs

@@ -199,6 +199,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

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 =

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs

@@ -164,7 +164,7 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} =
         (History.StandardSafeZone (safeFromTipA k))
         (safeZoneB k)
       <*> pure (GenesisWindow ((unNonZero $ maxRollbacks k) * 2))
-      <*> pure (History.PerasEnabled defaultPerasRoundLength)
+      <*> pure (History.PerasEnabled (perasRoundLength mkPerasParams))
 
   shape :: History.Shape '[BlockA, BlockB]
   shape = History.Shape $ exactlyTwo eraParamsA eraParamsB

ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md

@@ -0,0 +1,26 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+### Non-Breaking
+
+- Introduce `Ouroboros.Consensus.Peras.Params` module.
+- Introduce `WithArrivalTime` combinator.
+- Refactor `HasPerasCertX` field projection typeclasses.
+- Add `getLatestCertSeen` method to the PerasCertDB API.
+
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->

ouroboros-consensus/ouroboros-consensus.cabal

@@ -203,6 +203,7 @@ library
     Ouroboros.Consensus.Node.Run
     Ouroboros.Consensus.Node.Serialisation
     Ouroboros.Consensus.NodeId
+    Ouroboros.Consensus.Peras.Params
     Ouroboros.Consensus.Peras.SelectView
     Ouroboros.Consensus.Peras.Weight
     Ouroboros.Consensus.Protocol.Abstract

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 #-}
@@ -13,59 +13,49 @@
 
 module Ouroboros.Consensus.Block.SupportsPeras
   ( PerasRoundNo (..)
-  , PerasWeight (..)
+  , onPerasRoundNo
   , BlockSupportsPeras (..)
   , PerasCert (..)
-  , PerasCfg (..)
   , ValidatedPerasCert (..)
-  , makePerasCfg
-  , HasPerasCert (..)
-  , getPerasCertRound
-  , getPerasCertBoostedBlock
-  , getPerasCertBoost
-
-    -- * Ouroboros Peras round length
-  , PerasRoundLength (..)
-  , defaultPerasRoundLength
+  , HasPerasCertRound (..)
+  , HasPerasCertBoostedBlock (..)
+  , HasPerasCertBoost (..)
+
+    -- * Convenience re-exports
+  , module Ouroboros.Consensus.Peras.Params
   ) where
 
 import Codec.Serialise (Serialise (..))
 import Codec.Serialise.Decoding (decodeListLenOf)
 import Codec.Serialise.Encoding (encodeListLen)
-import Data.Monoid (Sum (..))
+import Data.Coerce (coerce)
 import Data.Proxy (Proxy (..))
 import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block.Abstract
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..))
+import Ouroboros.Consensus.Peras.Params
 import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.Condense
 import Quiet (Quiet (..))
 
 newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64}
   deriving Show via Quiet PerasRoundNo
   deriving stock Generic
-  deriving newtype (Enum, Eq, Ord, NoThunks, Serialise)
+  deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise)
 
 instance Condense PerasRoundNo where
   condense = show . unPerasRoundNo
 
 instance ShowProxy PerasRoundNo where
   showProxy _ = "PerasRoundNo"
 
-newtype PerasWeight = PerasWeight {unPerasWeight :: Word64}
-  deriving Show via Quiet PerasWeight
-  deriving stock Generic
-  deriving newtype (Eq, Ord, NoThunks)
-  deriving (Semigroup, Monoid) via Sum Word64
-
-instance Condense PerasWeight where
-  condense = show . unPerasWeight
-
--- | TODO: this will become a Ledger protocol parameter
--- see https://github.com/tweag/cardano-peras/issues/119
-boostPerCert :: PerasWeight
-boostPerCert = PerasWeight 15
+-- | Lift a binary operation on 'Word64' to 'PerasRoundNo'
+onPerasRoundNo ::
+  (Word64 -> Word64 -> Word64) ->
+  (PerasRoundNo -> PerasRoundNo -> PerasRoundNo)
+onPerasRoundNo = coerce
 
 -- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module?
 data ValidatedPerasCert blk = ValidatedPerasCert
@@ -76,27 +66,16 @@ data ValidatedPerasCert blk = ValidatedPerasCert
   deriving anyclass NoThunks
 
 {-------------------------------------------------------------------------------
-  Ouroboros Peras round length
+-- * BlockSupportsPeras class
 -------------------------------------------------------------------------------}
 
-newtype PerasRoundLength = PerasRoundLength {unPerasRoundLength :: Word64}
-  deriving stock (Show, Eq, Ord)
-  deriving newtype (NoThunks, Num)
-
--- | See the Protocol parameters section of the Peras design report:
---   https://tweag.github.io/cardano-peras/peras-design.pdf#section.2.1
--- TODO: this will become a Ledger protocol parameter
--- see https://github.com/tweag/cardano-peras/issues/119
-defaultPerasRoundLength :: PerasRoundLength
-defaultPerasRoundLength = 90
-
 class
   ( Show (PerasCfg blk)
   , NoThunks (PerasCert blk)
   ) =>
   BlockSupportsPeras blk
   where
-  data PerasCfg blk
+  type PerasCfg blk
 
   data PerasCert blk
 
@@ -110,13 +89,7 @@ class
 -- TODO: degenerate instance for all blks to get things to compile
 -- see https://github.com/tweag/cardano-peras/issues/73
 instance StandardHash blk => BlockSupportsPeras blk where
-  newtype PerasCfg blk = PerasCfg
-    { -- TODO: eventually, this will come from the
-      -- protocol parameters from the ledger state
-      -- see https://github.com/tweag/cardano-peras/issues/119
-      perasCfgWeightBoost :: PerasWeight
-    }
-    deriving stock (Show, Eq)
+  type PerasCfg blk = PerasParams
 
   data PerasCert blk = PerasCert
     { pcCertRound :: PerasRoundNo
@@ -134,11 +107,11 @@ instance StandardHash blk => BlockSupportsPeras blk where
   -- TODO: perform actual validation against all
   -- possible 'PerasValidationErr' variants
   -- see https://github.com/tweag/cardano-peras/issues/120
-  validatePerasCert cfg cert =
+  validatePerasCert params cert =
     Right
       ValidatedPerasCert
         { vpcCert = cert
-        , vpcCertBoost = perasCfgWeightBoost cfg
+        , vpcCertBoost = perasWeight params
         }
 
 instance ShowProxy blk => ShowProxy (PerasCert blk) where
@@ -155,31 +128,47 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
     pcCertBoostedBlock <- decode
     pure $ PerasCert{pcCertRound, pcCertBoostedBlock}
 
--- | Derive a 'PerasCfg' from a 'BlockConfig'
---
--- TODO: this currently doesn't depend on 'BlockConfig' at all, but likely will
--- depend on it in the future
--- see https://github.com/tweag/cardano-peras/issues/73
-makePerasCfg :: Maybe (BlockConfig blk) -> PerasCfg blk
-makePerasCfg _ =
-  PerasCfg
-    { perasCfgWeightBoost = boostPerCert
-    }
+-- | Extract the certificate round from a Peras certificate container
+class HasPerasCertRound cert where
+  getPerasCertRound :: cert -> PerasRoundNo
+
+instance HasPerasCertRound (PerasCert blk) where
+  getPerasCertRound = pcCertRound
+
+instance HasPerasCertRound (ValidatedPerasCert blk) where
+  getPerasCertRound = getPerasCertRound . vpcCert
+
+instance
+  HasPerasCertRound cert =>
+  HasPerasCertRound (WithArrivalTime cert)
+  where
+  getPerasCertRound = getPerasCertRound . forgetArrivalTime
+
+-- | Extract the boosted block point from a Peras certificate container
+class HasPerasCertBoostedBlock cert blk | cert -> blk where
+  getPerasCertBoostedBlock :: cert -> Point blk
 
-class StandardHash blk => HasPerasCert cert blk where
-  getPerasCert :: cert blk -> PerasCert blk
+instance HasPerasCertBoostedBlock (PerasCert blk) blk where
+  getPerasCertBoostedBlock = pcCertBoostedBlock
 
-instance StandardHash blk => HasPerasCert PerasCert blk where
-  getPerasCert = id
+instance HasPerasCertBoostedBlock (ValidatedPerasCert blk) blk where
+  getPerasCertBoostedBlock = getPerasCertBoostedBlock . vpcCert
 
-instance StandardHash blk => HasPerasCert ValidatedPerasCert blk where
-  getPerasCert = vpcCert
+instance
+  HasPerasCertBoostedBlock cert blk =>
+  HasPerasCertBoostedBlock (WithArrivalTime cert) blk
+  where
+  getPerasCertBoostedBlock = getPerasCertBoostedBlock . forgetArrivalTime
 
-getPerasCertRound :: HasPerasCert cert blk => cert blk -> PerasRoundNo
-getPerasCertRound = pcCertRound . getPerasCert
+-- | Extract the certificate boost from a Peras certificate container
+class HasPerasCertBoost cert where
+  getPerasCertBoost :: cert -> PerasWeight
 
-getPerasCertBoostedBlock :: HasPerasCert cert blk => cert blk -> Point blk
-getPerasCertBoostedBlock = pcCertBoostedBlock . getPerasCert
+instance HasPerasCertBoost (ValidatedPerasCert blk) where
+  getPerasCertBoost = vpcCertBoost
 
-getPerasCertBoost :: ValidatedPerasCert blk -> PerasWeight
-getPerasCertBoost = vpcCertBoost
+instance
+  HasPerasCertBoost cert =>
+  HasPerasCertBoost (WithArrivalTime cert)
+  where
+  getPerasCertBoost = getPerasCertBoost . forgetArrivalTime

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)