diff --git a/ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md b/ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md new file mode 100644 index 0000000000..8848bf832e --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20251201_130629_agustin.mista_new_defs_and_plumbing.md @@ -0,0 +1,25 @@ + + + + +### Non-Breaking + +- Add plumbing to provide a SystemTime to the PerasCertDB in ordert to record + certificate arrival times. + + diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 294aace61f..3890267c84 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -263,6 +263,7 @@ mkHandlers , keepAliveRng , miniProtocolParameters , getDiffusionPipeliningSupport + , systemTime } NodeKernel { getChainDB @@ -322,7 +323,7 @@ mkHandlers , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 , 10 -- TODO: see https://github.com/tweag/cardano-peras/issues/97 ) - (makePerasCertPoolWriterFromChainDB $ getChainDB) + (makePerasCertPoolWriterFromChainDB systemTime getChainDB) version controlMessageSTM , hPerasCertDiffusionServer = \version peer -> diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index ac9fb75450..c8f021fd66 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -578,6 +578,7 @@ runWith RunNodeArgs{..} encAddrNtN decAddrNtN LowLevelRunNodeArgs{..} = cfg rnTraceConsensus btime + systemTime (InFutureCheck.realHeaderInFutureCheck llrnMaxClockSkew systemTime) historicityCheck chainDB @@ -855,6 +856,7 @@ mkNodeKernelArgs :: TopLevelConfig blk -> Tracers m (ConnectionId addrNTN) (ConnectionId addrNTC) blk -> BlockchainTime m -> + SystemTime m -> InFutureCheck.SomeHeaderInFutureCheck m blk -> (m GSM.GsmState -> HistoricityCheck m blk) -> ChainDB m blk -> @@ -874,6 +876,7 @@ mkNodeKernelArgs cfg tracers btime + systemTime chainSyncFutureCheck chainSyncHistoricityCheck chainDB @@ -892,6 +895,7 @@ mkNodeKernelArgs , registry , cfg , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 1c45c68155..5fdeb9dffe 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -196,6 +196,7 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs , registry :: ResourceRegistry m , cfg :: TopLevelConfig blk , btime :: BlockchainTime m + , systemTime :: SystemTime m , chainDB :: ChainDB m blk , initChainDB :: StorageConfig blk -> InitChainDB m blk -> m () , chainSyncFutureCheck :: SomeHeaderInFutureCheck m blk diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index f5e9dbecbd..234a3fd4c1 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -1046,6 +1046,7 @@ runThreadNetwork , registry , cfg = pInfoConfig , btime + , systemTime , chainDB , initChainDB = nodeInitChainDB , chainSyncFutureCheck = diff --git a/ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md b/ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md new file mode 100644 index 0000000000..9a2276a8dc --- /dev/null +++ b/ouroboros-consensus/changelog.d/20251201_130034_agustin.mista_new_defs_and_plumbing.md @@ -0,0 +1,26 @@ + + + +### Non-Breaking + +- Introduce `Ouroboros.Consensus.Peras.Params` module. +- Introduce `WithArrivalTime` combinator. +- Refactor `HasPerasCertX` field projection typeclasses. +- Add `getLatestCertSeen` method to the PerasCertDB API. + + diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index a0d3a83786..2565f9120d 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -203,6 +203,7 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.NodeId + Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Weight Ouroboros.Consensus.Protocol.Abstract diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 030ab9d7e2..4f5a9ff49c 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 #-} @@ -13,31 +13,29 @@ 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 (..)) @@ -45,7 +43,7 @@ import Quiet (Quiet (..)) newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving Show via Quiet PerasRoundNo deriving stock Generic - deriving newtype (Enum, Eq, Ord, NoThunks, Serialise) + deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise) instance Condense PerasRoundNo where condense = show . unPerasRoundNo @@ -53,19 +51,11 @@ instance Condense PerasRoundNo where instance ShowProxy PerasRoundNo where showProxy _ = "PerasRoundNo" -newtype PerasWeight = PerasWeight {unPerasWeight :: Word64} - deriving Show via Quiet PerasWeight - deriving stock Generic - deriving newtype (Eq, Ord, NoThunks) - deriving (Semigroup, Monoid) via Sum Word64 - -instance Condense PerasWeight where - condense = show . unPerasWeight - --- | TODO: this will become a Ledger protocol parameter --- see https://github.com/tweag/cardano-peras/issues/119 -boostPerCert :: PerasWeight -boostPerCert = PerasWeight 15 +-- | 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 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) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs index 26bff506f3..0312dd4288 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasCert.hs @@ -11,10 +11,16 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert , makePerasCertPoolWriterFromChainDB ) where +import Control.Monad ((>=>)) import Data.Map (Map) import qualified Data.Map as Map import GHC.Exception (throw) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( SystemTime (..) + , WithArrivalTime (..) + , addArrivalTime + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB @@ -31,7 +37,7 @@ takeAscMap :: Int -> Map k v -> Map k v takeAscMap n = Map.fromDistinctAscList . take n . Map.toAscList makePerasCertPoolReaderFromSnapshot :: - (IOLike m, StandardHash blk) => + IOLike m => STM m (PerasCertSnapshot blk) -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromSnapshot getCertSnapshot = @@ -43,7 +49,10 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot = let certsAfterLastKnown = PerasCertDB.getCertsAfter certSnapshot lastKnown let loadCertsAfterLastKnown = - pure (getPerasCert <$> takeAscMap (fromIntegral limit) certsAfterLastKnown) + pure $ + fmap + (vpcCert . forgetArrivalTime) + (takeAscMap (fromIntegral limit) certsAfterLastKnown) pure $ if Map.null certsAfterLastKnown then Nothing @@ -51,40 +60,40 @@ makePerasCertPoolReaderFromSnapshot getCertSnapshot = } makePerasCertPoolReaderFromCertDB :: - (IOLike m, StandardHash blk) => + IOLike m => PerasCertDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromCertDB perasCertDB = makePerasCertPoolReaderFromSnapshot (PerasCertDB.getCertSnapshot perasCertDB) makePerasCertPoolWriterFromCertDB :: (StandardHash blk, IOLike m) => - PerasCertDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromCertDB perasCertDB = + 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 } makePerasCertPoolReaderFromChainDB :: - (IOLike m, StandardHash blk) => + IOLike m => ChainDB m blk -> ObjectPoolReader PerasRoundNo (PerasCert blk) PerasCertTicketNo m makePerasCertPoolReaderFromChainDB chainDB = makePerasCertPoolReaderFromSnapshot (ChainDB.getPerasCertSnapshot chainDB) makePerasCertPoolWriterFromChainDB :: (StandardHash blk, IOLike m) => - ChainDB m blk -> ObjectPoolWriter PerasRoundNo (PerasCert blk) m -makePerasCertPoolWriterFromChainDB chainDB = + 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 @@ -104,11 +113,30 @@ validatePerasCerts :: [PerasCert blk] -> m [ValidatedPerasCert blk] validatePerasCerts certs = do - let perasCfg = makePerasCfg Nothing - -- TODO replace the mocked-up Nothing with a real - -- 'BlockConfig' when all the plumbing is in place + let perasParams = mkPerasParams + -- TODO pass down 'BlockConfig' when all the plumbing is in place -- see https://github.com/tweag/cardano-peras/issues/73 -- see https://github.com/tweag/cardano-peras/issues/120 - case traverse (validatePerasCert perasCfg) certs of + case traverse (validatePerasCert perasParams) certs of Left validationErr -> throw (PerasCertValidationError validationErr) Right validatedCerts -> return validatedCerts + +-- | 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/Peras/Params.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs new file mode 100644 index 0000000000..c6af611269 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Params.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | Peras protocol parameters +module Ouroboros.Consensus.Peras.Params + ( -- * Protocol parameters + PerasIgnoranceRounds (..) + , PerasCooldownRounds (..) + , PerasBlockMinSlots (..) + , PerasCertArrivalThreshold (..) + , PerasRoundLength (..) + , PerasWeight (..) + + -- * Protocol parameters bundle + , PerasParams (..) + , mkPerasParams + ) +where + +import Data.Semigroup (Sum (..)) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Ouroboros.Consensus.Util.Condense (Condense (..)) +import Ouroboros.Consensus.Util.IOLike (NoThunks) +import Quiet (Quiet (..)) + +{------------------------------------------------------------------------------- + Protocol parameters +-------------------------------------------------------------------------------} + +-- | Number of rounds for which to ignore certificates after entering a +-- cooldown period. +newtype PerasIgnoranceRounds + = PerasIgnoranceRounds {unPerasIgnoranceRounds :: Word64} + deriving Show via Quiet PerasIgnoranceRounds + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Minimum number of rounds to wait before voting again after a cooldown +-- period starts. +newtype PerasCooldownRounds + = PerasCooldownRounds {unPerasCooldownRounds :: Word64} + deriving Show via Quiet PerasCooldownRounds + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Minimum age in slots of a block before it can be voted for in order to get +-- a boost. +newtype PerasBlockMinSlots + = PerasBlockMinSlots {unPerasBlockMinSlots :: Word64} + deriving Show via Quiet PerasBlockMinSlots + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Maximum number of slots to wait for after the start of a round to consider +-- a certificate valid for voting. +newtype PerasCertArrivalThreshold + = PerasCertArrivalThreshold {unPerasCertArrivalThreshold :: Word64} + deriving Show via Quiet PerasCertArrivalThreshold + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +-- | Length of a Peras round in slots. +newtype PerasRoundLength + = PerasRoundLength {unPerasRoundLength :: Word64} + deriving Show via Quiet PerasRoundLength + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks) + +-- | Weight assigned to a block when boosted by a Peras certificate. +newtype PerasWeight + = PerasWeight {unPerasWeight :: Word64} + deriving Show via Quiet PerasWeight + deriving stock Generic + deriving newtype (Enum, Eq, Ord, NoThunks, Condense) + +deriving via Sum Word64 instance Semigroup PerasWeight +deriving via Sum Word64 instance Monoid PerasWeight + +{------------------------------------------------------------------------------- + Protocol parameters bundle +-------------------------------------------------------------------------------} + +-- | Peras protocol parameters. +-- +-- These are documented in the section 2.1 of the Peras design report: +-- https://tweag.github.io/cardano-peras/peras-design.pdf#section.2.1 +data PerasParams = PerasParams + { perasIgnoranceRounds :: PerasIgnoranceRounds + , perasCooldownRounds :: PerasCooldownRounds + , perasBlockMinSlots :: PerasBlockMinSlots + , perasCertArrivalThreshold :: PerasCertArrivalThreshold + , perasRoundLength :: PerasRoundLength + , perasWeight :: PerasWeight + } + deriving (Show, Eq, Generic, NoThunks) + +-- | Instantiate default Peras protocol parameters. +-- +-- NOTE: in the future this will depend on a concrete 'BlockConfig'. +mkPerasParams :: PerasParams +mkPerasParams = + PerasParams + { perasIgnoranceRounds = + error "perasIgnoranceRounds: not yet defined" + , perasCooldownRounds = + error "perasCooldownRounds: not yet defined" + , perasBlockMinSlots = + error "perasBlockMinSlots: not yet defined" + , perasCertArrivalThreshold = + error "perasCertArrivalThreshold: not yet defined" + , perasRoundLength = + PerasRoundLength 90 + , perasWeight = + PerasWeight 15 + } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 8b89764c2c..99d5d46e1e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -81,6 +81,7 @@ import Control.ResourceRegistry import Data.Typeable (Typeable) import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.HeaderStateHistory ( HeaderStateHistory (..) ) @@ -396,7 +397,7 @@ data ChainDB m blk = ChainDB , getStatistics :: m (Maybe Statistics) -- ^ Get statistics from the LedgerDB, in particular the number of entries -- in the tables. - , addPerasCertAsync :: ValidatedPerasCert blk -> m (AddPerasCertPromise m) + , addPerasCertAsync :: WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) -- ^ Asynchronously insert a certificate to the DB. If this leads to a fork to -- be weightier than our current selection, this will trigger a fork switch. , getPerasWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) @@ -537,7 +538,7 @@ newtype AddPerasCertPromise m = AddPerasCertPromise -- impossible). } -addPerasCertSync :: IOLike m => ChainDB m blk -> ValidatedPerasCert blk -> m () +addPerasCertSync :: IOLike m => ChainDB m blk -> WithArrivalTime (ValidatedPerasCert blk) -> m () addPerasCertSync chainDB cert = waitPerasCertProcessed =<< addPerasCertAsync chainDB cert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index 5278133580..a032a268d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -45,6 +45,7 @@ import qualified Data.Set as Set import Data.Traversable (for) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..)) import qualified Ouroboros.Consensus.Fragment.Diff as Diff @@ -326,9 +327,9 @@ addBlockAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertAsync :: forall m blk. - (IOLike m, HasHeader blk) => + IOLike m => ChainDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) addPerasCertAsync CDB{cdbTracer, cdbChainSelQueue} = addPerasCertToQueue (TraceAddPerasCertEvent >$< cdbTracer) cdbChainSelQueue diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 3336ba527f..71f836f487 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -94,6 +94,7 @@ import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class (OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.Fragment.Diff (ChainDiff) import Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..)) @@ -553,7 +554,7 @@ data ChainSelMessage m blk ChainSelAddBlock !(BlockToAdd m blk) | -- | Add a Peras certificate ChainSelAddPerasCert - !(ValidatedPerasCert blk) + !(WithArrivalTime (ValidatedPerasCert blk)) -- | Used for 'AddPerasCertPromise'. !(StrictTMVar m ()) | -- | Reprocess blocks that have been postponed by the LoE. @@ -606,10 +607,10 @@ addBlockToAdd tracer (ChainSelQueue{varChainSelQueue, varChainSelPoints}) punish -- | Add a Peras certificate to the background queue. addPerasCertToQueue :: - (IOLike m, StandardHash blk) => + IOLike m => Tracer m (TraceAddPerasCertEvent blk) -> ChainSelQueue m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m (AddPerasCertPromise m) addPerasCertToQueue tracer ChainSelQueue{varChainSelQueue} cert = do varProcessed <- newEmptyTMVarIO diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs index 873ebe29f9..6ef63864c8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/API.hs @@ -17,12 +17,13 @@ import Data.Map (Map) import Data.Word (Word64) import NoThunks.Class import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) data PerasCertDB m blk = PerasCertDB - { addCert :: ValidatedPerasCert blk -> m AddPerasCertResult + { addCert :: WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult -- ^ Add a Peras certificate to the database. The result indicates whether -- the certificate was actually added, or if it was already present. , getWeightSnapshot :: STM m (WithFingerprint (PerasWeightSnapshot blk)) @@ -34,6 +35,14 @@ data PerasCertDB m blk = PerasCertDB -- The 'Fingerprint' is updated every time a new certificate is added, but it -- stays the same when certificates are garbage-collected. , getCertSnapshot :: STM m (PerasCertSnapshot blk) + , getLatestCertSeen :: STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ Get the certificate with the highest round number that has been added to + -- the db since it has been opened. This certificate is not affected by garbage + -- collection, but it's forgotten when the db is closed. + -- + -- FIXME(peras): having seen a certificate is a precondition to start voting + -- in every round except for the first one (at origin). As a consequence, only + -- caught-up nodes can actively participate in the Peras protocol for now. , garbageCollect :: SlotNo -> m () -- ^ Garbage-collect state older than the given slot number. , closeDB :: m () @@ -46,7 +55,9 @@ data AddPerasCertResult = AddedPerasCertToDB | PerasCertAlreadyInDB data PerasCertSnapshot blk = PerasCertSnapshot { containsCert :: PerasRoundNo -> Bool -- ^ Do we have the certificate for this round? - , getCertsAfter :: PerasCertTicketNo -> Map PerasCertTicketNo (ValidatedPerasCert blk) + , getCertsAfter :: + PerasCertTicketNo -> + Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk)) -- ^ Get certificates after the given ticket number (excluded). -- The result is a map of ticket numbers to validated certificates. } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 8b8a33c342..16d59df38c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -32,6 +32,7 @@ import qualified Data.Set as Set import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.PerasCertDB.API import Ouroboros.Consensus.Util.Args @@ -78,6 +79,7 @@ openDB args = do { addCert = getEnv1 h implAddCert , getWeightSnapshot = getEnvSTM h implGetWeightSnapshot , getCertSnapshot = getEnvSTM h implGetCertSnapshot + , getLatestCertSeen = getEnvSTM h implGetLatestCertSeen , garbageCollect = getEnv1 h implGarbageCollect , closeDB = implCloseDB h } @@ -152,7 +154,7 @@ implAddCert :: , StandardHash blk ) => PerasCertDbEnv m blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> m AddPerasCertResult implAddCert env cert = do traceWith pcdbTracer $ AddingPerasCert roundNo boostedPt @@ -169,18 +171,22 @@ implAddCert env cert = do if Map.member roundNo pvcsCerts then pure PerasCertAlreadyInDB else do + let pvcsCerts' = Map.insert roundNo cert pvcsCerts let pvcsLastTicketNo' = succ pvcsLastTicketNo writeTVar pcdbVolatileState $ WithFingerprint PerasVolatileCertState { pvcsCerts = - Map.insert roundNo cert pvcsCerts + pvcsCerts' , -- Note that the same block might be boosted by multiple points. pvcsWeightByPoint = addToPerasWeightSnapshot boostedPt (getPerasCertBoost cert) pvcsWeightByPoint , pvcsCertsByTicket = Map.insert pvcsLastTicketNo' cert pvcsCertsByTicket - , pvcsLastTicketNo = pvcsLastTicketNo' + , pvcsLastTicketNo = + pvcsLastTicketNo' + , pvcsLatestCertSeen = + snd <$> Map.lookupMax pvcsCerts' } (succ fp) pure AddedPerasCertToDB @@ -219,9 +225,17 @@ implGetCertSnapshot PerasCertDbEnv{pcdbVolatileState} = snd $ Map.split ticketNo pvcsCertsByTicket } +implGetLatestCertSeen :: + IOLike m => + PerasCertDbEnv m blk -> STM m (Maybe (WithArrivalTime (ValidatedPerasCert blk))) +implGetLatestCertSeen PerasCertDbEnv{pcdbVolatileState} = + readTVar pcdbVolatileState + <&> forgetFingerprint + <&> pvcsLatestCertSeen + implGarbageCollect :: forall m blk. - (IOLike m, StandardHash blk) => + IOLike m => PerasCertDbEnv m blk -> SlotNo -> m () implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- No need to update the 'Fingerprint' as we only remove certificates that do @@ -235,12 +249,14 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = , pvcsWeightByPoint , pvcsLastTicketNo , pvcsCertsByTicket + , pvcsLatestCertSeen } = PerasVolatileCertState { pvcsCerts = Map.filter keepCert pvcsCerts , pvcsWeightByPoint = prunePerasWeightSnapshot slot pvcsWeightByPoint , pvcsCertsByTicket = Map.filter keepCert pvcsCertsByTicket , pvcsLastTicketNo = pvcsLastTicketNo + , pvcsLatestCertSeen = pvcsLatestCertSeen } where keepCert cert = @@ -255,15 +271,20 @@ implGarbageCollect PerasCertDbEnv{pcdbVolatileState} slot = -- -- INVARIANT: See 'invariantForPerasVolatileCertState'. data PerasVolatileCertState blk = PerasVolatileCertState - { pvcsCerts :: !(Map PerasRoundNo (ValidatedPerasCert blk)) + { pvcsCerts :: !(Map PerasRoundNo (WithArrivalTime (ValidatedPerasCert blk))) -- ^ The boosted blocks by 'RoundNo' of all certificates currently in the db. , pvcsWeightByPoint :: !(PerasWeightSnapshot blk) -- ^ The weight of boosted blocks w.r.t. the certificates currently in the db. - , pvcsCertsByTicket :: !(Map PerasCertTicketNo (ValidatedPerasCert blk)) + -- + -- INVARIANT: In sync with 'pvcsCerts'. + , pvcsCertsByTicket :: !(Map PerasCertTicketNo (WithArrivalTime (ValidatedPerasCert blk))) -- ^ The certificates by 'PerasCertTicketNo'. , pvcsLastTicketNo :: !PerasCertTicketNo -- ^ The most recent 'PerasCertTicketNo' (or 'zeroPerasCertTicketNo' -- otherwise). + , pvcsLatestCertSeen :: !(Maybe (WithArrivalTime (ValidatedPerasCert blk))) + -- ^ The certificate with the highest round number that has been added to the + -- db since it has been opened. } deriving stock (Show, Generic) deriving anyclass NoThunks @@ -276,6 +297,7 @@ initialPerasVolatileCertState = , pvcsWeightByPoint = emptyPerasWeightSnapshot , pvcsCertsByTicket = Map.empty , pvcsLastTicketNo = zeroPerasCertTicketNo + , pvcsLatestCertSeen = Nothing } (Fingerprint 0) @@ -300,7 +322,6 @@ invariantForPerasVolatileCertState pvcs = do <> " > " <> show pvcsLastTicketNo where - PerasVolatileCertState _ _ _ _keep = forgetFingerprint pvcs PerasVolatileCertState { pvcsCerts , pvcsWeightByPoint 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 baee97b57d..9513201752 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs @@ -15,6 +15,13 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Consensus.Block.SupportsPeras +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , SystemTime (..) + , WithArrivalTime (..) + , addArrivalTime + , systemTimeCurrent + ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert import Ouroboros.Consensus.Storage.PerasCertDB.API @@ -25,6 +32,12 @@ import Ouroboros.Consensus.Storage.PerasCertDB.API import qualified Ouroboros.Consensus.Storage.PerasCertDB.API as PerasCertDB import qualified Ouroboros.Consensus.Storage.PerasCertDB.Impl as PerasCertDB import Ouroboros.Consensus.Util.IOLike + ( IOLike + , atomically + , stateTVar + , throwIO + , uncheckedNewTVarM + ) import Ouroboros.Network.Block (Point (..), SlotNo (SlotNo), StandardHash) import Ouroboros.Network.Point (Block (Block), WithOrigin (..)) import Ouroboros.Network.Protocol.ObjectDiffusion.Codec @@ -32,6 +45,7 @@ import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( objectDiffusionInboundPeerPipelined ) import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) +import System.Random (mkStdGen, uniform) import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( ListWithUniqueIds (..) , WithId @@ -55,7 +69,7 @@ tests = ] perasTestCfg :: PerasCfg TestBlock -perasTestCfg = makePerasCfg Nothing +perasTestCfg = mkPerasParams genPoint :: Gen (Point (TestBlock)) genPoint = @@ -80,21 +94,33 @@ genPerasCert = do instance WithId (PerasCert blk) PerasRoundNo where getId = pcCertRound +mockSystemTime :: IOLike m => Int -> m (SystemTime m) +mockSystemTime seed = do + varGen <- uncheckedNewTVarM (mkStdGen seed) + return $ + SystemTime + { systemTimeCurrent = + RelativeTime . realToFrac @Int <$> atomically (stateTVar varGen uniform) + , systemTimeWait = + pure () + } + newCertDB :: (IOLike m, StandardHash blk) => PerasCfg blk -> + SystemTime m -> [PerasCert blk] -> m (PerasCertDB m blk) -newCertDB perasCfg certs = do +newCertDB perasParams systemTime certs = do db <- PerasCertDB.openDB (PerasCertDB.PerasCertDbArgs @Identity nullTracer) mapM_ ( \cert -> do let validatedCert = ValidatedPerasCert { vpcCert = cert - , vpcCertBoost = perasCfgWeightBoost perasCfg + , vpcCertBoost = perasWeight perasParams } - result <- PerasCertDB.addCert db validatedCert + result <- PerasCertDB.addCert db =<< addArrivalTime systemTime validatedCert case result of AddedPerasCertToDB -> pure () PerasCertAlreadyInDB -> throwIO (userError "Expected AddedPerasCertToDB, but cert was already in DB") @@ -106,47 +132,49 @@ prop_smoke :: Property prop_smoke = forAll genProtocolConstants $ \protocolConstants -> forAll (genListWithUniqueIds genPerasCert) $ \(ListWithUniqueIds certs) -> - let - runOutboundPeer outbound outboundChannel tracer = - runPeer - ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) - codecObjectDiffusionId - outboundChannel - (objectDiffusionOutboundPeer outbound) - >> pure () - runInboundPeer inbound inboundChannel tracer = - runPipelinedPeer - ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) - codecObjectDiffusionId - inboundChannel - (objectDiffusionInboundPeerPipelined inbound) - >> pure () - mkPoolInterfaces :: - forall m. - IOLike m => - m - ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m - , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m - , m [PerasCert TestBlock] - ) - mkPoolInterfaces = do - outboundPool <- newCertDB perasTestCfg certs - inboundPool <- newCertDB perasTestCfg [] + forAll arbitrary $ \systemTimeSeed -> + let + runOutboundPeer outbound outboundChannel tracer = + runPeer + ((\x -> "Outbound (Client): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + outboundChannel + (objectDiffusionOutboundPeer outbound) + >> pure () + runInboundPeer inbound inboundChannel tracer = + runPipelinedPeer + ((\x -> "Inbound (Server): " ++ show x) `contramap` tracer) + codecObjectDiffusionId + inboundChannel + (objectDiffusionInboundPeerPipelined inbound) + >> pure () + mkPoolInterfaces :: + forall m. + IOLike m => + m + ( ObjectPoolReader PerasRoundNo (PerasCert TestBlock) PerasCertTicketNo m + , ObjectPoolWriter PerasRoundNo (PerasCert TestBlock) m + , m [PerasCert TestBlock] + ) + mkPoolInterfaces = do + systemTime <- mockSystemTime systemTimeSeed + outboundPool <- newCertDB perasTestCfg systemTime certs + inboundPool <- newCertDB perasTestCfg systemTime [] - let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool - inboundPoolWriter = makePerasCertPoolWriterFromCertDB inboundPool - getAllInboundPoolContent = atomically $ do - snap <- PerasCertDB.getCertSnapshot inboundPool - let rawContent = - Map.toAscList $ - PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) - pure $ getPerasCert . snd <$> rawContent + let outboundPoolReader = makePerasCertPoolReaderFromCertDB outboundPool + inboundPoolWriter = makePerasCertPoolWriterFromCertDB systemTime inboundPool + getAllInboundPoolContent = atomically $ do + snap <- PerasCertDB.getCertSnapshot inboundPool + let rawContent = + Map.toAscList $ + PerasCertDB.getCertsAfter snap (PerasCertDB.zeroPerasCertTicketNo) + pure $ vpcCert . forgetArrivalTime . snd <$> rawContent - return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) - in - prop_smoke_object_diffusion - protocolConstants - certs - runOutboundPeer - runInboundPeer - mkPoolInterfaces + return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) + in + prop_smoke_object_diffusion + protocolConstants + certs + runOutboundPeer + runInboundPeer + mkPoolInterfaces diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 910c7e1130..22cff44b75 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -104,6 +104,7 @@ import qualified Data.Set as Set import Data.TreeDiff import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract @@ -148,7 +149,7 @@ data Model blk = Model -- ^ The VolatileDB , immutableDbChain :: Chain blk -- ^ The ImmutableDB - , perasCerts :: Map PerasRoundNo (ValidatedPerasCert blk) + , perasCerts :: Map PerasRoundNo (WithArrivalTime (ValidatedPerasCert blk)) , cps :: CPS.ChainProducerState blk , currentLedger :: ExtLedgerState blk EmptyMK , initLedger :: ExtLedgerState blk EmptyMK @@ -445,7 +446,7 @@ addPerasCert :: forall blk. (LedgerSupportsProtocol blk, LedgerTablesAreTrivial (ExtLedgerState blk)) => TopLevelConfig blk -> - ValidatedPerasCert blk -> + WithArrivalTime (ValidatedPerasCert blk) -> Model blk -> Model blk addPerasCert cfg cert m diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs index 13d9735c5f..72cd8cfca5 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/StateMachine.hs @@ -97,11 +97,15 @@ import Data.Proxy import Data.TreeDiff import Data.Typeable import Data.Void (Void) -import Data.Word (Word16) +import Data.Word (Word16, Word64) import GHC.Generics (Generic) import qualified Generics.SOP as SOP import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , WithArrivalTime (..) + ) import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -190,7 +194,7 @@ data Cmd blk it flr AddBlock blk (Persistent [blk]) | -- | Add a Peras cert for a block, with (possibly) some gap blocks leading to it. -- For more information about gap blocks, refer to 'GenState' below. - AddPerasCert (ValidatedPerasCert blk) (Persistent [blk]) + AddPerasCert (WithArrivalTime (ValidatedPerasCert blk)) (Persistent [blk]) | GetCurrentChain | GetTipBlock | GetTipHeader @@ -1147,6 +1151,9 @@ generator loe genBlock m@Model{..} = empty :: Bool empty = null pointsInDB + genRelativeTime :: Gen RelativeTime + genRelativeTime = RelativeTime . fromIntegral <$> arbitrary @Word64 + genRealPoint :: Gen (RealPoint blk) genRealPoint = frequency @@ -1196,19 +1203,19 @@ generator loe genBlock m@Model{..} = ] -- Include the boosted block itself in the persisted seenBlocks let seenBlks = fmap (blk :) gapBlks - - pure $ - AddPerasCert - ( ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = blockPoint blk - } - , vpcCertBoost = boost - } - ) - seenBlks + -- Build the certificate + now <- genRelativeTime + let certWithTime = + WithArrivalTime now $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = blockPoint blk + } + , vpcCertBoost = boost + } + pure $ AddPerasCert certWithTime seenBlks genBounds :: Gen (StreamFrom blk, StreamTo blk) genBounds = diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs index d81a0a7940..cadeff1857 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs @@ -4,6 +4,7 @@ module Test.Ouroboros.Storage.Orphans () where import Data.Maybe (isJust) +import Data.Time.Clock (NominalDiffTime) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.ChainDB.API ( ChainDbError @@ -16,6 +17,8 @@ import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB import Ouroboros.Consensus.Util.CallStack import System.FS.API.Types (FsError, sameFsError) +import Test.QuickCheck.StateModel (HasVariables) +import Test.QuickCheck.StateModel.Variables (HasVariables (..)) {------------------------------------------------------------------------------- PrettyCallStack @@ -66,3 +69,10 @@ deriving instance StandardHash blk => Eq (ImmutableDB.UnexpectedFailure blk) deriving instance StandardHash blk => Eq (ChainDbFailure blk) deriving instance StandardHash blk => Eq (ChainDbError blk) + +{------------------------------------------------------------------------------- + Time +-------------------------------------------------------------------------------} + +instance HasVariables NominalDiffTime where + getAllVariables _ = mempty diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs index 9808ffe21c..a455d4ac27 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/Model.hs @@ -11,6 +11,7 @@ module Test.Ouroboros.Storage.PerasCertDB.Model , closeDB , addCert , getWeightSnapshot + , getLatestCertSeen , garbageCollect , hasRoundNo ) where @@ -19,13 +20,16 @@ import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime, forgetArrivalTime) import Ouroboros.Consensus.Peras.Weight ( PerasWeightSnapshot , mkPerasWeightSnapshot ) +import Ouroboros.Consensus.Util (safeMaximumOn) data Model blk = Model - { certs :: Set (ValidatedPerasCert blk) + { certs :: Set (WithArrivalTime (ValidatedPerasCert blk)) + , latestCertSeen :: Maybe (WithArrivalTime (ValidatedPerasCert blk)) , open :: Bool } deriving Generic @@ -33,25 +37,27 @@ data Model blk = Model deriving instance StandardHash blk => Show (Model blk) initModel :: Model blk -initModel = Model{open = False, certs = Set.empty} +initModel = Model{open = False, certs = Set.empty, latestCertSeen = Nothing} openDB :: Model blk -> Model blk openDB model = model{open = True} closeDB :: Model blk -> Model blk -closeDB _ = Model{open = False, certs = Set.empty} +closeDB _ = Model{open = False, certs = Set.empty, latestCertSeen = Nothing} addCert :: StandardHash blk => - Model blk -> ValidatedPerasCert blk -> Model blk + Model blk -> WithArrivalTime (ValidatedPerasCert blk) -> Model blk addCert model@Model{certs} cert | certs `hasRoundNo` cert = model - | otherwise = model{certs = Set.insert cert certs} + | otherwise = model{certs = certs', latestCertSeen = safeMaximumOn roundNo (Set.toList certs')} + where + certs' = Set.insert cert certs + roundNo = getPerasCertRound . forgetArrivalTime hasRoundNo :: - StandardHash blk => - Set (ValidatedPerasCert blk) -> - ValidatedPerasCert blk -> + Set (WithArrivalTime (ValidatedPerasCert blk)) -> + WithArrivalTime (ValidatedPerasCert blk) -> Bool hasRoundNo certs cert = (getPerasCertRound cert) `Set.member` (Set.map getPerasCertRound certs) @@ -65,7 +71,12 @@ getWeightSnapshot Model{certs} = | cert <- Set.toList certs ] -garbageCollect :: StandardHash blk => SlotNo -> Model blk -> Model blk +getLatestCertSeen :: + Model blk -> Maybe (WithArrivalTime (ValidatedPerasCert blk)) +getLatestCertSeen Model{latestCertSeen} = + latestCertSeen + +garbageCollect :: SlotNo -> Model blk -> Model blk garbageCollect slot model@Model{certs} = model{certs = Set.filter keepCert certs} where diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs index 504949b9ed..160b722bf4 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasCertDB/StateMachine.hs @@ -9,6 +9,7 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -23,12 +24,19 @@ import Control.Tracer (nullTracer) import Data.Function ((&)) import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set +import Data.Word (Word64) import Ouroboros.Consensus.Block +import Ouroboros.Consensus.BlockchainTime.WallClock.Types + ( RelativeTime (..) + , WithArrivalTime (..) + ) import Ouroboros.Consensus.Peras.Weight (PerasWeightSnapshot) import qualified Ouroboros.Consensus.Storage.PerasCertDB as PerasCertDB import Ouroboros.Consensus.Storage.PerasCertDB.API (AddPerasCertResult (..), PerasCertDB) import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.STM +import Test.Ouroboros.Storage.Orphans () import qualified Test.Ouroboros.Storage.PerasCertDB.Model as Model import Test.QuickCheck hiding (Some (..)) import qualified Test.QuickCheck.Monadic as QC @@ -46,7 +54,7 @@ tests = ] perasTestCfg :: PerasCfg TestBlock -perasTestCfg = makePerasCfg Nothing +perasTestCfg = mkPerasParams prop_qd :: Actions Model -> Property prop_qd actions = QC.monadic f $ property () <$ runActions actions @@ -60,8 +68,9 @@ 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) + GetLatestCertSeen :: Action Model (Maybe (WithArrivalTime (ValidatedPerasCert TestBlock))) GarbageCollect :: SlotNo -> Action Model () arbitraryAction _ (Model model) @@ -70,23 +79,29 @@ instance StateModel Model where [ (1, pure $ Some CloseDB) , (20, Some <$> genAddCert) , (20, pure $ Some GetWeightSnapshot) + , (10, pure $ Some GetLatestCertSeen) , (5, Some . GarbageCollect . SlotNo <$> arbitrary) ] | otherwise = pure $ Some OpenDB where + genRelativeTime :: Gen RelativeTime + genRelativeTime = RelativeTime . fromIntegral <$> arbitrary @Word64 + genAddCert = do roundNo <- genRoundNo boostedBlock <- genPoint - pure $ - AddCert - ValidatedPerasCert - { vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = boostedBlock - } - , vpcCertBoost = perasCfgWeightBoost perasTestCfg - } + now <- genRelativeTime + let certWithTime = + WithArrivalTime now $ + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = boostedBlock + } + , vpcCertBoost = perasWeight perasTestCfg + } + pure (AddCert certWithTime) -- Generators are heavily skewed toward collisions, to get equivocating certificates -- and certificates boosting the same block @@ -112,6 +127,7 @@ instance StateModel Model where CloseDB -> Model.closeDB model AddCert cert -> Model.addCert model cert GetWeightSnapshot -> model + GetLatestCertSeen -> model GarbageCollect slot -> Model.garbageCollect slot model precondition (Model model) = \case @@ -127,6 +143,7 @@ instance StateModel Model where where p cert' = getPerasCertRound cert /= getPerasCertRound cert' || cert == cert' GetWeightSnapshot -> True + GetLatestCertSeen -> True GarbageCollect _slot -> True deriving stock instance Show (Action Model a) @@ -149,6 +166,9 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where GetWeightSnapshot -> do perasCertDB <- get lift $ atomically $ forgetFingerprint <$> PerasCertDB.getWeightSnapshot perasCertDB + GetLatestCertSeen -> do + perasCertDB <- get + lift $ atomically $ PerasCertDB.getLatestCertSeen perasCertDB GarbageCollect slot -> do perasCertDB <- get lift $ PerasCertDB.garbageCollect perasCertDB slot @@ -164,6 +184,11 @@ instance RunModel Model (StateT (PerasCertDB IO TestBlock) IO) where counterexamplePost $ "Model: " <> show expected counterexamplePost $ "SUT: " <> show actual pure $ expected == actual + postcondition (Model model, _) GetLatestCertSeen _ actual = do + let expected = Model.getLatestCertSeen model + counterexamplePost $ "Model: " <> show expected + counterexamplePost $ "SUT: " <> show actual + pure $ expected == actual postcondition _ _ _ _ = pure True monitoring (Model model, _) (AddCert cert) _ _ prop =