From ab031dff7a734b1e4fd479b9745943604ff4b471 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 20 Nov 2025 17:41:58 +0100 Subject: [PATCH 1/5] Add basic types and definitions for votes --- ouroboros-consensus/ouroboros-consensus.cabal | 5 + .../Consensus/Block/SupportsPeras.hs | 96 +++++++++++++++++++ .../ObjectDiffusion/ObjectPool/PerasVote.hs | 1 + .../MiniProtocol/ObjectDiffusion/PerasVote.hs | 54 +++++++++++ .../Ouroboros/Consensus/Node/Serialisation.hs | 19 ++++ .../Consensus/Storage/PerasVoteDB.hs | 1 + .../Consensus/Storage/PerasVoteDB/API.hs | 78 +++++++++++++++ .../Consensus/Storage/PerasVoteDB/Impl.hs | 1 + 8 files changed, 255 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index c7e8542a2b..58e220c9a1 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -201,8 +201,10 @@ library Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V2.Types Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasCert + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasCert + Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasVote Ouroboros.Consensus.MiniProtocol.Util Ouroboros.Consensus.MiniProtocol.Util.Idling Ouroboros.Consensus.Node.GsmState @@ -281,6 +283,9 @@ library Ouroboros.Consensus.Storage.PerasCertDB Ouroboros.Consensus.Storage.PerasCertDB.API Ouroboros.Consensus.Storage.PerasCertDB.Impl + Ouroboros.Consensus.Storage.PerasVoteDB + Ouroboros.Consensus.Storage.PerasVoteDB.API + Ouroboros.Consensus.Storage.PerasVoteDB.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/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index a1a468ee8b..0c2c5a4a4c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} @@ -7,9 +8,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) @@ -17,22 +20,31 @@ module Ouroboros.Consensus.Block.SupportsPeras , PerasWeight (..) , BlockSupportsPeras (..) , PerasCert (..) + , PerasVote (..) , PerasCfg (..) , ValidatedPerasCert (..) + , ValidatedPerasVote (..) , makePerasCfg , HasPerasCertRound (..) , HasPerasCertBoostedBlock (..) , HasPerasCertBoost (..) + , HasPerasVoteRound (..) + , HasPerasVoteVotedBlock (..) + , HasStakePoolId (..) -- * Ouroboros Peras round length , PerasRoundLength (..) , defaultPerasRoundLength ) where +import qualified Cardano.Binary as KeyHash +import Cardano.Ledger.Core (KeyHash, KeyRole (StakePool)) +import Cardano.Ledger.State (IndividualPoolStake (..), PoolDistr (PoolDistr, unPoolDistr)) import Codec.Serialise (Serialise (..)) import Codec.Serialise.Decoding (decodeListLenOf) import Codec.Serialise.Encoding (encodeListLen) import Data.Coerce (coerce) +import qualified Data.Map as Map import Data.Monoid (Sum (..)) import Data.Proxy (Proxy (..)) import Data.Word (Word64) @@ -49,6 +61,9 @@ newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving stock Generic deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise) +-- | TODO: what is the proper underlying type? +type StakePoolId = KeyHash 'StakePool + instance Condense PerasRoundNo where condense = show . unPerasRoundNo @@ -83,6 +98,15 @@ data ValidatedPerasCert blk = ValidatedPerasCert deriving stock (Show, Eq, Ord, Generic) deriving anyclass NoThunks +deriving instance Ord IndividualPoolStake + +data ValidatedPerasVote blk = ValidatedPerasVote + { vpvVote :: !(PerasVote blk) + , vpvVoteStake :: !IndividualPoolStake + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass NoThunks + {------------------------------------------------------------------------------- Ouroboros Peras round length -------------------------------------------------------------------------------} @@ -108,6 +132,8 @@ class data PerasCert blk + data PerasVote blk + data PerasValidationErr blk validatePerasCert :: @@ -115,6 +141,12 @@ class PerasCert blk -> Either (PerasValidationErr blk) (ValidatedPerasCert blk) + validatePerasVote :: + PerasCfg blk -> + PerasVote blk -> + PoolDistr -> + Either (PerasValidationErr blk) (ValidatedPerasVote blk) + -- 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 @@ -133,6 +165,14 @@ instance StandardHash blk => BlockSupportsPeras blk where deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks + data PerasVote blk = PerasVote + { pvVoteRound :: PerasRoundNo + , pvVotedBlock :: Point blk + , pvVoteStakePoolId :: StakePoolId + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + -- TODO: enrich with actual error types -- see https://github.com/tweag/cardano-peras/issues/120 data PerasValidationErr blk @@ -149,9 +189,16 @@ instance StandardHash blk => BlockSupportsPeras blk where , vpcCertBoost = perasCfgWeightBoost cfg } + validatePerasVote _cfg vote PoolDistr{unPoolDistr} = + let stake = unPoolDistr Map.! (pvVoteStakePoolId vote) + in Right (ValidatedPerasVote{vpvVote = vote, vpvVoteStake = stake}) + instance ShowProxy blk => ShowProxy (PerasCert blk) where showProxy _ = "PerasCert " <> showProxy (Proxy @blk) +instance ShowProxy blk => ShowProxy (PerasVote blk) where + showProxy _ = "PerasVote " <> showProxy (Proxy @blk) + instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where encode PerasCert{pcCertRound, pcCertBoostedBlock} = encodeListLen 2 @@ -163,6 +210,19 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where pcCertBoostedBlock <- decode pure $ PerasCert{pcCertRound, pcCertBoostedBlock} +instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where + encode PerasVote{pvVoteRound, pvVotedBlock, pvVoteStakePoolId} = + encodeListLen 3 + <> encode pvVoteRound + <> encode pvVotedBlock + <> KeyHash.toCBOR pvVoteStakePoolId + decode = do + decodeListLenOf 3 + pvVoteRound <- decode + pvVotedBlock <- decode + pvVoteStakePoolId <- KeyHash.fromCBOR + pure $ PerasVote{pvVoteRound, pvVotedBlock, pvVoteStakePoolId} + -- | Derive a 'PerasCfg' from a 'BlockConfig' -- -- TODO: this currently doesn't depend on 'BlockConfig' at all, but likely will @@ -218,3 +278,39 @@ instance HasPerasCertBoost (WithArrivalTime cert) where getPerasCertBoost = getPerasCertBoost . forgetArrivalTime + +class HasPerasVoteRound vote where + getPerasVoteRound :: vote -> PerasRoundNo +instance HasPerasVoteRound (PerasVote blk) where + getPerasVoteRound = pvVoteRound +instance HasPerasVoteRound (ValidatedPerasVote blk) where + getPerasVoteRound = getPerasVoteRound . vpvVote +instance + HasPerasVoteRound vote => + HasPerasVoteRound (WithArrivalTime vote) + where + getPerasVoteRound = getPerasVoteRound . forgetArrivalTime + +class HasPerasVoteVotedBlock vote blk | vote -> blk where + getPerasVoteVotedBlock :: vote -> Point blk +instance HasPerasVoteVotedBlock (PerasVote blk) blk where + getPerasVoteVotedBlock = pvVotedBlock +instance HasPerasVoteVotedBlock (ValidatedPerasVote blk) blk where + getPerasVoteVotedBlock = getPerasVoteVotedBlock . vpvVote +instance + HasPerasVoteVotedBlock vote blk => + HasPerasVoteVotedBlock (WithArrivalTime vote) blk + where + getPerasVoteVotedBlock = getPerasVoteVotedBlock . forgetArrivalTime + +class HasStakePoolId vote where + getStakePoolId :: vote -> StakePoolId +instance HasStakePoolId (PerasVote blk) where + getStakePoolId = pvVoteStakePoolId +instance HasStakePoolId (ValidatedPerasVote blk) where + getStakePoolId = getStakePoolId . vpvVote +instance + HasStakePoolId vote => + HasStakePoolId (WithArrivalTime vote) + where + getStakePoolId = getStakePoolId . forgetArrivalTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs new file mode 100644 index 0000000000..e2fc18cb01 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -0,0 +1 @@ +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs new file mode 100644 index 0000000000..4742edabf9 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs @@ -0,0 +1,54 @@ +-- | This module defines type aliases for the ObjectDiffusion protocol applied +-- to PerasVote diffusion. +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasVote + ( TracePerasVoteDiffusionInbound + , TracePerasVoteDiffusionOutbound + , PerasVotePoolReader + , PerasVotePoolWriter + , PerasVoteDiffusionInboundPipelined + , PerasVoteDiffusionOutbound + , PerasVoteDiffusion + , PerasVoteDiffusionInboundState + , PerasVoteDiffusionInboundHandle + , PerasVoteDiffusionInboundHandleCollection + ) 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.PerasVoteDB.API +import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound (ObjectDiffusionInboundPipelined) +import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (ObjectDiffusionOutbound) +import Ouroboros.Network.Protocol.ObjectDiffusion.Type (ObjectDiffusion) + +type TracePerasVoteDiffusionInbound blk = + TraceObjectDiffusionInbound PerasRoundNo (PerasVote blk) + +type TracePerasVoteDiffusionOutbound blk = + TraceObjectDiffusionOutbound PerasRoundNo (PerasVote blk) + +type PerasVotePoolReader blk m = + ObjectPoolReader PerasRoundNo (PerasVote blk) PerasVoteTicketNo m + +type PerasVotePoolWriter blk m = + ObjectPoolWriter PerasRoundNo (PerasVote blk) m + +type PerasVoteDiffusionInboundPipelined blk m a = + ObjectDiffusionInboundPipelined PerasRoundNo (PerasVote blk) m a + +type PerasVoteDiffusionOutbound blk m a = + ObjectDiffusionOutbound PerasRoundNo (PerasVote blk) m a + +type PerasVoteDiffusion blk = + ObjectDiffusion PerasRoundNo (PerasVote blk) + +type PerasVoteDiffusionInboundState blk = + ObjectDiffusionInboundState blk + +type PerasVoteDiffusionInboundHandle m blk = + ObjectDiffusionInboundHandle m blk + +type PerasVoteDiffusionInboundHandleCollection peer m blk = + ObjectDiffusionInboundHandleCollection peer m 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 6a4fc87229..8b69597daa 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Serialisation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -36,6 +37,8 @@ module Ouroboros.Consensus.Node.Serialisation , Some (..) ) where +import qualified Cardano.Binary as KeyHash +import Cardano.Ledger.Core import Codec.CBOR.Decoding (Decoder, decodeListLenOf) import Codec.CBOR.Encoding (Encoding, encodeListLen) import Codec.Serialise (Serialise (decode, encode)) @@ -206,6 +209,22 @@ instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasCert blk) where pcCertRound <- decodeNodeToNode ccfg version pcCertBoostedBlock <- decodeNodeToNode ccfg version pure $ PerasCert pcCertRound pcCertBoostedBlock +instance ConvertRawHash blk => SerialiseNodeToNode blk (PerasVote blk) where + -- Consistent with the 'Serialise' instance for 'PerasVote' defined in Ouroboros.Consensus.Block.SupportsPeras + encodeNodeToNode ccfg version PerasVote{..} = + encodeListLen 2 + <> encodeNodeToNode ccfg version pvVoteRound + <> encodeNodeToNode ccfg version pvVotedBlock + decodeNodeToNode ccfg version = do + decodeListLenOf 3 + pvVoteRound <- decodeNodeToNode ccfg version + pvVotedBlock <- decodeNodeToNode ccfg version + pvVoteStakePoolId <- decodeNodeToNode ccfg version + pure $ PerasVote pvVoteRound pvVotedBlock pvVoteStakePoolId + +instance SerialiseNodeToNode blk (KeyHash 'StakePool) where + encodeNodeToNode _ccfg _version = KeyHash.toCBOR + decodeNodeToNode _ccfg _version = KeyHash.fromCBOR deriving newtype instance SerialiseNodeToClient blk (GenTxId blk) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs new file mode 100644 index 0000000000..d0e5c8b803 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs @@ -0,0 +1 @@ +module Ouroboros.Consensus.Storage.PerasVoteDB where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs new file mode 100644 index 0000000000..e762c85652 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Consensus.Storage.PerasVoteDB.API + ( PerasVoteDB (..) + , AddPerasVoteResult (..) + + -- * 'PerasVoteSnapshot' + , PerasVoteSnapshot (..) + , PerasVoteTicketNo + , zeroPerasVoteTicketNo + ) where + +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 PerasVoteDB m blk = PerasVoteDB + { addVote :: WithArrivalTime (ValidatedPerasVote blk) -> m AddPerasVoteResult + -- ^ Add a Peras vote to the database. The result indicates whether + -- the vote was actually added, or if it was already present. + , 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 vote is added, but it + -- stays the same when votes are garbage-collected. + , getVoteSnapshot :: STM m (PerasVoteSnapshot blk) + , getLatestVoteSeen :: STM m (Maybe (WithArrivalTime (ValidatedPerasVote blk))) + -- ^ Get the vote with the highest round number that has been added to + -- the db since it has been opened. This vote is not affected by garbage + -- collection, but it's forgotten when the db is closed. + -- + -- NOTE: having seen a vote 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 () + } + deriving NoThunks via OnlyCheckWhnfNamed "PerasVoteDB" (PerasVoteDB m blk) + +data AddPerasVoteResult = AddedPerasVoteToDB | PerasVoteAlreadyInDB + deriving stock (Show, Eq) + +data PerasVoteSnapshot blk = PerasVoteSnapshot + { containsVote :: PerasRoundNo -> Bool + -- ^ Do we have the vote for this round? + , getVotesAfter :: + PerasVoteTicketNo -> + Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)) + -- ^ Get votes after the given ticket number (excluded). + -- The result is a map of ticket numbers to validated votes. + } + +-- | A sequence number, incremented every time we receive a new vote. +-- +-- Note that we will /usually/ receive votes monotonically by round +-- number, so round numbers could /almost/ fulfill the role of ticket numbers. +-- However, in certain edge cases (while catching up, or during cooldowns), this +-- might not be true, such as during syncing or during cooldown periods. +-- Therefore, for robustness, we choose to maintain dedicated ticket numbers +-- separately. +newtype PerasVoteTicketNo = PerasVoteTicketNo Word64 + deriving stock Show + deriving newtype (Eq, Ord, Enum, NoThunks) + +zeroPerasVoteTicketNo :: PerasVoteTicketNo +zeroPerasVoteTicketNo = PerasVoteTicketNo 0 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs new file mode 100644 index 0000000000..c24a9f2846 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -0,0 +1 @@ +module Ouroboros.Consensus.Storage.PerasVoteDB.Impl where From c48452ac5c1be03eb9cf05a281ecb788badf9ef0 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 21 Nov 2025 14:12:24 +0100 Subject: [PATCH 2/5] VoteDB first implementation --- .../Consensus/Block/SupportsPeras.hs | 204 +++++++++-- .../ObjectDiffusion/ObjectPool/PerasVote.hs | 2 +- .../Consensus/Storage/PerasVoteDB.hs | 2 +- .../Consensus/Storage/PerasVoteDB/API.hs | 67 ++-- .../Consensus/Storage/PerasVoteDB/Impl.hs | 335 +++++++++++++++++- 5 files changed, 553 insertions(+), 57 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 0c2c5a4a4c..f52081cb5b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -8,7 +8,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -17,20 +16,28 @@ module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) , onPerasRoundNo + , PerasVoteStake (..) , PerasWeight (..) , BlockSupportsPeras (..) , PerasCert (..) , PerasVote (..) + , PerasVoteTarget , PerasCfg (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) + , PerasVoteAggregate (..) + , emptyPerasVoteAggregate + , updatePerasVoteAggregate + , UpdatePerasVoteAggregateResult (..) , makePerasCfg + , HasId (..) , HasPerasCertRound (..) , HasPerasCertBoostedBlock (..) , HasPerasCertBoost (..) , HasPerasVoteRound (..) , HasPerasVoteVotedBlock (..) - , HasStakePoolId (..) + , HasPerasVoteVoterId (..) + , HasPerasVoteTarget (..) -- * Ouroboros Peras round length , PerasRoundLength (..) @@ -39,14 +46,16 @@ module Ouroboros.Consensus.Block.SupportsPeras import qualified Cardano.Binary as KeyHash import Cardano.Ledger.Core (KeyHash, KeyRole (StakePool)) -import Cardano.Ledger.State (IndividualPoolStake (..), PoolDistr (PoolDistr, unPoolDistr)) import Codec.Serialise (Serialise (..)) import Codec.Serialise.Decoding (decodeListLenOf) import Codec.Serialise.Encoding (encodeListLen) +import Control.Applicative ((<|>)) import Data.Coerce (coerce) -import qualified Data.Map as Map +import Data.Maybe (isNothing) import Data.Monoid (Sum (..)) import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class @@ -56,13 +65,40 @@ import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Quiet (Quiet (..)) +class + ( Ord (IdOf a) + , Eq (IdOf a) + , Show (IdOf a) + , NoThunks (IdOf a) + , Serialise (IdOf a) + ) => + HasId a + where + type IdOf a + getId :: a -> IdOf a + +instance HasId perasObj => HasId (WithArrivalTime perasObj) where + type IdOf (WithArrivalTime perasObj) = IdOf perasObj + getId = getId . forgetArrivalTime + newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} deriving Show via Quiet PerasRoundNo deriving stock Generic deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, Serialise) +newtype PerasVoteStake = PerasVoteStake {unPerasVoteStake :: Rational} + deriving Show via Quiet PerasVoteStake + deriving stock Generic + deriving newtype (Enum, Eq, Ord, Num, Fractional, NoThunks, Serialise) + deriving Semigroup via Sum Rational + deriving Monoid via Sum Rational + +data PerasVoteStakeDistr +getPerasVoteStakeOf :: PerasVoteStakeDistr -> VoterId -> PerasVoteStake +getPerasVoteStakeOf = undefined + -- | TODO: what is the proper underlying type? -type StakePoolId = KeyHash 'StakePool +type VoterId = KeyHash 'StakePool instance Condense PerasRoundNo where condense = show . unPerasRoundNo @@ -98,15 +134,39 @@ data ValidatedPerasCert blk = ValidatedPerasCert deriving stock (Show, Eq, Ord, Generic) deriving anyclass NoThunks -deriving instance Ord IndividualPoolStake +instance + ( HasId (PerasCert blk) + , Ord (IdOf (PerasCert blk)) + , Eq (IdOf (PerasCert blk)) + , Show (IdOf (PerasCert blk)) + , NoThunks (IdOf (PerasCert blk)) + , Serialise (IdOf (PerasCert blk)) + ) => + HasId (ValidatedPerasCert blk) + where + type IdOf (ValidatedPerasCert blk) = IdOf (PerasCert blk) + getId = getId . vpcCert data ValidatedPerasVote blk = ValidatedPerasVote { vpvVote :: !(PerasVote blk) - , vpvVoteStake :: !IndividualPoolStake + , vpvVoteStake :: !PerasVoteStake } deriving stock (Show, Eq, Ord, Generic) deriving anyclass NoThunks +instance + ( HasId (PerasVote blk) + , Ord (IdOf (PerasVote blk)) + , Eq (IdOf (PerasVote blk)) + , Show (IdOf (PerasVote blk)) + , NoThunks (IdOf (PerasVote blk)) + , Serialise (IdOf (PerasVote blk)) + ) => + HasId (ValidatedPerasVote blk) + where + type IdOf (ValidatedPerasVote blk) = IdOf (PerasVote blk) + getId = getId . vpvVote + {------------------------------------------------------------------------------- Ouroboros Peras round length -------------------------------------------------------------------------------} @@ -144,9 +204,80 @@ class validatePerasVote :: PerasCfg blk -> PerasVote blk -> - PoolDistr -> + PerasVoteStakeDistr -> Either (PerasValidationErr blk) (ValidatedPerasVote blk) +const_PERAS_QUORUM_THRESHOLD :: PerasVoteStake +const_PERAS_QUORUM_THRESHOLD = PerasVoteStake 0.75 + +data PerasVoteAggregate blk = PerasVoteAggregate + { pvaTarget :: !(PerasVoteTarget blk) + , pvaVotes :: !(Set (WithArrivalTime (ValidatedPerasVote blk))) + , pvaTotalStake :: !PerasVoteStake + , pvaMaybeCert :: !(Maybe (ValidatedPerasCert blk)) + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + +emptyPerasVoteAggregate :: PerasVoteTarget blk -> PerasVoteAggregate blk +emptyPerasVoteAggregate target = + PerasVoteAggregate + { pvaTotalStake = PerasVoteStake 0 + , pvaTarget = target + , pvaVotes = Set.empty + , pvaMaybeCert = Nothing + } + +data UpdatePerasVoteAggregateResult blk + = IncorrectPerasVoteTarget + | AddedPerasVoteButDidntGenerateNewCert (PerasVoteAggregate blk) + | AddedPerasVoteAndGeneratedNewCert (PerasVoteAggregate blk) (ValidatedPerasCert blk) + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + +updatePerasVoteAggregate :: + StandardHash blk => + PerasVoteAggregate blk -> + WithArrivalTime (ValidatedPerasVote blk) -> + UpdatePerasVoteAggregateResult blk +updatePerasVoteAggregate + pva@PerasVoteAggregate + { pvaTarget = (roundNo, point) + , pvaVotes = existingVotes + , pvaTotalStake = initialStake + , pvaMaybeCert = mExistingCert + } + vote = + if getPerasVoteRound vote == roundNo && getPerasVoteVotedBlock vote == point + then + let pvaTotalStake = initialStake + vpvVoteStake (forgetArrivalTime vote) + pvaVotes = Set.insert vote existingVotes + mNewCert = + if isNothing mExistingCert && pvaTotalStake >= const_PERAS_QUORUM_THRESHOLD + then + Just $ + ValidatedPerasCert + { vpcCertBoost = boostPerCert + , vpcCert = + PerasCert + { pcCertRound = roundNo + , pcCertBoostedBlock = point + } + } + else Nothing + pva' = + pva + { pvaVotes + , pvaTotalStake + , pvaMaybeCert = mExistingCert <|> mNewCert + } + in case mNewCert of + Just cert -> AddedPerasVoteAndGeneratedNewCert pva' cert + Nothing -> AddedPerasVoteButDidntGenerateNewCert pva' + else IncorrectPerasVoteTarget + +type PerasVoteTarget blk = (PerasRoundNo, Point blk) + -- 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 @@ -168,7 +299,7 @@ instance StandardHash blk => BlockSupportsPeras blk where data PerasVote blk = PerasVote { pvVoteRound :: PerasRoundNo , pvVotedBlock :: Point blk - , pvVoteStakePoolId :: StakePoolId + , pvVoteVoterId :: VoterId } deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks @@ -189,10 +320,23 @@ instance StandardHash blk => BlockSupportsPeras blk where , vpcCertBoost = perasCfgWeightBoost cfg } - validatePerasVote _cfg vote PoolDistr{unPoolDistr} = - let stake = unPoolDistr Map.! (pvVoteStakePoolId vote) + validatePerasVote _cfg vote stakeDistr = + let stake = getPerasVoteStakeOf stakeDistr (pvVoteVoterId vote) in Right (ValidatedPerasVote{vpvVote = vote, vpvVoteStake = stake}) +instance HasId (PerasCert blk) where + type IdOf (PerasCert blk) = PerasRoundNo + getId = pcCertRound + +-- TODO: Orphan instance +instance Serialise (KeyHash 'StakePool) where + encode = KeyHash.toCBOR + decode = KeyHash.fromCBOR + +instance HasId (PerasVote blk) where + type IdOf (PerasVote blk) = (PerasRoundNo, VoterId) + getId vote = (pvVoteRound vote, pvVoteVoterId vote) + instance ShowProxy blk => ShowProxy (PerasCert blk) where showProxy _ = "PerasCert " <> showProxy (Proxy @blk) @@ -211,17 +355,17 @@ instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where pure $ PerasCert{pcCertRound, pcCertBoostedBlock} instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where - encode PerasVote{pvVoteRound, pvVotedBlock, pvVoteStakePoolId} = + encode PerasVote{pvVoteRound, pvVotedBlock, pvVoteVoterId} = encodeListLen 3 <> encode pvVoteRound <> encode pvVotedBlock - <> KeyHash.toCBOR pvVoteStakePoolId + <> KeyHash.toCBOR pvVoteVoterId decode = do decodeListLenOf 3 pvVoteRound <- decode pvVotedBlock <- decode - pvVoteStakePoolId <- KeyHash.fromCBOR - pure $ PerasVote{pvVoteRound, pvVotedBlock, pvVoteStakePoolId} + pvVoteVoterId <- KeyHash.fromCBOR + pure $ PerasVote{pvVoteRound, pvVotedBlock, pvVoteVoterId} -- | Derive a 'PerasCfg' from a 'BlockConfig' -- @@ -303,14 +447,26 @@ instance where getPerasVoteVotedBlock = getPerasVoteVotedBlock . forgetArrivalTime -class HasStakePoolId vote where - getStakePoolId :: vote -> StakePoolId -instance HasStakePoolId (PerasVote blk) where - getStakePoolId = pvVoteStakePoolId -instance HasStakePoolId (ValidatedPerasVote blk) where - getStakePoolId = getStakePoolId . vpvVote +class HasPerasVoteVoterId vote where + getPerasVoteVoterId :: vote -> VoterId +instance HasPerasVoteVoterId (PerasVote blk) where + getPerasVoteVoterId = pvVoteVoterId +instance HasPerasVoteVoterId (ValidatedPerasVote blk) where + getPerasVoteVoterId = getPerasVoteVoterId . vpvVote +instance + HasPerasVoteVoterId vote => + HasPerasVoteVoterId (WithArrivalTime vote) + where + getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime + +class HasPerasVoteTarget vote blk | vote -> blk where + getPerasVoteTarget :: vote -> PerasVoteTarget blk +instance HasPerasVoteTarget (PerasVote blk) blk where + getPerasVoteTarget vote = (pvVoteRound vote, pvVotedBlock vote) +instance HasPerasVoteTarget (ValidatedPerasVote blk) blk where + getPerasVoteTarget vote = getPerasVoteTarget (vpvVote vote) instance - HasStakePoolId vote => - HasStakePoolId (WithArrivalTime vote) + HasPerasVoteTarget vote blk => + HasPerasVoteTarget (WithArrivalTime vote) blk where - getStakePoolId = getStakePoolId . forgetArrivalTime + getPerasVoteTarget = getPerasVoteTarget . forgetArrivalTime diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs index e2fc18cb01..8845a2e33c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/ObjectPool/PerasVote.hs @@ -1 +1 @@ -module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote where +module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote () where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs index d0e5c8b803..b30ffb2526 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB.hs @@ -1 +1 @@ -module Ouroboros.Consensus.Storage.PerasVoteDB where +module Ouroboros.Consensus.Storage.PerasVoteDB () where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index e762c85652..5d47127995 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,52 +11,64 @@ module Ouroboros.Consensus.Storage.PerasVoteDB.API -- * 'PerasVoteSnapshot' , PerasVoteSnapshot (..) + , PerasStakeSnapshot (..) , PerasVoteTicketNo , zeroPerasVoteTicketNo + , getPerasCertsFromStakeSnapshot ) where import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set import Data.Word (Word64) +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.Util.IOLike +import Ouroboros.Consensus.Util.MonadSTM.NormalForm + ( MonadSTM (STM) + ) import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) data PerasVoteDB m blk = PerasVoteDB - { addVote :: WithArrivalTime (ValidatedPerasVote blk) -> m AddPerasVoteResult + { addVote :: WithArrivalTime (ValidatedPerasVote blk) -> m (AddPerasVoteResult blk) -- ^ Add a Peras vote to the database. The result indicates whether -- the vote was actually added, or if it was already present. - , 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. + , getStakeSnapshot :: STM m (PerasStakeSnapshot blk) + -- ^ Return a view of accumulated vote stake per (point, round) -- - -- The 'Fingerprint' is updated every time a new vote is added, but it + -- The underlying 'Fingerprint' is updated every time a new vote is added, but it -- stays the same when votes are garbage-collected. , getVoteSnapshot :: STM m (PerasVoteSnapshot blk) - , getLatestVoteSeen :: STM m (Maybe (WithArrivalTime (ValidatedPerasVote blk))) - -- ^ Get the vote with the highest round number that has been added to - -- the db since it has been opened. This vote is not affected by garbage - -- collection, but it's forgotten when the db is closed. - -- - -- NOTE: having seen a vote 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. + -- ^ Interface to read the known votes, mostly for diffusion + , garbageCollect :: PerasRoundNo -> m () + -- ^ Garbage-collect state strictly older than the given slot number. , closeDB :: m () } deriving NoThunks via OnlyCheckWhnfNamed "PerasVoteDB" (PerasVoteDB m blk) -data AddPerasVoteResult = AddedPerasVoteToDB | PerasVoteAlreadyInDB - deriving stock (Show, Eq) +data AddPerasVoteResult blk + = PerasVoteAlreadyInDB + | AddedPerasVoteButDidntGenerateNewCert + | AddedPerasVoteAndGeneratedNewCert (ValidatedPerasCert blk) + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + +newtype PerasStakeSnapshot blk = PerasStakeSnapshot + {unPerasStakeSnapshot :: WithFingerprint (Map (PerasVoteTarget blk) (PerasVoteAggregate blk))} + deriving Generic + deriving newtype NoThunks + +getPerasCertsFromStakeSnapshot :: + StandardHash blk => + PerasStakeSnapshot blk -> + Set (ValidatedPerasCert blk) +getPerasCertsFromStakeSnapshot (PerasStakeSnapshot mp) = + Set.fromList $ Map.elems $ Map.mapMaybe pvaMaybeCert (forgetFingerprint mp) data PerasVoteSnapshot blk = PerasVoteSnapshot - { containsVote :: PerasRoundNo -> Bool - -- ^ Do we have the vote for this round? + { containsVote :: IdOf (PerasVote blk) -> Bool , getVotesAfter :: PerasVoteTicketNo -> Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk)) @@ -63,13 +77,6 @@ data PerasVoteSnapshot blk = PerasVoteSnapshot } -- | A sequence number, incremented every time we receive a new vote. --- --- Note that we will /usually/ receive votes monotonically by round --- number, so round numbers could /almost/ fulfill the role of ticket numbers. --- However, in certain edge cases (while catching up, or during cooldowns), this --- might not be true, such as during syncing or during cooldown periods. --- Therefore, for robustness, we choose to maintain dedicated ticket numbers --- separately. newtype PerasVoteTicketNo = PerasVoteTicketNo Word64 deriving stock Show deriving newtype (Eq, Ord, Enum, NoThunks) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index c24a9f2846..3dcbaab054 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -1 +1,334 @@ -module Ouroboros.Consensus.Storage.PerasVoteDB.Impl where +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Ouroboros.Consensus.Storage.PerasVoteDB.Impl + ( -- * Opening + PerasVoteDbArgs (..) + , defaultArgs + , openDB + + -- * Trace types + , TraceEvent (..) + + -- * Exceptions + , PerasVoteDbError (..) + ) where + +import Control.Monad (when) +import Control.Monad.Except (throwError) +import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Foldable (for_) +import Data.Foldable qualified as Foldable +import Data.Functor ((<&>)) +import Data.Kind (Type) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import GHC.Generics (Generic) +import NoThunks.Class +import Ouroboros.Consensus.Block hiding (UpdatePerasVoteAggregateResult (..)) +import Ouroboros.Consensus.Block.SupportsPeras qualified as UPVAR +import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (forgetArrivalTime)) +import Ouroboros.Consensus.Peras.Weight +import Ouroboros.Consensus.Storage.PerasVoteDB.API +import Ouroboros.Consensus.Util.Args +import Ouroboros.Consensus.Util.CallStack +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.STM + +{------------------------------------------------------------------------------ + Opening the database +------------------------------------------------------------------------------} + +type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type +data PerasVoteDbArgs f m blk = PerasVoteDbArgs + { pvdbaTracer :: Tracer m (TraceEvent blk) + } + +defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk +defaultArgs = + PerasVoteDbArgs + { pvdbaTracer = nullTracer + } + +openDB :: + forall m blk. + ( IOLike m + , StandardHash blk + ) => + Complete PerasVoteDbArgs m blk -> + m (PerasVoteDB m blk) +openDB args = do + pvdbPerasVoteStateVar <- + newTVarWithInvariantIO + (either Just (const Nothing) . invariantForPerasVoteState) + initialPerasVoteState + let env = + PerasVoteDbEnv + { pvdbTracer + , pvdbPerasVoteStateVar + } + h <- PerasVoteDbHandle <$> newTVarIO (PerasVoteDbOpen env) + traceWith pvdbTracer OpenedPerasVoteDB + pure + PerasVoteDB + { addVote = getEnv1 h implAddVote + , getStakeSnapshot = getEnvSTM h implGetStakeSnapshot + , getVoteSnapshot = getEnvSTM h implGetVoteSnapshot + , garbageCollect = getEnv1 h implGarbageCollect + , closeDB = implCloseDB h + } + where + PerasVoteDbArgs + { pvdbaTracer = pvdbTracer + } = args + +{------------------------------------------------------------------------------- + Database state +-------------------------------------------------------------------------------} + +newtype PerasVoteDbHandle m blk = PerasVoteDbHandle (StrictTVar m (PerasVoteDbState m blk)) + +data PerasVoteDbState m blk + = PerasVoteDbOpen !(PerasVoteDbEnv m blk) + | PerasVoteDbClosed + deriving stock Generic + deriving anyclass NoThunks + +data PerasVoteDbEnv m blk = PerasVoteDbEnv + { pvdbTracer :: !(Tracer m (TraceEvent blk)) + , pvdbPerasVoteStateVar :: !(StrictTVar m (WithFingerprint (PerasVoteState blk))) + -- ^ The 'RoundNo's of all votes currently in the db. + } + deriving NoThunks via OnlyCheckWhnfNamed "PerasVoteDbEnv" (PerasVoteDbEnv m blk) + +getEnv :: + (IOLike m, HasCallStack) => + PerasVoteDbHandle m blk -> + (PerasVoteDbEnv m blk -> m r) -> + m r +getEnv (PerasVoteDbHandle varState) f = + readTVarIO varState >>= \case + PerasVoteDbOpen env -> f env + PerasVoteDbClosed -> throwIO $ ClosedDBError prettyCallStack + +getEnv1 :: + (IOLike m, HasCallStack) => + PerasVoteDbHandle m blk -> + (PerasVoteDbEnv m blk -> a -> m r) -> + a -> + m r +getEnv1 h f a = getEnv h (\env -> f env a) + +getEnvSTM :: + (IOLike m, HasCallStack) => + PerasVoteDbHandle m blk -> + (PerasVoteDbEnv m blk -> STM m r) -> + STM m r +getEnvSTM (PerasVoteDbHandle varState) f = + readTVar varState >>= \case + PerasVoteDbOpen env -> f env + PerasVoteDbClosed -> throwIO $ ClosedDBError prettyCallStack + +{------------------------------------------------------------------------------- + API implementation +-------------------------------------------------------------------------------} + +implCloseDB :: IOLike m => PerasVoteDbHandle m blk -> m () +implCloseDB (PerasVoteDbHandle varState) = + atomically (swapTVar varState PerasVoteDbClosed) >>= \case + PerasVoteDbOpen PerasVoteDbEnv{pvdbTracer} -> do + traceWith pvdbTracer ClosedPerasVoteDB + -- DB was already closed. + PerasVoteDbClosed -> pure () + +-- TODO: we will need to update this method with non-trivial validation logic +-- see https://github.com/tweag/cardano-peras/issues/120 +implAddVote :: + ( IOLike m + , StandardHash blk + ) => + PerasVoteDbEnv m blk -> + WithArrivalTime (ValidatedPerasVote blk) -> + m (AddPerasVoteResult blk) +implAddVote env vote = do + traceWith pvdbTracer $ AddingPerasVote voteTarget voteId voteStake + + res <- atomically $ do + WithFingerprint + PerasVoteState + { pvsVoteIds + , pvsVotesByTarget + , pvsVotesByTicket + , pvsLastTicketNo + } + fp <- + readTVar pvdbPerasVoteStateVar + + if Set.member voteId (pvsVoteIds) + then pure PerasVoteAlreadyInDB + else do + let pvsVoteIds' = Set.insert voteId (pvsVoteIds) + (res, pvsVotesByTarget') = + Map.alterF + ( \mExistingAggr -> + let aggr = fromMaybe (emptyPerasVoteAggregate voteTarget) mExistingAggr + in case updatePerasVoteAggregate aggr vote of + UPVAR.IncorrectPerasVoteTarget -> error "The aggregate should match the vote target." + UPVAR.AddedPerasVoteButDidntGenerateNewCert aggr' -> (AddedPerasVoteButDidntGenerateNewCert, Just aggr') + UPVAR.AddedPerasVoteAndGeneratedNewCert aggr' cert -> (AddedPerasVoteAndGeneratedNewCert cert, Just aggr') + ) + voteTarget + pvsVotesByTarget + pvsLastTicketNo' = succ pvsLastTicketNo + pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote pvsVotesByTicket + fp' = succ fp + writeTVar pvdbPerasVoteStateVar $ + WithFingerprint + PerasVoteState + { pvsVoteIds = pvsVoteIds' + , pvsVotesByTarget = pvsVotesByTarget' + , pvsVotesByTicket = pvsVotesByTicket' + , pvsLastTicketNo = pvsLastTicketNo' + } + fp' + pure res + + case res of + PerasVoteAlreadyInDB -> traceWith pvdbTracer $ IgnoredVoteAlreadyInDB voteId + AddedPerasVoteButDidntGenerateNewCert -> traceWith pvdbTracer $ AddedPerasVote voteId + AddedPerasVoteAndGeneratedNewCert newCert -> do + traceWith pvdbTracer $ AddedPerasVote voteId + traceWith pvdbTracer $ GeneratedPerasCert newCert + pure res + where + PerasVoteDbEnv + { pvdbTracer + , pvdbPerasVoteStateVar + } = env + + voteTarget = getPerasVoteTarget vote + voteId = getId vote + voteStake = vpvVoteStake . forgetArrivalTime $ vote + +implGetStakeSnapshot :: + IOLike m => + PerasVoteDbEnv m blk -> STM m (PerasStakeSnapshot blk) +implGetStakeSnapshot PerasVoteDbEnv{pvdbPerasVoteStateVar} = do + perasVoteState <- readTVar pvdbPerasVoteStateVar + let unPerasStakeSnapshot = pvsVotesByTarget <$> perasVoteState + pure $ PerasStakeSnapshot{unPerasStakeSnapshot} + +implGetVoteSnapshot :: + IOLike m => + PerasVoteDbEnv m blk -> STM m (PerasVoteSnapshot blk) +implGetVoteSnapshot PerasVoteDbEnv{pvdbPerasVoteStateVar} = do + PerasVoteState{pvsVoteIds, pvsVotesByTicket} <- forgetFingerprint <$> readTVar pvdbPerasVoteStateVar + pure $ + PerasVoteSnapshot + { containsVote = (`Set.member` pvsVoteIds) + , getVotesAfter = \ticketNo -> + snd $ Map.split ticketNo pvsVotesByTicket + } + +implGarbageCollect :: + forall m blk. + IOLike m => + PerasVoteDbEnv m blk -> PerasRoundNo -> m () +implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = + -- No need to update the 'Fingerprint' as we only remove votes that do + -- not matter for comparing interesting chains. + atomically $ modifyTVar pvdbPerasVoteStateVar (fmap gc) + where + gc :: PerasVoteState blk -> PerasVoteState blk + gc + PerasVoteState + { pvsVoteIds + , pvsVotesByTarget + , pvsVotesByTicket + , pvsLastTicketNo + } = + let pvsVotesByTarget' = + Map.filterWithKey + (\(rNo, _) _ -> rNo >= roundNo) + pvsVotesByTarget + (pvsVotesByTicket', votesToRemove) = Map.partition (\vote -> getPerasVoteRound vote >= roundNo) pvsVotesByTicket + pvsVoteIds' = + Foldable.foldl' + (\set vote -> Set.delete (getId vote) set) + pvsVoteIds + votesToRemove + in PerasVoteState + { pvsVoteIds = pvsVoteIds' + , pvsVotesByTarget = pvsVotesByTarget' + , pvsVotesByTicket = pvsVotesByTicket' + , pvsLastTicketNo = pvsLastTicketNo + } + +{------------------------------------------------------------------------------- + Implementation-internal types +-------------------------------------------------------------------------------} + +data PerasVoteState blk = PerasVoteState + { pvsVoteIds :: !(Set (IdOf (PerasVote blk))) + , pvsVotesByTarget :: !(Map (PerasVoteTarget blk) (PerasVoteAggregate blk)) + , pvsVotesByTicket :: !(Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))) + -- ^ The votes by 'PerasVoteTicketNo'. + -- + -- INVARIANT: In sync with 'pvsVotesByTarget'. + , pvsLastTicketNo :: !PerasVoteTicketNo + -- ^ The most recent 'PerasVoteTicketNo' (or 'zeroPerasVoteTicketNo' + -- otherwise). + } + deriving stock (Show, Generic) + deriving anyclass NoThunks + +initialPerasVoteState :: WithFingerprint (PerasVoteState blk) +initialPerasVoteState = + WithFingerprint + PerasVoteState + { pvsVoteIds = Set.empty + , pvsVotesByTarget = Map.empty + , pvsVotesByTicket = Map.empty + , pvsLastTicketNo = zeroPerasVoteTicketNo + } + (Fingerprint 0) + +-- | Check that the fields of 'PerasVoteState' are in sync. +invariantForPerasVoteState :: + WithFingerprint (PerasVoteState blk) -> Either String () +invariantForPerasVoteState _pvs = + -- TODO + pure () + +{------------------------------------------------------------------------------- + Trace types +-------------------------------------------------------------------------------} + +data TraceEvent blk + = OpenedPerasVoteDB + | ClosedPerasVoteDB + | AddingPerasVote (PerasVoteTarget blk) (IdOf (PerasVote blk)) PerasVoteStake + | AddedPerasVote (IdOf (PerasVote blk)) + | IgnoredVoteAlreadyInDB (IdOf (PerasVote blk)) + | GeneratedPerasCert (ValidatedPerasCert blk) + deriving stock (Show, Eq, Generic) + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +data PerasVoteDbError + = ClosedDBError PrettyCallStack + deriving stock Show + deriving anyclass Exception From c93a0f26ee2c4c75f448057ffbee1ebf3efdcfd8 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Thu, 27 Nov 2025 10:47:38 +0100 Subject: [PATCH 3/5] Change PerasVoteAggregate{,Status} datatype to a GADT instead of a record --- .../Consensus/Block/SupportsPeras.hs | 118 +++++++++++------- .../Consensus/Storage/PerasVoteDB/API.hs | 4 +- .../Consensus/Storage/PerasVoteDB/Impl.hs | 17 +-- 3 files changed, 84 insertions(+), 55 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 f52081cb5b..585ee5cc0a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -12,6 +12,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Ouroboros.Consensus.Block.SupportsPeras ( PerasRoundNo (..) @@ -26,9 +28,11 @@ module Ouroboros.Consensus.Block.SupportsPeras , ValidatedPerasCert (..) , ValidatedPerasVote (..) , PerasVoteAggregate (..) - , emptyPerasVoteAggregate + , PerasVoteAggregateStatus (..) + , pvasMaybeCert + , emptyPerasVoteAggregateStatus , updatePerasVoteAggregate - , UpdatePerasVoteAggregateResult (..) + , updatePerasVoteAggregateStatus , makePerasCfg , HasId (..) , HasPerasCertRound (..) @@ -51,6 +55,8 @@ import Codec.Serialise.Decoding (decodeListLenOf) import Codec.Serialise.Encoding (encodeListLen) import Control.Applicative ((<|>)) import Data.Coerce (coerce) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Maybe (isNothing) import Data.Monoid (Sum (..)) import Data.Proxy (Proxy (..)) @@ -212,69 +218,89 @@ const_PERAS_QUORUM_THRESHOLD = PerasVoteStake 0.75 data PerasVoteAggregate blk = PerasVoteAggregate { pvaTarget :: !(PerasVoteTarget blk) - , pvaVotes :: !(Set (WithArrivalTime (ValidatedPerasVote blk))) + , pvaVotes :: !(Map (IdOf (PerasVote blk)) (WithArrivalTime (ValidatedPerasVote blk))) , pvaTotalStake :: !PerasVoteStake - , pvaMaybeCert :: !(Maybe (ValidatedPerasCert blk)) } deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks -emptyPerasVoteAggregate :: PerasVoteTarget blk -> PerasVoteAggregate blk -emptyPerasVoteAggregate target = - PerasVoteAggregate - { pvaTotalStake = PerasVoteStake 0 - , pvaTarget = target - , pvaVotes = Set.empty - , pvaMaybeCert = Nothing - } - -data UpdatePerasVoteAggregateResult blk - = IncorrectPerasVoteTarget - | AddedPerasVoteButDidntGenerateNewCert (PerasVoteAggregate blk) - | AddedPerasVoteAndGeneratedNewCert (PerasVoteAggregate blk) (ValidatedPerasCert blk) +data PerasVoteAggregateStatus blk + = PerasVoteAggregateQuorumNotReached {pvasVoteAggregate :: !(PerasVoteAggregate blk)} + | PerasVoteAggregateQuorumReachedAlready + {pvasVoteAggregate :: !(PerasVoteAggregate blk), pvasCert :: ValidatedPerasCert blk} deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks +pvasMaybeCert :: PerasVoteAggregateStatus blk -> Maybe (ValidatedPerasCert blk) +pvasMaybeCert aggr = case aggr of + PerasVoteAggregateQuorumNotReached{} -> Nothing + PerasVoteAggregateQuorumReachedAlready{pvasCert} -> Just pvasCert + +emptyPerasVoteAggregateStatus :: PerasVoteTarget blk -> PerasVoteAggregateStatus blk +emptyPerasVoteAggregateStatus target = + PerasVoteAggregateQuorumNotReached $ + PerasVoteAggregate + { pvaTotalStake = PerasVoteStake 0 + , pvaTarget = target + , pvaVotes = Map.empty + } + +-- | Add a vote to an existing aggregate if it isn't already present, and update +-- the stake accordingly. +-- PRECONDITION: the vote's target must match the aggregate's target. updatePerasVoteAggregate :: StandardHash blk => PerasVoteAggregate blk -> WithArrivalTime (ValidatedPerasVote blk) -> - UpdatePerasVoteAggregateResult blk + PerasVoteAggregate blk updatePerasVoteAggregate pva@PerasVoteAggregate { pvaTarget = (roundNo, point) , pvaVotes = existingVotes , pvaTotalStake = initialStake - , pvaMaybeCert = mExistingCert } vote = - if getPerasVoteRound vote == roundNo && getPerasVoteVotedBlock vote == point - then - let pvaTotalStake = initialStake + vpvVoteStake (forgetArrivalTime vote) - pvaVotes = Set.insert vote existingVotes - mNewCert = - if isNothing mExistingCert && pvaTotalStake >= const_PERAS_QUORUM_THRESHOLD - then - Just $ - ValidatedPerasCert - { vpcCertBoost = boostPerCert - , vpcCert = - PerasCert - { pcCertRound = roundNo - , pcCertBoostedBlock = point - } - } - else Nothing - pva' = - pva - { pvaVotes - , pvaTotalStake - , pvaMaybeCert = mExistingCert <|> mNewCert - } - in case mNewCert of - Just cert -> AddedPerasVoteAndGeneratedNewCert pva' cert - Nothing -> AddedPerasVoteButDidntGenerateNewCert pva' - else IncorrectPerasVoteTarget + if not (getPerasVoteRound vote == roundNo && getPerasVoteVotedBlock vote == point) + then error "updatePerasVoteAggregate: vote target does not match aggregate target" + else + let (pvaVotes', pvaTotalStake') = + case Map.insertLookupWithKey + (\_k old _new -> old) + (getId vote) + vote + existingVotes of + (Nothing, votes') -> + -- key was NOT present → inserted and stake updated + (votes', initialStake + vpvVoteStake (forgetArrivalTime vote)) + (Just _, _) -> + -- key WAS already present → votes and stake unchanged + (existingVotes, initialStake) + in pva{pvaVotes = pvaVotes', pvaTotalStake = pvaTotalStake'} + +updatePerasVoteAggregateStatus :: + StandardHash blk => + PerasVoteAggregateStatus blk -> + WithArrivalTime (ValidatedPerasVote blk) -> + PerasVoteAggregateStatus blk +updatePerasVoteAggregateStatus aggr vote = case aggr of + PerasVoteAggregateQuorumNotReached{pvasVoteAggregate} -> + let aggr' = updatePerasVoteAggregate pvasVoteAggregate vote + in if pvaTotalStake aggr' >= const_PERAS_QUORUM_THRESHOLD + then + PerasVoteAggregateQuorumReachedAlready + { pvasVoteAggregate = aggr' + , pvasCert = + ValidatedPerasCert + { vpcCertBoost = boostPerCert + , vpcCert = uncurry PerasCert (pvaTarget aggr') + } + } + else PerasVoteAggregateQuorumNotReached{pvasVoteAggregate = aggr'} + PerasVoteAggregateQuorumReachedAlready{pvasVoteAggregate, pvasCert} -> + PerasVoteAggregateQuorumReachedAlready + { pvasVoteAggregate = updatePerasVoteAggregate pvasVoteAggregate vote + , pvasCert + } type PerasVoteTarget blk = (PerasRoundNo, Point blk) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index 5d47127995..f9b64682ee 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -56,7 +56,7 @@ data AddPerasVoteResult blk deriving anyclass NoThunks newtype PerasStakeSnapshot blk = PerasStakeSnapshot - {unPerasStakeSnapshot :: WithFingerprint (Map (PerasVoteTarget blk) (PerasVoteAggregate blk))} + {unPerasStakeSnapshot :: WithFingerprint (Map (PerasVoteTarget blk) (PerasVoteAggregateStatus blk))} deriving Generic deriving newtype NoThunks @@ -65,7 +65,7 @@ getPerasCertsFromStakeSnapshot :: PerasStakeSnapshot blk -> Set (ValidatedPerasCert blk) getPerasCertsFromStakeSnapshot (PerasStakeSnapshot mp) = - Set.fromList $ Map.elems $ Map.mapMaybe pvaMaybeCert (forgetFingerprint mp) + Set.fromList $ Map.elems $ Map.mapMaybe pvasMaybeCert (forgetFingerprint mp) data PerasVoteSnapshot blk = PerasVoteSnapshot { containsVote :: IdOf (PerasVote blk) -> Bool diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 3dcbaab054..bd8f71b60a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -36,7 +36,7 @@ import Data.Set (Set) import Data.Set qualified as Set import GHC.Generics (Generic) import NoThunks.Class -import Ouroboros.Consensus.Block hiding (UpdatePerasVoteAggregateResult (..)) +import Ouroboros.Consensus.Block import Ouroboros.Consensus.Block.SupportsPeras qualified as UPVAR import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (forgetArrivalTime)) import Ouroboros.Consensus.Peras.Weight @@ -182,11 +182,14 @@ implAddVote env vote = do (res, pvsVotesByTarget') = Map.alterF ( \mExistingAggr -> - let aggr = fromMaybe (emptyPerasVoteAggregate voteTarget) mExistingAggr - in case updatePerasVoteAggregate aggr vote of - UPVAR.IncorrectPerasVoteTarget -> error "The aggregate should match the vote target." - UPVAR.AddedPerasVoteButDidntGenerateNewCert aggr' -> (AddedPerasVoteButDidntGenerateNewCert, Just aggr') - UPVAR.AddedPerasVoteAndGeneratedNewCert aggr' cert -> (AddedPerasVoteAndGeneratedNewCert cert, Just aggr') + let aggr = fromMaybe (emptyPerasVoteAggregateStatus voteTarget) mExistingAggr + aggr' = updatePerasVoteAggregateStatus aggr vote + in case (aggr, aggr') of + -- if we observe a state transition, it means a certificate was emitted + (PerasVoteAggregateQuorumNotReached{}, PerasVoteAggregateQuorumReachedAlready{pvasCert}) -> + (AddedPerasVoteAndGeneratedNewCert pvasCert, Just aggr') + _ -> + (AddedPerasVoteButDidntGenerateNewCert, Just aggr') ) voteTarget pvsVotesByTarget @@ -281,7 +284,7 @@ implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = data PerasVoteState blk = PerasVoteState { pvsVoteIds :: !(Set (IdOf (PerasVote blk))) - , pvsVotesByTarget :: !(Map (PerasVoteTarget blk) (PerasVoteAggregate blk)) + , pvsVotesByTarget :: !(Map (PerasVoteTarget blk) (PerasVoteAggregateStatus blk)) , pvsVotesByTicket :: !(Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))) -- ^ The votes by 'PerasVoteTicketNo'. -- From 0a4d52969e8af089df59e2b3d5e985c9a0fc549e Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 1 Dec 2025 18:25:29 +0100 Subject: [PATCH 4/5] Refactor VoteDB to enforce single-cert-per-round invariant --- .../Consensus/Block/SupportsPeras.hs | 136 ++----- .../MiniProtocol/ObjectDiffusion/PerasVote.hs | 4 +- .../Consensus/Storage/PerasVoteDB/API.hs | 25 +- .../Consensus/Storage/PerasVoteDB/Impl.hs | 356 +++++++++++++----- 4 files changed, 315 insertions(+), 206 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 585ee5cc0a..1da3f66811 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -27,12 +27,6 @@ module Ouroboros.Consensus.Block.SupportsPeras , PerasCfg (..) , ValidatedPerasCert (..) , ValidatedPerasVote (..) - , PerasVoteAggregate (..) - , PerasVoteAggregateStatus (..) - , pvasMaybeCert - , emptyPerasVoteAggregateStatus - , updatePerasVoteAggregate - , updatePerasVoteAggregateStatus , makePerasCfg , HasId (..) , HasPerasCertRound (..) @@ -132,6 +126,11 @@ instance Condense PerasWeight where boostPerCert :: PerasWeight boostPerCert = PerasWeight 15 +-- | TODO: this may become a Ledger protocol parameter +-- see https://github.com/tweag/cardano-peras/issues/119 +quorumThreshold :: PerasVoteStake +quorumThreshold = PerasVoteStake 0.75 + -- TODO using 'Validated' for extra safety? Or some @.Unsafe@ module? data ValidatedPerasCert blk = ValidatedPerasCert { vpcCert :: !(PerasCert blk) @@ -202,6 +201,8 @@ class data PerasValidationErr blk + data PerasForgeErr blk + validatePerasCert :: PerasCfg blk -> PerasCert blk -> @@ -213,105 +214,23 @@ class PerasVoteStakeDistr -> Either (PerasValidationErr blk) (ValidatedPerasVote blk) -const_PERAS_QUORUM_THRESHOLD :: PerasVoteStake -const_PERAS_QUORUM_THRESHOLD = PerasVoteStake 0.75 - -data PerasVoteAggregate blk = PerasVoteAggregate - { pvaTarget :: !(PerasVoteTarget blk) - , pvaVotes :: !(Map (IdOf (PerasVote blk)) (WithArrivalTime (ValidatedPerasVote blk))) - , pvaTotalStake :: !PerasVoteStake - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks - -data PerasVoteAggregateStatus blk - = PerasVoteAggregateQuorumNotReached {pvasVoteAggregate :: !(PerasVoteAggregate blk)} - | PerasVoteAggregateQuorumReachedAlready - {pvasVoteAggregate :: !(PerasVoteAggregate blk), pvasCert :: ValidatedPerasCert blk} - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks - -pvasMaybeCert :: PerasVoteAggregateStatus blk -> Maybe (ValidatedPerasCert blk) -pvasMaybeCert aggr = case aggr of - PerasVoteAggregateQuorumNotReached{} -> Nothing - PerasVoteAggregateQuorumReachedAlready{pvasCert} -> Just pvasCert - -emptyPerasVoteAggregateStatus :: PerasVoteTarget blk -> PerasVoteAggregateStatus blk -emptyPerasVoteAggregateStatus target = - PerasVoteAggregateQuorumNotReached $ - PerasVoteAggregate - { pvaTotalStake = PerasVoteStake 0 - , pvaTarget = target - , pvaVotes = Map.empty - } - --- | Add a vote to an existing aggregate if it isn't already present, and update --- the stake accordingly. --- PRECONDITION: the vote's target must match the aggregate's target. -updatePerasVoteAggregate :: - StandardHash blk => - PerasVoteAggregate blk -> - WithArrivalTime (ValidatedPerasVote blk) -> - PerasVoteAggregate blk -updatePerasVoteAggregate - pva@PerasVoteAggregate - { pvaTarget = (roundNo, point) - , pvaVotes = existingVotes - , pvaTotalStake = initialStake - } - vote = - if not (getPerasVoteRound vote == roundNo && getPerasVoteVotedBlock vote == point) - then error "updatePerasVoteAggregate: vote target does not match aggregate target" - else - let (pvaVotes', pvaTotalStake') = - case Map.insertLookupWithKey - (\_k old _new -> old) - (getId vote) - vote - existingVotes of - (Nothing, votes') -> - -- key was NOT present → inserted and stake updated - (votes', initialStake + vpvVoteStake (forgetArrivalTime vote)) - (Just _, _) -> - -- key WAS already present → votes and stake unchanged - (existingVotes, initialStake) - in pva{pvaVotes = pvaVotes', pvaTotalStake = pvaTotalStake'} - -updatePerasVoteAggregateStatus :: - StandardHash blk => - PerasVoteAggregateStatus blk -> - WithArrivalTime (ValidatedPerasVote blk) -> - PerasVoteAggregateStatus blk -updatePerasVoteAggregateStatus aggr vote = case aggr of - PerasVoteAggregateQuorumNotReached{pvasVoteAggregate} -> - let aggr' = updatePerasVoteAggregate pvasVoteAggregate vote - in if pvaTotalStake aggr' >= const_PERAS_QUORUM_THRESHOLD - then - PerasVoteAggregateQuorumReachedAlready - { pvasVoteAggregate = aggr' - , pvasCert = - ValidatedPerasCert - { vpcCertBoost = boostPerCert - , vpcCert = uncurry PerasCert (pvaTarget aggr') - } - } - else PerasVoteAggregateQuorumNotReached{pvasVoteAggregate = aggr'} - PerasVoteAggregateQuorumReachedAlready{pvasVoteAggregate, pvasCert} -> - PerasVoteAggregateQuorumReachedAlready - { pvasVoteAggregate = updatePerasVoteAggregate pvasVoteAggregate vote - , pvasCert - } + forgePerasCert :: + PerasCfg blk -> + PerasVoteTarget blk -> + [ValidatedPerasVote blk] -> + Either (PerasForgeErr blk) (ValidatedPerasCert blk) type PerasVoteTarget blk = (PerasRoundNo, Point blk) -- 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 + data 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 + , perasCfgQuorumThreshold :: PerasVoteStake } deriving stock (Show, Eq) @@ -336,6 +255,11 @@ instance StandardHash blk => BlockSupportsPeras blk where = PerasValidationErr deriving stock (Show, Eq) + data PerasForgeErr blk + = PerasForgeErrMismatchedTarget + | PerasForgeErrInsufficientVotes + deriving stock (Show, Eq) + -- TODO: perform actual validation against all -- possible 'PerasValidationErr' variants -- see https://github.com/tweag/cardano-peras/issues/120 @@ -350,6 +274,27 @@ instance StandardHash blk => BlockSupportsPeras blk where let stake = getPerasVoteStakeOf stakeDistr (pvVoteVoterId vote) in Right (ValidatedPerasVote{vpvVote = vote, vpvVoteStake = stake}) + forgePerasCert cfg target votes = + let allMatchTarget = all (\v -> getPerasVoteTarget v == target) votes + hasSufficientStake = + let totalStake = mconcat (map vpvVoteStake votes) + in totalStake >= perasCfgQuorumThreshold cfg + in if not allMatchTarget + then Left PerasForgeErrMismatchedTarget + else + if not hasSufficientStake + then Left PerasForgeErrInsufficientVotes + else + Right + ValidatedPerasCert + { vpcCert = + PerasCert + { pcCertRound = fst target + , pcCertBoostedBlock = snd target + } + , vpcCertBoost = perasCfgWeightBoost cfg + } + instance HasId (PerasCert blk) where type IdOf (PerasCert blk) = PerasRoundNo getId = pcCertRound @@ -402,6 +347,7 @@ makePerasCfg :: Maybe (BlockConfig blk) -> PerasCfg blk makePerasCfg _ = PerasCfg { perasCfgWeightBoost = boostPerCert + , perasCfgQuorumThreshold = quorumThreshold } -- | Extract the certificate round from a Peras certificate container diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs index 4742edabf9..1efadd943c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ObjectDiffusion/PerasVote.hs @@ -14,8 +14,8 @@ module Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.PerasVote ) where import Ouroboros.Consensus.Block -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound -import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.State +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1 +import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound.V1.State import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound import Ouroboros.Consensus.Storage.PerasVoteDB.API diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs index f9b64682ee..602f733cec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs @@ -11,16 +11,11 @@ module Ouroboros.Consensus.Storage.PerasVoteDB.API -- * 'PerasVoteSnapshot' , PerasVoteSnapshot (..) - , PerasStakeSnapshot (..) , PerasVoteTicketNo , zeroPerasVoteTicketNo - , getPerasCertsFromStakeSnapshot ) where import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set import Data.Word (Word64) import GHC.Generics (Generic) import NoThunks.Class @@ -29,19 +24,15 @@ import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime) import Ouroboros.Consensus.Util.MonadSTM.NormalForm ( MonadSTM (STM) ) -import Ouroboros.Consensus.Util.STM (WithFingerprint (..)) data PerasVoteDB m blk = PerasVoteDB { addVote :: WithArrivalTime (ValidatedPerasVote blk) -> m (AddPerasVoteResult blk) -- ^ Add a Peras vote to the database. The result indicates whether -- the vote was actually added, or if it was already present. - , getStakeSnapshot :: STM m (PerasStakeSnapshot blk) - -- ^ Return a view of accumulated vote stake per (point, round) - -- - -- The underlying 'Fingerprint' is updated every time a new vote is added, but it - -- stays the same when votes are garbage-collected. , getVoteSnapshot :: STM m (PerasVoteSnapshot blk) -- ^ Interface to read the known votes, mostly for diffusion + , getForgedCertForRound :: PerasRoundNo -> STM m (Maybe (ValidatedPerasCert blk)) + -- ^ Get the certificate if quorum was reached for the given round. , garbageCollect :: PerasRoundNo -> m () -- ^ Garbage-collect state strictly older than the given slot number. , closeDB :: m () @@ -55,18 +46,6 @@ data AddPerasVoteResult blk deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks -newtype PerasStakeSnapshot blk = PerasStakeSnapshot - {unPerasStakeSnapshot :: WithFingerprint (Map (PerasVoteTarget blk) (PerasVoteAggregateStatus blk))} - deriving Generic - deriving newtype NoThunks - -getPerasCertsFromStakeSnapshot :: - StandardHash blk => - PerasStakeSnapshot blk -> - Set (ValidatedPerasCert blk) -getPerasCertsFromStakeSnapshot (PerasStakeSnapshot mp) = - Set.fromList $ Map.elems $ Map.mapMaybe pvasMaybeCert (forgetFingerprint mp) - data PerasVoteSnapshot blk = PerasVoteSnapshot { containsVote :: IdOf (PerasVote blk) -> Bool , getVotesAfter :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index bd8f71b60a..6ad0c23a70 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -7,7 +7,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneKindSignatures #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-partial-fields #-} module Ouroboros.Consensus.Storage.PerasVoteDB.Impl ( -- * Opening @@ -22,30 +22,200 @@ module Ouroboros.Consensus.Storage.PerasVoteDB.Impl , PerasVoteDbError (..) ) where -import Control.Monad (when) -import Control.Monad.Except (throwError) import Control.Tracer (Tracer, nullTracer, traceWith) -import Data.Foldable (for_) import Data.Foldable qualified as Foldable -import Data.Functor ((<&>)) import Data.Kind (Type) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as Set import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Block.SupportsPeras qualified as UPVAR import Ouroboros.Consensus.BlockchainTime (WithArrivalTime (forgetArrivalTime)) -import Ouroboros.Consensus.Peras.Weight import Ouroboros.Consensus.Storage.PerasVoteDB.API import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM +-- | Update a 'Map' at a given key with a function, using a default value as the +-- "old" value if the key is not present. +-- Both the old and new values are returned, along with the updated map. +updateWithDefault :: + forall k v. + Ord k => + -- | default value if key not present + v -> + -- | update function + (v -> v) -> + -- | key + k -> + Map k v -> + -- | (old value, new value, updated map) + (v, v, Map k v) +updateWithDefault def upd k m = + case Map.alterF go k m of + ((old, new), m') -> (old, new, m') + where + go :: Maybe v -> ((v, v), Maybe v) + go Nothing = + let old = def + new = upd old + in ((old, new), Just new) + go (Just old) = + let new = upd old + in ((old, new), Just new) + +-- | Aggregate of votes for a given target (round number and block point). +data PerasTargetVoteAggregate blk = PerasTargetVoteAggregate + { ptvaTarget :: !(PerasVoteTarget blk) + , ptvaVotes :: !(Map (IdOf (PerasVote blk)) (WithArrivalTime (ValidatedPerasVote blk))) + , ptvaTotalStake :: !PerasVoteStake + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + +-- | View of votes for a given round number. This type is in charge of enforcing +-- that only one certificate can be generated per round. +data PerasRoundVoteAggregates blk + = PerasRoundVoteAggregatesQuorumNotReached + { prvaRoundNo :: PerasRoundNo + , prvaVoteAggregates :: !(Map (Point blk) (PerasTargetVoteAggregate blk)) + } + | PerasRoundVoteAggregatesQuorumReachedAlready + { prvaRoundNo :: PerasRoundNo + , prvaVoteAggregates :: !(Map (Point blk) (PerasTargetVoteAggregate blk)) + , prvaCert :: ValidatedPerasCert blk + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + +-- | Get the certificate if quorum was reached for the given round. +prvaMaybeCert :: PerasRoundVoteAggregates blk -> Maybe (ValidatedPerasCert blk) +prvaMaybeCert aggr = case aggr of + PerasRoundVoteAggregatesQuorumNotReached{} -> Nothing + PerasRoundVoteAggregatesQuorumReachedAlready{prvaCert} -> Just prvaCert + +-- | Create a new, target-level vote aggregate for the given target. +newTargetVoteAggregate :: + PerasVoteTarget blk -> + PerasTargetVoteAggregate blk +newTargetVoteAggregate target = + PerasTargetVoteAggregate + { ptvaTarget = target + , ptvaVotes = Map.empty + , ptvaTotalStake = PerasVoteStake 0 + } + +-- | Create a new, round-level vote aggregate for the given round number. +newRoundVoteAggregates :: + PerasRoundNo -> + PerasRoundVoteAggregates blk +newRoundVoteAggregates roundNo = + PerasRoundVoteAggregatesQuorumNotReached + { prvaRoundNo = roundNo + , prvaVoteAggregates = Map.empty + } + +-- | Add a vote to an existing target aggregate if it isn't already present, +-- and update the stake accordingly. +-- PRECONDITION: the vote's target must match the aggregate's target. +updateTargetVoteAggregate :: + StandardHash blk => + WithArrivalTime (ValidatedPerasVote blk) -> + PerasTargetVoteAggregate blk -> + PerasTargetVoteAggregate blk +updateTargetVoteAggregate + vote + ptva@PerasTargetVoteAggregate + { ptvaTarget = (roundNo, point) + , ptvaVotes = existingVotes + , ptvaTotalStake = initialStake + } = + if getPerasVoteRound vote /= roundNo || getPerasVoteVotedBlock vote /= point + then error "updatePerasVoteAggregate: vote target does not match aggregate target" + else + let (pvaVotes', pvaTotalStake') = + case Map.insertLookupWithKey + (\_k old _new -> old) + (getId vote) + vote + existingVotes of + (Nothing, votes') -> + -- key was NOT present → inserted and stake updated + (votes', initialStake + vpvVoteStake (forgetArrivalTime vote)) + (Just _, _) -> + -- key WAS already present → votes and stake unchanged + (existingVotes, initialStake) + in ptva{ptvaVotes = pvaVotes', ptvaTotalStake = pvaTotalStake'} + +-- | Add a vote to an existing round aggregate. +-- PRECONDITION: the vote's round must match the aggregate's round. +updatePerasRoundVoteAggregates :: + StandardHash blk => + WithArrivalTime (ValidatedPerasVote blk) -> + PerasCfg blk -> + PerasRoundVoteAggregates blk -> + PerasRoundVoteAggregates blk +updatePerasRoundVoteAggregates vote cfg@PerasCfg{perasCfgQuorumThreshold} roundAggrs = + if getPerasVoteRound vote /= prvaRoundNo roundAggrs + then error "updatePerasRoundVoteAggregates: vote round does not match aggregate round" + else + let target = getPerasVoteTarget vote + point = snd target + (oldTargetAggr, newTargetAggr, prvaVoteAggregates') = + updateWithDefault + (newTargetVoteAggregate target) + (updateTargetVoteAggregate vote) + point + (prvaVoteAggregates roundAggrs) + mustEmitCert = + ptvaTotalStake oldTargetAggr < perasCfgQuorumThreshold + && ptvaTotalStake newTargetAggr >= perasCfgQuorumThreshold + in case (roundAggrs, mustEmitCert) of + (PerasRoundVoteAggregatesQuorumNotReached{prvaRoundNo}, True) -> + PerasRoundVoteAggregatesQuorumReachedAlready + { prvaRoundNo + , prvaVoteAggregates = prvaVoteAggregates' + , prvaCert = case forgePerasCert cfg target (forgetArrivalTime <$> Map.elems (ptvaVotes newTargetAggr)) of + -- TODO: the forge error might be made into a PerasVoteDB error variant? + Left err -> + error + ( "updatePerasRoundVoteAggregates: forging the " + ++ "certificate should be valid when quorum is " + ++ "reached, but got error: " + ++ show err + ) + Right cert -> cert + } + (PerasRoundVoteAggregatesQuorumNotReached{prvaRoundNo}, False) -> + PerasRoundVoteAggregatesQuorumNotReached + { prvaRoundNo + , prvaVoteAggregates = prvaVoteAggregates' + } + (PerasRoundVoteAggregatesQuorumReachedAlready{prvaRoundNo, prvaCert}, True) -> + -- TODO: the equivocating cert error might be made into a PerasVoteDB error variant? + error + ( "updatePerasRoundVoteAggregates: quorum was already reached for round " + ++ show prvaRoundNo + ++ " on point " + ++ show (pcCertBoostedBlock . vpcCert $ prvaCert) + ++ ", but we reached it again on point " + ++ show point + ++ "with " + ++ show (ptvaTotalStake newTargetAggr) + ++ " stake (quorum threshold = " + ++ (show perasCfgQuorumThreshold) + ++ ". Equivocating certificates should be impossible per design." + ) + (PerasRoundVoteAggregatesQuorumReachedAlready{prvaRoundNo, prvaCert}, False) -> + PerasRoundVoteAggregatesQuorumReachedAlready + { prvaRoundNo + , prvaCert + , prvaVoteAggregates = prvaVoteAggregates' + } + {------------------------------------------------------------------------------ Opening the database ------------------------------------------------------------------------------} @@ -53,12 +223,14 @@ import Ouroboros.Consensus.Util.STM type PerasVoteDbArgs :: (Type -> Type) -> (Type -> Type) -> Type -> Type data PerasVoteDbArgs f m blk = PerasVoteDbArgs { pvdbaTracer :: Tracer m (TraceEvent blk) + , pvdbaPerasCfg :: HKD f (PerasCfg blk) } defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk defaultArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer + , pvdbaPerasCfg = noDefault } openDB :: @@ -68,7 +240,7 @@ openDB :: ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) -openDB args = do +openDB args@PerasVoteDbArgs{pvdbaPerasCfg} = do pvdbPerasVoteStateVar <- newTVarWithInvariantIO (either Just (const Nothing) . invariantForPerasVoteState) @@ -82,9 +254,9 @@ openDB args = do traceWith pvdbTracer OpenedPerasVoteDB pure PerasVoteDB - { addVote = getEnv1 h implAddVote - , getStakeSnapshot = getEnvSTM h implGetStakeSnapshot + { addVote = getEnv1 h (implAddVote pvdbaPerasCfg) , getVoteSnapshot = getEnvSTM h implGetVoteSnapshot + , getForgedCertForRound = getEnvSTM1 h implForgedCertForRound , garbageCollect = getEnv1 h implGarbageCollect , closeDB = implCloseDB h } @@ -140,6 +312,14 @@ getEnvSTM (PerasVoteDbHandle varState) f = PerasVoteDbOpen env -> f env PerasVoteDbClosed -> throwIO $ ClosedDBError prettyCallStack +getEnvSTM1 :: + (IOLike m, HasCallStack) => + PerasVoteDbHandle m blk -> + (PerasVoteDbEnv m blk -> a -> STM m r) -> + a -> + STM m r +getEnvSTM1 h f a = getEnvSTM h (\env -> f env a) + {------------------------------------------------------------------------------- API implementation -------------------------------------------------------------------------------} @@ -158,79 +338,72 @@ implAddVote :: ( IOLike m , StandardHash blk ) => + PerasCfg blk -> PerasVoteDbEnv m blk -> WithArrivalTime (ValidatedPerasVote blk) -> m (AddPerasVoteResult blk) -implAddVote env vote = do - traceWith pvdbTracer $ AddingPerasVote voteTarget voteId voteStake - - res <- atomically $ do - WithFingerprint - PerasVoteState - { pvsVoteIds - , pvsVotesByTarget - , pvsVotesByTicket - , pvsLastTicketNo - } - fp <- - readTVar pvdbPerasVoteStateVar - - if Set.member voteId (pvsVoteIds) - then pure PerasVoteAlreadyInDB - else do - let pvsVoteIds' = Set.insert voteId (pvsVoteIds) - (res, pvsVotesByTarget') = - Map.alterF - ( \mExistingAggr -> - let aggr = fromMaybe (emptyPerasVoteAggregateStatus voteTarget) mExistingAggr - aggr' = updatePerasVoteAggregateStatus aggr vote - in case (aggr, aggr') of - -- if we observe a state transition, it means a certificate was emitted - (PerasVoteAggregateQuorumNotReached{}, PerasVoteAggregateQuorumReachedAlready{pvasCert}) -> - (AddedPerasVoteAndGeneratedNewCert pvasCert, Just aggr') - _ -> - (AddedPerasVoteButDidntGenerateNewCert, Just aggr') - ) - voteTarget - pvsVotesByTarget - pvsLastTicketNo' = succ pvsLastTicketNo - pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote pvsVotesByTicket - fp' = succ fp - writeTVar pvdbPerasVoteStateVar $ - WithFingerprint - PerasVoteState - { pvsVoteIds = pvsVoteIds' - , pvsVotesByTarget = pvsVotesByTarget' - , pvsVotesByTicket = pvsVotesByTicket' - , pvsLastTicketNo = pvsLastTicketNo' - } - fp' - pure res - - case res of - PerasVoteAlreadyInDB -> traceWith pvdbTracer $ IgnoredVoteAlreadyInDB voteId - AddedPerasVoteButDidntGenerateNewCert -> traceWith pvdbTracer $ AddedPerasVote voteId - AddedPerasVoteAndGeneratedNewCert newCert -> do - traceWith pvdbTracer $ AddedPerasVote voteId - traceWith pvdbTracer $ GeneratedPerasCert newCert - pure res - where +implAddVote + perasCfg PerasVoteDbEnv { pvdbTracer , pvdbPerasVoteStateVar - } = env - - voteTarget = getPerasVoteTarget vote - voteId = getId vote - voteStake = vpvVoteStake . forgetArrivalTime $ vote - -implGetStakeSnapshot :: - IOLike m => - PerasVoteDbEnv m blk -> STM m (PerasStakeSnapshot blk) -implGetStakeSnapshot PerasVoteDbEnv{pvdbPerasVoteStateVar} = do - perasVoteState <- readTVar pvdbPerasVoteStateVar - let unPerasStakeSnapshot = pvsVotesByTarget <$> perasVoteState - pure $ PerasStakeSnapshot{unPerasStakeSnapshot} + } + vote = do + let voteId = getId vote + voteTarget = getPerasVoteTarget vote + voteStake = vpvVoteStake (forgetArrivalTime vote) + + traceWith pvdbTracer $ AddingPerasVote voteTarget voteId voteStake + + res <- atomically $ do + WithFingerprint + PerasVoteState + { pvsVoteIds + , pvsVoteAggrsByRound + , pvsVotesByTicket + , pvsLastTicketNo + } + fp <- + readTVar pvdbPerasVoteStateVar + + if Set.member voteId pvsVoteIds + then pure PerasVoteAlreadyInDB + else do + let pvsVoteIds' = Set.insert voteId pvsVoteIds + roundNo = getPerasVoteRound vote + (oldRoundAggrs, newRoundAggrs, pvsVoteAggrsByRound') = + updateWithDefault + (newRoundVoteAggregates roundNo) + (updatePerasRoundVoteAggregates vote perasCfg) + roundNo + pvsVoteAggrsByRound + res = case (oldRoundAggrs, newRoundAggrs) of + ( PerasRoundVoteAggregatesQuorumNotReached{} + , PerasRoundVoteAggregatesQuorumReachedAlready{prvaCert} + ) -> + AddedPerasVoteAndGeneratedNewCert prvaCert + _ -> AddedPerasVoteButDidntGenerateNewCert + pvsLastTicketNo' = succ pvsLastTicketNo + pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote pvsVotesByTicket + fp' = succ fp + writeTVar pvdbPerasVoteStateVar $ + WithFingerprint + PerasVoteState + { pvsVoteIds = pvsVoteIds' + , pvsVoteAggrsByRound = pvsVoteAggrsByRound' + , pvsVotesByTicket = pvsVotesByTicket' + , pvsLastTicketNo = pvsLastTicketNo' + } + fp' + pure res + + case res of + PerasVoteAlreadyInDB -> traceWith pvdbTracer $ IgnoredVoteAlreadyInDB voteId + AddedPerasVoteButDidntGenerateNewCert -> traceWith pvdbTracer $ AddedPerasVote voteId + AddedPerasVoteAndGeneratedNewCert newCert -> do + traceWith pvdbTracer $ AddedPerasVote voteId + traceWith pvdbTracer $ GeneratedPerasCert newCert + pure res implGetVoteSnapshot :: IOLike m => @@ -244,6 +417,17 @@ implGetVoteSnapshot PerasVoteDbEnv{pvdbPerasVoteStateVar} = do snd $ Map.split ticketNo pvsVotesByTicket } +implForgedCertForRound :: + IOLike m => + PerasVoteDbEnv m blk -> + PerasRoundNo -> + STM m (Maybe (ValidatedPerasCert blk)) +implForgedCertForRound PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = do + PerasVoteState{pvsVoteAggrsByRound} <- forgetFingerprint <$> readTVar pvdbPerasVoteStateVar + case Map.lookup roundNo pvsVoteAggrsByRound of + Nothing -> pure Nothing + Just aggr -> pure $ prvaMaybeCert aggr + implGarbageCollect :: forall m blk. IOLike m => @@ -257,14 +441,14 @@ implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = gc PerasVoteState { pvsVoteIds - , pvsVotesByTarget + , pvsVoteAggrsByRound , pvsVotesByTicket , pvsLastTicketNo } = - let pvsVotesByTarget' = + let pvsVoteAggrsByRound' = Map.filterWithKey - (\(rNo, _) _ -> rNo >= roundNo) - pvsVotesByTarget + (\rNo _ -> rNo >= roundNo) + pvsVoteAggrsByRound (pvsVotesByTicket', votesToRemove) = Map.partition (\vote -> getPerasVoteRound vote >= roundNo) pvsVotesByTicket pvsVoteIds' = Foldable.foldl' @@ -273,7 +457,7 @@ implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = votesToRemove in PerasVoteState { pvsVoteIds = pvsVoteIds' - , pvsVotesByTarget = pvsVotesByTarget' + , pvsVoteAggrsByRound = pvsVoteAggrsByRound' , pvsVotesByTicket = pvsVotesByTicket' , pvsLastTicketNo = pvsLastTicketNo } @@ -284,11 +468,11 @@ implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = data PerasVoteState blk = PerasVoteState { pvsVoteIds :: !(Set (IdOf (PerasVote blk))) - , pvsVotesByTarget :: !(Map (PerasVoteTarget blk) (PerasVoteAggregateStatus blk)) + , pvsVoteAggrsByRound :: !(Map PerasRoundNo (PerasRoundVoteAggregates blk)) , pvsVotesByTicket :: !(Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))) -- ^ The votes by 'PerasVoteTicketNo'. -- - -- INVARIANT: In sync with 'pvsVotesByTarget'. + -- INVARIANT: In sync with 'pvsVoteAggrsByRound'. , pvsLastTicketNo :: !PerasVoteTicketNo -- ^ The most recent 'PerasVoteTicketNo' (or 'zeroPerasVoteTicketNo' -- otherwise). @@ -301,7 +485,7 @@ initialPerasVoteState = WithFingerprint PerasVoteState { pvsVoteIds = Set.empty - , pvsVotesByTarget = Map.empty + , pvsVoteAggrsByRound = Map.empty , pvsVotesByTicket = Map.empty , pvsLastTicketNo = zeroPerasVoteTicketNo } From 3cd68918bc2348f5e6d32b4476e1495dde86198f Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 2 Dec 2025 13:49:33 +0100 Subject: [PATCH 5/5] Change vote aggregating logic, to a partial type-level encoded one --- .../Consensus/Storage/PerasVoteDB/Impl.hs | 553 ++++++++++++------ 1 file changed, 374 insertions(+), 179 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 6ad0c23a70..38a8dabc28 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -2,11 +2,18 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-partial-fields #-} module Ouroboros.Consensus.Storage.PerasVoteDB.Impl @@ -22,11 +29,15 @@ module Ouroboros.Consensus.Storage.PerasVoteDB.Impl , PerasVoteDbError (..) ) where +import Cardano.Prelude (Word64) import Control.Tracer (Tracer, nullTracer, traceWith) +import Data.Data (Typeable) import Data.Foldable qualified as Foldable +import Data.Functor.Compose (Compose (..)) import Data.Kind (Type) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Set qualified as Set import GHC.Generics (Generic) @@ -39,182 +50,357 @@ import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.STM --- | Update a 'Map' at a given key with a function, using a default value as the --- "old" value if the key is not present. --- Both the old and new values are returned, along with the updated map. -updateWithDefault :: - forall k v. - Ord k => - -- | default value if key not present - v -> - -- | update function - (v -> v) -> - -- | key - k -> - Map k v -> - -- | (old value, new value, updated map) - (v, v, Map k v) -updateWithDefault def upd k m = - case Map.alterF go k m of - ((old, new), m') -> (old, new, m') - where - go :: Maybe v -> ((v, v), Maybe v) - go Nothing = - let old = def - new = upd old - in ((old, new), Just new) - go (Just old) = - let new = upd old - in ((old, new), Just new) - --- | Aggregate of votes for a given target (round number and block point). -data PerasTargetVoteAggregate blk = PerasTargetVoteAggregate - { ptvaTarget :: !(PerasVoteTarget blk) - , ptvaVotes :: !(Map (IdOf (PerasVote blk)) (WithArrivalTime (ValidatedPerasVote blk))) - , ptvaTotalStake :: !PerasVoteStake +-- | Tally of votes for a given target (round number and block point). +data PerasTargetVoteTally blk = PerasTargetVoteTally + { ptvtTarget :: !(PerasVoteTarget blk) + , ptvtVotes :: !(Map (IdOf (PerasVote blk)) (WithArrivalTime (ValidatedPerasVote blk))) + , ptvtTotalStake :: !PerasVoteStake } deriving stock (Generic, Eq, Ord, Show) deriving anyclass NoThunks --- | View of votes for a given round number. This type is in charge of enforcing --- that only one certificate can be generated per round. -data PerasRoundVoteAggregates blk - = PerasRoundVoteAggregatesQuorumNotReached - { prvaRoundNo :: PerasRoundNo - , prvaVoteAggregates :: !(Map (Point blk) (PerasTargetVoteAggregate blk)) - } - | PerasRoundVoteAggregatesQuorumReachedAlready - { prvaRoundNo :: PerasRoundNo - , prvaVoteAggregates :: !(Map (Point blk) (PerasTargetVoteAggregate blk)) - , prvaCert :: ValidatedPerasCert blk - } - deriving stock (Generic, Eq, Ord, Show) - deriving anyclass NoThunks +instance HasPerasVoteTarget (PerasTargetVoteTally blk) blk where + getPerasVoteTarget = ptvtTarget --- | Get the certificate if quorum was reached for the given round. -prvaMaybeCert :: PerasRoundVoteAggregates blk -> Maybe (ValidatedPerasCert blk) -prvaMaybeCert aggr = case aggr of - PerasRoundVoteAggregatesQuorumNotReached{} -> Nothing - PerasRoundVoteAggregatesQuorumReachedAlready{prvaCert} -> Just prvaCert - --- | Create a new, target-level vote aggregate for the given target. -newTargetVoteAggregate :: - PerasVoteTarget blk -> - PerasTargetVoteAggregate blk -newTargetVoteAggregate target = - PerasTargetVoteAggregate - { ptvaTarget = target - , ptvaVotes = Map.empty - , ptvaTotalStake = PerasVoteStake 0 - } +instance HasPerasVoteRound (PerasTargetVoteTally blk) where + getPerasVoteRound = fst . getPerasVoteTarget --- | Create a new, round-level vote aggregate for the given round number. -newRoundVoteAggregates :: - PerasRoundNo -> - PerasRoundVoteAggregates blk -newRoundVoteAggregates roundNo = - PerasRoundVoteAggregatesQuorumNotReached - { prvaRoundNo = roundNo - , prvaVoteAggregates = Map.empty +instance HasPerasVoteVotedBlock (PerasTargetVoteTally blk) blk where + getPerasVoteVotedBlock = snd . getPerasVoteTarget + +freshTargetVoteTally :: PerasVoteTarget blk -> PerasTargetVoteTally blk +freshTargetVoteTally target = + PerasTargetVoteTally + { ptvtTarget = target + , ptvtVotes = Map.empty + , ptvtTotalStake = PerasVoteStake 0 } --- | Add a vote to an existing target aggregate if it isn't already present, +-- | Check whether the given target vote tally's stake is above quorum. +voteTallyAboveQuorum :: + PerasCfg blk -> + PerasTargetVoteTally blk -> + Bool +voteTallyAboveQuorum PerasCfg{perasCfgQuorumThreshold} ptvt = + ptvtTotalStake ptvt >= perasCfgQuorumThreshold + +-- | Add a vote to an existing target tally if it isn't already present, -- and update the stake accordingly. --- PRECONDITION: the vote's target must match the aggregate's target. -updateTargetVoteAggregate :: +-- PRECONDITION: the vote's target must match the tally's target. +updateTargetVoteTally :: StandardHash blk => WithArrivalTime (ValidatedPerasVote blk) -> - PerasTargetVoteAggregate blk -> - PerasTargetVoteAggregate blk -updateTargetVoteAggregate + PerasTargetVoteTally blk -> + PerasTargetVoteTally blk +updateTargetVoteTally vote - ptva@PerasTargetVoteAggregate - { ptvaTarget = (roundNo, point) - , ptvaVotes = existingVotes - , ptvaTotalStake = initialStake + ptvt@PerasTargetVoteTally + { ptvtTarget + , ptvtVotes + , ptvtTotalStake } = - if getPerasVoteRound vote /= roundNo || getPerasVoteVotedBlock vote /= point - then error "updatePerasVoteAggregate: vote target does not match aggregate target" + if getPerasVoteTarget vote /= ptvtTarget + then error "updatePerasVoteTally: vote target does not match tally target" else let (pvaVotes', pvaTotalStake') = case Map.insertLookupWithKey (\_k old _new -> old) (getId vote) vote - existingVotes of + ptvtVotes of (Nothing, votes') -> -- key was NOT present → inserted and stake updated - (votes', initialStake + vpvVoteStake (forgetArrivalTime vote)) + (votes', ptvtTotalStake + vpvVoteStake (forgetArrivalTime vote)) (Just _, _) -> -- key WAS already present → votes and stake unchanged - (existingVotes, initialStake) - in ptva{ptvaVotes = pvaVotes', ptvaTotalStake = pvaTotalStake'} + (ptvtVotes, ptvtTotalStake) + in ptvt{ptvtVotes = pvaVotes', ptvtTotalStake = pvaTotalStake'} + +------------------------------------------------------------------------------- + +-- | Indicate the current status of the target w.r.t the voting process. +data PerasTargetVoteStatus + = Candidate + | Winner + | Loser + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass NoThunks + +-- | Voting state for a given target. +-- We indicate at type level the status of the target w.r.t the voting process. +data PerasTargetVoteState blk (status :: PerasTargetVoteStatus) where + PerasTargetVoteCandidate :: + !(PerasTargetVoteTally blk) -> + PerasTargetVoteState blk 'Candidate + PerasTargetVoteLoser :: + !(PerasTargetVoteTally blk) -> + PerasTargetVoteState blk 'Loser + PerasTargetVoteWinner :: + !(PerasTargetVoteTally blk) -> + -- | Number of extra votes received since the target was elected winner / + -- the cert was forged. + !Word64 -> + !(ValidatedPerasCert blk) -> + PerasTargetVoteState blk 'Winner + +deriving stock instance + ( Eq (PerasTargetVoteTally blk) + , Eq (ValidatedPerasCert blk) + ) => + Eq (PerasTargetVoteState blk status) + +deriving stock instance + ( Ord (PerasTargetVoteTally blk) + , Ord (ValidatedPerasCert blk) + ) => + Ord (PerasTargetVoteState blk status) + +deriving stock instance + ( Show (PerasTargetVoteTally blk) + , Show (ValidatedPerasCert blk) + ) => + Show (PerasTargetVoteState blk status) + +instance + ( NoThunks (PerasTargetVoteTally blk) + , NoThunks (ValidatedPerasCert blk) + ) => + NoThunks (PerasTargetVoteState blk status) + where + -- avoid the Generic-based default + showTypeOf _ = "PerasTargetVoteState" + + -- we can just delegate wNoThunks to our custom noThunks + wNoThunks = noThunks + + noThunks ctx (PerasTargetVoteCandidate tally) = + noThunks ctx tally + noThunks ctx (PerasTargetVoteLoser tally) = + noThunks ctx tally + noThunks ctx (PerasTargetVoteWinner tally w cert) = + noThunks ctx (tally, w, cert) + +instance HasPerasVoteTarget (PerasTargetVoteState blk status) blk where + getPerasVoteTarget = getPerasVoteTarget . ptvsVoteTally + +instance HasPerasVoteRound (PerasTargetVoteState blk status) where + getPerasVoteRound = getPerasVoteRound . ptvsVoteTally + +instance HasPerasVoteVotedBlock (PerasTargetVoteState blk status) blk where + getPerasVoteVotedBlock = getPerasVoteVotedBlock . ptvsVoteTally + +ptvsVoteTally :: PerasTargetVoteState blk status -> PerasTargetVoteTally blk +ptvsVoteTally = \case + PerasTargetVoteCandidate tally -> tally + PerasTargetVoteLoser tally -> tally + PerasTargetVoteWinner tally _ _ -> tally + +freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate +freshCandidateVoteState target = + PerasTargetVoteCandidate (freshTargetVoteTally target) + +freshLoserVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Loser +freshLoserVoteState target = + PerasTargetVoteLoser (freshTargetVoteTally target) + +-- | Convert a 'Candidate' state to a 'Loser' state. This function is called on +-- all candidates (except the winner) once a winner is elected. +candidateToLoser :: + PerasCfg blk -> + PerasTargetVoteState blk 'Candidate -> + PerasTargetVoteState blk 'Loser +candidateToLoser cfg (PerasTargetVoteCandidate tally) = + if voteTallyAboveQuorum cfg tally + then error "candidateToLoser: candidate is above quorum" + else PerasTargetVoteLoser tally + +-- | Add a vote to an existing target vote state if it isn't already present +-- PRECONDITION: the vote's target must match the underlying tally's target. +-- +-- May fail if the candidate is elected winner but forging the certificate fails. +updateCandidateVoteState :: + StandardHash blk => + PerasCfg blk -> + WithArrivalTime (ValidatedPerasVote blk) -> + PerasTargetVoteState blk 'Candidate -> + Either + (PerasForgeErr blk) + (Either (PerasTargetVoteState blk 'Candidate) (PerasTargetVoteState blk 'Winner)) +updateCandidateVoteState cfg vote oldState = + let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) + voteList = forgetArrivalTime <$> Map.elems (ptvtVotes newVoteTally) + in if voteTallyAboveQuorum cfg newVoteTally + then case forgePerasCert cfg (ptvtTarget newVoteTally) voteList of + Left err -> Left $ err + Right cert -> Right $ Right $ PerasTargetVoteWinner newVoteTally 0 cert + else Right $ Left $ PerasTargetVoteCandidate newVoteTally + +-- | Add a vote to an existing target vote state if it isn't already present +-- PRECONDITION: the vote's target must match the underlying tally's target. +-- +-- May fail if the loser goes above quorum by adding the vote. +updateLoserVoteState :: + StandardHash blk => + PerasCfg blk -> + WithArrivalTime (ValidatedPerasVote blk) -> + PerasTargetVoteState blk 'Loser -> + Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser) +updateLoserVoteState cfg vote oldState = + let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) + aboveQuorum = voteTallyAboveQuorum cfg newVoteTally + in if aboveQuorum + then Left $ PerasTargetVoteLoser newVoteTally + else Right $ PerasTargetVoteLoser newVoteTally + +-- | Add a vote to an existing target vote state if it isn't already present +-- PRECONDITION: the vote's target must match the underlying tally's target. +updateWinnerVoteState :: + StandardHash blk => + WithArrivalTime (ValidatedPerasVote blk) -> + PerasTargetVoteState blk 'Winner -> + PerasTargetVoteState blk 'Winner +updateWinnerVoteState vote oldState = + let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState) + (PerasTargetVoteWinner _ extraCertCount cert) = oldState + in PerasTargetVoteWinner newVoteTally (extraCertCount + 1) cert + +------------------------------------------------------------------------------- + +-- | Current vote state for a given round. +data PerasRoundVoteState blk + = PerasRoundVoteStateQuorumNotReached + { prvsRoundNo :: !PerasRoundNo + , prvsCandidateStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Candidate)) + } + | PerasRoundVoteStateQuorumReachedAlready + { prvsRoundNo :: !PerasRoundNo + , prvsLoserStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Loser)) + , prvsWinnerState :: !(PerasTargetVoteState blk 'Winner) + } + deriving stock (Generic, Eq, Ord, Show) + deriving anyclass NoThunks + +instance HasPerasVoteRound (PerasRoundVoteState blk) where + getPerasVoteRound = prvsRoundNo + +-- | Get the certificate if quorum was reached for the given round. +prvsMaybeCert :: PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk) +prvsMaybeCert = \case + PerasRoundVoteStateQuorumNotReached{} -> Nothing + PerasRoundVoteStateQuorumReachedAlready{prvsWinnerState = PerasTargetVoteWinner _ _ cert} -> + Just cert + +freshRoundVoteState :: + PerasRoundNo -> + PerasRoundVoteState blk +freshRoundVoteState roundNo = + PerasRoundVoteStateQuorumNotReached + { prvsRoundNo = roundNo + , prvsCandidateStates = Map.empty + } + +data UpdateRoundVoteStateError blk + = RoundVoteStateLoserAboveQuorum (PerasTargetVoteState blk 'Winner) (PerasTargetVoteState blk 'Loser) + | RoundVoteStateForgingCertError (PerasForgeErr blk) -- | Add a vote to an existing round aggregate. -- PRECONDITION: the vote's round must match the aggregate's round. -updatePerasRoundVoteAggregates :: +-- +-- May fail if the state transition is invalid (e.g., a loser going above +-- quorum) or if forging the certificate fails. +updatePerasRoundVoteState :: + forall blk. StandardHash blk => WithArrivalTime (ValidatedPerasVote blk) -> PerasCfg blk -> - PerasRoundVoteAggregates blk -> - PerasRoundVoteAggregates blk -updatePerasRoundVoteAggregates vote cfg@PerasCfg{perasCfgQuorumThreshold} roundAggrs = - if getPerasVoteRound vote /= prvaRoundNo roundAggrs - then error "updatePerasRoundVoteAggregates: vote round does not match aggregate round" - else - let target = getPerasVoteTarget vote - point = snd target - (oldTargetAggr, newTargetAggr, prvaVoteAggregates') = - updateWithDefault - (newTargetVoteAggregate target) - (updateTargetVoteAggregate vote) - point - (prvaVoteAggregates roundAggrs) - mustEmitCert = - ptvaTotalStake oldTargetAggr < perasCfgQuorumThreshold - && ptvaTotalStake newTargetAggr >= perasCfgQuorumThreshold - in case (roundAggrs, mustEmitCert) of - (PerasRoundVoteAggregatesQuorumNotReached{prvaRoundNo}, True) -> - PerasRoundVoteAggregatesQuorumReachedAlready - { prvaRoundNo - , prvaVoteAggregates = prvaVoteAggregates' - , prvaCert = case forgePerasCert cfg target (forgetArrivalTime <$> Map.elems (ptvaVotes newTargetAggr)) of - -- TODO: the forge error might be made into a PerasVoteDB error variant? - Left err -> - error - ( "updatePerasRoundVoteAggregates: forging the " - ++ "certificate should be valid when quorum is " - ++ "reached, but got error: " - ++ show err - ) - Right cert -> cert - } - (PerasRoundVoteAggregatesQuorumNotReached{prvaRoundNo}, False) -> - PerasRoundVoteAggregatesQuorumNotReached - { prvaRoundNo - , prvaVoteAggregates = prvaVoteAggregates' - } - (PerasRoundVoteAggregatesQuorumReachedAlready{prvaRoundNo, prvaCert}, True) -> - -- TODO: the equivocating cert error might be made into a PerasVoteDB error variant? - error - ( "updatePerasRoundVoteAggregates: quorum was already reached for round " - ++ show prvaRoundNo - ++ " on point " - ++ show (pcCertBoostedBlock . vpcCert $ prvaCert) - ++ ", but we reached it again on point " - ++ show point - ++ "with " - ++ show (ptvaTotalStake newTargetAggr) - ++ " stake (quorum threshold = " - ++ (show perasCfgQuorumThreshold) - ++ ". Equivocating certificates should be impossible per design." - ) - (PerasRoundVoteAggregatesQuorumReachedAlready{prvaRoundNo, prvaCert}, False) -> - PerasRoundVoteAggregatesQuorumReachedAlready - { prvaRoundNo - , prvaCert - , prvaVoteAggregates = prvaVoteAggregates' - } + PerasRoundVoteState blk -> + Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk) +updatePerasRoundVoteState vote cfg roundState = + if getPerasVoteRound vote /= getPerasVoteRound roundState + then error "updatePerasRoundVoteTallys: vote round does not match aggregate round" + else case roundState of + PerasRoundVoteStateQuorumNotReached{prvsCandidateStates} -> + let oldCandidateState = + Map.findWithDefault + (freshCandidateVoteState (getPerasVoteTarget vote)) + (getPerasVoteVotedBlock vote) + prvsCandidateStates + in case updateCandidateVoteState cfg vote oldCandidateState of + Left err -> Left $ RoundVoteStateForgingCertError err + Right (Left newCandidateState) -> + let prvsCandidateStates' = + Map.insert + (getPerasVoteVotedBlock vote) + newCandidateState + prvsCandidateStates + in Right $ + PerasRoundVoteStateQuorumNotReached + { prvsRoundNo = prvsRoundNo roundState + , prvsCandidateStates = prvsCandidateStates' + } + Right (Right winnerState) -> + let winnerPoint = getPerasVoteVotedBlock winnerState + loserStates = candidateToLoser cfg <$> (Map.delete winnerPoint prvsCandidateStates) + in Right $ + PerasRoundVoteStateQuorumReachedAlready + { prvsRoundNo = prvsRoundNo roundState + , prvsLoserStates = loserStates + , prvsWinnerState = winnerState + } + state@PerasRoundVoteStateQuorumReachedAlready{prvsLoserStates, prvsWinnerState} -> + let votePoint = getPerasVoteVotedBlock vote + winnerPoint = getPerasVoteVotedBlock prvsWinnerState + + updateMaybeLoser :: + Maybe (PerasTargetVoteState blk 'Loser) -> + Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser) + updateMaybeLoser mState = + updateLoserVoteState cfg vote (fromMaybe (freshLoserVoteState (getPerasVoteTarget vote)) mState) + in if votePoint == winnerPoint + then Right $ state{prvsWinnerState = updateWinnerVoteState vote prvsWinnerState} + else case Map.alterF (\mState -> Just <$> updateMaybeLoser mState) votePoint prvsLoserStates of + Left newLoserStateAboveQuorum -> + Left $ RoundVoteStateLoserAboveQuorum prvsWinnerState newLoserStateAboveQuorum + Right prvsLoserStates' -> + Right $ state{prvsLoserStates = prvsLoserStates'} + +-- | Updates the round vote states map with the given vote. +-- A new entry is created if necessary (i.e., if there is no existing state for +-- the vote's round). +-- +-- May fail if the state transition is invalid (e.g., a loser going above +-- quorum) or if forging the certificate fails. +updatePerasRoundVoteStates :: + forall blk. + StandardHash blk => + WithArrivalTime (ValidatedPerasVote blk) -> + PerasCfg blk -> + Map PerasRoundNo (PerasRoundVoteState blk) -> + Either + (UpdateRoundVoteStateError blk) + (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk)) +updatePerasRoundVoteStates vote cfg = + -- We use the Functor instance of `Compose (Either e) ((,) s)` ≅ `λt. Either e (s, t)` in `Map.alterF` + -- That way, we can return both the updated map and the updated leaf in one pass, + -- and still handle errors. + getCompose + . Map.alterF + (\mState -> Just <$> updateMaybeRoundState mState) + (getPerasVoteRound vote) + where + updateMaybeRoundState :: + Maybe (PerasRoundVoteState blk) -> + Compose + (Either (UpdateRoundVoteStateError blk)) + ((,) (PerasRoundVoteState blk)) + (PerasRoundVoteState blk) + updateMaybeRoundState mRoundState = Compose $ + case updatePerasRoundVoteState + vote + cfg + (fromMaybe (freshRoundVoteState (getPerasVoteRound vote)) mRoundState) of + Left err -> Left err + Right newRoundState -> Right (newRoundState, newRoundState) {------------------------------------------------------------------------------ Opening the database @@ -237,6 +423,7 @@ openDB :: forall m blk. ( IOLike m , StandardHash blk + , Typeable blk ) => Complete PerasVoteDbArgs m blk -> m (PerasVoteDB m blk) @@ -285,17 +472,18 @@ data PerasVoteDbEnv m blk = PerasVoteDbEnv deriving NoThunks via OnlyCheckWhnfNamed "PerasVoteDbEnv" (PerasVoteDbEnv m blk) getEnv :: - (IOLike m, HasCallStack) => + forall m r blk. + (IOLike m, HasCallStack, StandardHash blk, Typeable blk) => PerasVoteDbHandle m blk -> (PerasVoteDbEnv m blk -> m r) -> m r getEnv (PerasVoteDbHandle varState) f = readTVarIO varState >>= \case PerasVoteDbOpen env -> f env - PerasVoteDbClosed -> throwIO $ ClosedDBError prettyCallStack + PerasVoteDbClosed -> throwIO $ ClosedDBError @blk prettyCallStack getEnv1 :: - (IOLike m, HasCallStack) => + (IOLike m, HasCallStack, StandardHash blk, Typeable blk) => PerasVoteDbHandle m blk -> (PerasVoteDbEnv m blk -> a -> m r) -> a -> @@ -303,17 +491,18 @@ getEnv1 :: getEnv1 h f a = getEnv h (\env -> f env a) getEnvSTM :: - (IOLike m, HasCallStack) => + forall m r blk. + (IOLike m, HasCallStack, StandardHash blk, Typeable blk) => PerasVoteDbHandle m blk -> (PerasVoteDbEnv m blk -> STM m r) -> STM m r getEnvSTM (PerasVoteDbHandle varState) f = readTVar varState >>= \case PerasVoteDbOpen env -> f env - PerasVoteDbClosed -> throwIO $ ClosedDBError prettyCallStack + PerasVoteDbClosed -> throwIO $ ClosedDBError @blk prettyCallStack getEnvSTM1 :: - (IOLike m, HasCallStack) => + (IOLike m, HasCallStack, StandardHash blk, Typeable blk) => PerasVoteDbHandle m blk -> (PerasVoteDbEnv m blk -> a -> STM m r) -> a -> @@ -337,6 +526,7 @@ implCloseDB (PerasVoteDbHandle varState) = implAddVote :: ( IOLike m , StandardHash blk + , Typeable blk ) => PerasCfg blk -> PerasVoteDbEnv m blk -> @@ -359,7 +549,7 @@ implAddVote WithFingerprint PerasVoteState { pvsVoteIds - , pvsVoteAggrsByRound + , pvsRoundVoteStates , pvsVotesByTicket , pvsLastTicketNo } @@ -370,27 +560,30 @@ implAddVote then pure PerasVoteAlreadyInDB else do let pvsVoteIds' = Set.insert voteId pvsVoteIds - roundNo = getPerasVoteRound vote - (oldRoundAggrs, newRoundAggrs, pvsVoteAggrsByRound') = - updateWithDefault - (newRoundVoteAggregates roundNo) - (updatePerasRoundVoteAggregates vote perasCfg) - roundNo - pvsVoteAggrsByRound - res = case (oldRoundAggrs, newRoundAggrs) of - ( PerasRoundVoteAggregatesQuorumNotReached{} - , PerasRoundVoteAggregatesQuorumReachedAlready{prvaCert} - ) -> - AddedPerasVoteAndGeneratedNewCert prvaCert - _ -> AddedPerasVoteButDidntGenerateNewCert pvsLastTicketNo' = succ pvsLastTicketNo pvsVotesByTicket' = Map.insert pvsLastTicketNo' vote pvsVotesByTicket fp' = succ fp + (res, pvsRoundVoteStates') <- case updatePerasRoundVoteStates vote perasCfg pvsRoundVoteStates of + Left (RoundVoteStateLoserAboveQuorum winnerState loserState) -> + throwSTM $ + EquivocatingCertError + (getPerasVoteRound vote) + (getPerasVoteVotedBlock winnerState, vpvVoteStake (forgetArrivalTime vote)) + (getPerasVoteVotedBlock loserState, vpvVoteStake (forgetArrivalTime vote)) + Left (RoundVoteStateForgingCertError err) -> + throwSTM $ ForgingCertError err + Right + ( PerasRoundVoteStateQuorumReachedAlready{prvsWinnerState = PerasTargetVoteWinner _ 0 cert} + , pvsRoundVoteStates' + ) -> + pure (AddedPerasVoteAndGeneratedNewCert cert, pvsRoundVoteStates') + Right (_, pvsRoundVoteStates') -> + pure (AddedPerasVoteButDidntGenerateNewCert, pvsRoundVoteStates') writeTVar pvdbPerasVoteStateVar $ WithFingerprint PerasVoteState { pvsVoteIds = pvsVoteIds' - , pvsVoteAggrsByRound = pvsVoteAggrsByRound' + , pvsRoundVoteStates = pvsRoundVoteStates' , pvsVotesByTicket = pvsVotesByTicket' , pvsLastTicketNo = pvsLastTicketNo' } @@ -423,10 +616,10 @@ implForgedCertForRound :: PerasRoundNo -> STM m (Maybe (ValidatedPerasCert blk)) implForgedCertForRound PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = do - PerasVoteState{pvsVoteAggrsByRound} <- forgetFingerprint <$> readTVar pvdbPerasVoteStateVar - case Map.lookup roundNo pvsVoteAggrsByRound of + PerasVoteState{pvsRoundVoteStates} <- forgetFingerprint <$> readTVar pvdbPerasVoteStateVar + case Map.lookup roundNo pvsRoundVoteStates of Nothing -> pure Nothing - Just aggr -> pure $ prvaMaybeCert aggr + Just aggr -> pure $ prvsMaybeCert aggr implGarbageCollect :: forall m blk. @@ -441,14 +634,14 @@ implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = gc PerasVoteState { pvsVoteIds - , pvsVoteAggrsByRound + , pvsRoundVoteStates , pvsVotesByTicket , pvsLastTicketNo } = - let pvsVoteAggrsByRound' = + let pvsRoundVoteStates' = Map.filterWithKey (\rNo _ -> rNo >= roundNo) - pvsVoteAggrsByRound + pvsRoundVoteStates (pvsVotesByTicket', votesToRemove) = Map.partition (\vote -> getPerasVoteRound vote >= roundNo) pvsVotesByTicket pvsVoteIds' = Foldable.foldl' @@ -457,7 +650,7 @@ implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = votesToRemove in PerasVoteState { pvsVoteIds = pvsVoteIds' - , pvsVoteAggrsByRound = pvsVoteAggrsByRound' + , pvsRoundVoteStates = pvsRoundVoteStates' , pvsVotesByTicket = pvsVotesByTicket' , pvsLastTicketNo = pvsLastTicketNo } @@ -468,11 +661,11 @@ implGarbageCollect PerasVoteDbEnv{pvdbPerasVoteStateVar} roundNo = data PerasVoteState blk = PerasVoteState { pvsVoteIds :: !(Set (IdOf (PerasVote blk))) - , pvsVoteAggrsByRound :: !(Map PerasRoundNo (PerasRoundVoteAggregates blk)) + , pvsRoundVoteStates :: !(Map PerasRoundNo (PerasRoundVoteState blk)) , pvsVotesByTicket :: !(Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))) -- ^ The votes by 'PerasVoteTicketNo'. -- - -- INVARIANT: In sync with 'pvsVoteAggrsByRound'. + -- INVARIANT: In sync with 'pvsRoundVoteStates'. , pvsLastTicketNo :: !PerasVoteTicketNo -- ^ The most recent 'PerasVoteTicketNo' (or 'zeroPerasVoteTicketNo' -- otherwise). @@ -485,7 +678,7 @@ initialPerasVoteState = WithFingerprint PerasVoteState { pvsVoteIds = Set.empty - , pvsVoteAggrsByRound = Map.empty + , pvsRoundVoteStates = Map.empty , pvsVotesByTicket = Map.empty , pvsLastTicketNo = zeroPerasVoteTicketNo } @@ -515,7 +708,9 @@ data TraceEvent blk Exceptions -------------------------------------------------------------------------------} -data PerasVoteDbError +data PerasVoteDbError blk = ClosedDBError PrettyCallStack + | EquivocatingCertError PerasRoundNo (Point blk, PerasVoteStake) (Point blk, PerasVoteStake) + | ForgingCertError (PerasForgeErr blk) deriving stock Show deriving anyclass Exception