Refactor VoteDB to enforce single-cert-per-round invariant

Author: tbagrel1

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

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

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 ::