From b351cc3297693500bcc0fdaef794044c5284bfda Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 27 Apr 2026 12:23:43 +0200 Subject: [PATCH 01/20] Tweak voting committee crypto interface for aggregatable types This commit tweaks the generic voting committee interface around aggregatable types to better acommodate the fact that cryptographic aggregation of signatures can fail (in very rare cases). Previously, we had encapsulated this problem by collecting keys and signatures and aggregating them at verification time. The new interface is more faithful and accounts for the new failure mode in a more honest way. In addition, it renames the 'CryptoSupportsAggregateVRF' class into 'CryptoSupportsBatchVRFVerification', since the new interface constraints the inputs to /not/ be aggregated at (batch) verification time, so that implementations that require binding keys to VRF outputs can do so more directly and explicitly. Finally, it removes the trivial aggregation helpers introduced in Peras 22, as concrete implementations of the new aggregation interface will not benefit much from having them, so there's no need to maintain unused code for which we have no plans to use in the long term either. Co-authored-by: Nicolas BACQUEY Co-authored-by: Thomas BAGREL Co-authored-by: Agustin Mista --- .../Ouroboros/Consensus/Committee/Class.hs | 4 +- .../Ouroboros/Consensus/Committee/Crypto.hs | 240 ++++-------------- 2 files changed, 48 insertions(+), 196 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs index 6d656d14e5..5ec07a3cf2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs @@ -103,7 +103,9 @@ class -- | Forge a certificate attesting the winner of a given election forgeCert :: VotesWithSameTarget crypto committee -> - Cert crypto committee + Either + (VotingCommitteeError crypto committee) + (Cert crypto committee) -- | Verify a certificate attesting the winner of a given election verifyCert :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto.hs index 8c002843bf..175f27c039 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -19,35 +18,20 @@ module Ouroboros.Consensus.Committee.Crypto -- * Vote signing interface , CryptoSupportsVoteSigning (..) - , CryptoSupportsAggregateVoteSigning (..) - - -- ** Trivial aggregate vote signature verification helpers - , TrivialAggregateVoteVerificationKey (..) - , TrivialAggregateVoteSignature (..) - , trivialLiftVoteVerificationKey - , trivialLiftVoteSignature - , trivialVerifyAggregateVoteSignature -- * VRF-based eligibility proofs interface , VRFPoolContext (..) , NormalizedVRFOutput (..) , CryptoSupportsVRF (..) - , CryptoSupportsAggregateVRF (..) - - -- ** Trivial aggregate VRF verification helpers - , TrivialAggregateVRFVerificationKey (..) - , TrivialAggregateVRFOutput (..) - , trivialLiftVRFVerificationKey - , trivialLiftVRFOutput - , trivialVerifyAggregateVRFOutput + + -- * Aggregate verification interface + , CryptoSupportsAggregateVoteSigning (..) + , CryptoSupportsBatchVRFVerification (..) ) where import Cardano.Ledger.BaseTypes (Nonce) import Data.Containers.NonEmpty (HasNonEmpty (..)) -import Data.Either (partitionEithers) import Data.Kind (Type) -import Data.List (intercalate) -import qualified Data.List.NonEmpty as NonEmpty import Data.Proxy (Proxy) -- * Core types associated to voting committees @@ -104,100 +88,6 @@ class CryptoSupportsVoteSigning crypto where VoteSignature crypto -> Either String () --- | Crypto interface used for verifying aggregate vote signatures -class - ( Semigroup (AggregateVoteVerificationKey crypto) - , Semigroup (AggregateVoteSignature crypto) - ) => - CryptoSupportsAggregateVoteSigning crypto - where - -- | Key used for verifying aggregate vote signatures - type AggregateVoteVerificationKey crypto :: Type - - -- | Aggregate cryptographic signature of a vote - type AggregateVoteSignature crypto :: Type - - -- | Lift a single vote signature verification key into an aggregate one - liftVoteVerificationKey :: - Proxy crypto -> - VoteVerificationKey crypto -> - AggregateVoteVerificationKey crypto - - -- | Lift a single vote signature into an aggregate one - liftVoteSignature :: - Proxy crypto -> - VoteSignature crypto -> - AggregateVoteSignature crypto - - -- | Verify an aggregate vote signature for a given election and candidate - verifyAggregateVoteSignature :: - Proxy crypto -> - AggregateVoteVerificationKey crypto -> - ElectionId crypto -> - VoteCandidate crypto -> - AggregateVoteSignature crypto -> - Either String () - --- ** Trivial aggregate vote signature verification helpers - -newtype TrivialAggregateVoteVerificationKey crypto - = TrivialAggregateVoteVerificationKey (NE [VoteVerificationKey crypto]) - deriving newtype Semigroup - -newtype TrivialAggregateVoteSignature crypto - = TrivialAggregateVoteSignature (NE [VoteSignature crypto]) - deriving newtype Semigroup - -trivialLiftVoteVerificationKey :: - Proxy crypto -> - VoteVerificationKey crypto -> - TrivialAggregateVoteVerificationKey crypto -trivialLiftVoteVerificationKey _ = - TrivialAggregateVoteVerificationKey - . NonEmpty.singleton - -trivialLiftVoteSignature :: - Proxy crypto -> - VoteSignature crypto -> - TrivialAggregateVoteSignature crypto -trivialLiftVoteSignature _ = - TrivialAggregateVoteSignature - . NonEmpty.singleton - -trivialVerifyAggregateVoteSignature :: - CryptoSupportsVoteSigning crypto => - Proxy crypto -> - TrivialAggregateVoteVerificationKey crypto -> - ElectionId crypto -> - VoteCandidate crypto -> - TrivialAggregateVoteSignature crypto -> - Either String () -trivialVerifyAggregateVoteSignature - _ - (TrivialAggregateVoteVerificationKey keys) - electionId - candidate - (TrivialAggregateVoteSignature signatures) - | length keys /= length signatures = - Left $ - "Aggregate vote signature verification failed: " - <> "number of keys and signatures do not match" - | not (null errors) = - Left $ - "Aggregate vote signature verification failed: " - <> intercalate "; " errors - | otherwise = - Right () - where - (errors, _) = - partitionEithers $ - zipWith - ( \key sig -> - verifyVoteSignature key electionId candidate sig - ) - (NonEmpty.toList keys) - (NonEmpty.toList signatures) - -- * VRF-based eligibility proofs interface -- | Context in which a VRF input is evaluated. @@ -262,90 +152,50 @@ class CryptoSupportsVRF crypto where VRFOutput crypto -> NormalizedVRFOutput --- | Crypto interface used for verifying aggregate VRF signatures -class - ( Semigroup (AggregateVRFVerificationKey crypto) - , Semigroup (AggregateVRFOutput crypto) - ) => - CryptoSupportsAggregateVRF crypto - where - -- | Key used for verifying aggregate VRF outputs - type AggregateVRFVerificationKey crypto :: Type - - -- | Aggregate cryptographic signature of a VRF output - type AggregateVRFOutput crypto :: Type - - -- | Lift a single VRF output verification key into an aggregate one - liftVRFVerificationKey :: +-- * Aggregate verification interface + +-- | Crypto interface used for verifying aggregate vote signatures +class CryptoSupportsAggregateVoteSigning crypto where + -- | Aggregate vote verification keys + type AggregateVoteVerificationKey crypto :: Type + + -- | Aggregate vote signatures + type AggregateVoteSignature crypto :: Type + + -- | Aggregate vote verification keys + aggregateVoteVerificationKeys :: Proxy crypto -> - VRFVerificationKey crypto -> - AggregateVRFVerificationKey crypto + NE [VoteVerificationKey crypto] -> + Either String (AggregateVoteVerificationKey crypto) - -- | Lift a single VRF output into an aggregate one - liftVRFOutput :: + -- | Aggregate vote signatures + aggregateVoteSignatures :: Proxy crypto -> - VRFOutput crypto -> - AggregateVRFOutput crypto + NE [VoteSignature crypto] -> + Either String (AggregateVoteSignature crypto) - -- | Verify an aggregate vote signature for a given election and candidate - verifyAggregateVRFOutput :: - AggregateVRFVerificationKey crypto -> - VRFElectionInput crypto -> - AggregateVRFOutput crypto -> + -- | Verify an aggregate vote signature for a given election and candidate. + verifyAggregateVoteSignature :: + Proxy crypto -> + AggregateVoteVerificationKey crypto -> + ElectionId crypto -> + VoteCandidate crypto -> + AggregateVoteSignature crypto -> Either String () --- ** Trivial aggregate VRF verification helpers - -newtype TrivialAggregateVRFVerificationKey crypto - = TrivialAggregateVRFVerificationKey (NE [VRFVerificationKey crypto]) - deriving newtype Semigroup - -newtype TrivialAggregateVRFOutput crypto - = TrivialAggregateVRFOutput (NE [VRFOutput crypto]) - deriving newtype Semigroup - -trivialLiftVRFVerificationKey :: - Proxy crypto -> - VRFVerificationKey crypto -> - TrivialAggregateVRFVerificationKey crypto -trivialLiftVRFVerificationKey _ = - TrivialAggregateVRFVerificationKey - . NonEmpty.singleton - -trivialLiftVRFOutput :: - Proxy crypto -> - VRFOutput crypto -> - TrivialAggregateVRFOutput crypto -trivialLiftVRFOutput _ = - TrivialAggregateVRFOutput - . NonEmpty.singleton - -trivialVerifyAggregateVRFOutput :: - CryptoSupportsVRF crypto => - TrivialAggregateVRFVerificationKey crypto -> - VRFElectionInput crypto -> - TrivialAggregateVRFOutput crypto -> - Either String () -trivialVerifyAggregateVRFOutput - (TrivialAggregateVRFVerificationKey keys) - vrfInput - (TrivialAggregateVRFOutput vrfOutputs) - | length keys /= length vrfOutputs = - Left $ - "Aggregate VRF output verification failed: " - <> "number of keys and outputs do not match" - | not (null errors) = - Left $ - "Aggregate VRF output verification failed: " - <> intercalate "; " errors - | otherwise = - Right () - where - (errors, _) = - partitionEithers $ - zipWith - ( \key vrfOutput -> - evalVRF (VRFVerifyContext key vrfOutput) vrfInput - ) - (NonEmpty.toList keys) - (NonEmpty.toList vrfOutputs) +-- | Crypto interface used for verifying multiple VRF outputs at once. +class CryptoSupportsBatchVRFVerification crypto where + -- | Verify a list of VRF outputs for a given election input using the + -- corresponding verification keys of their issuers. + -- + -- NOTE: this expects non-aggregate VRF verification keys and VRF outputs + -- because the implementation should be able to first bind each key to its + -- corresponding VRF output via linearization. This is needed to avoid + -- swap-attacks where an adversary could swap their VRF output with someone + -- else's before forging a certificate, stealing their (more favorable) + -- eligibility proof. + batchVerifyVRFOutputs :: + NE [VRFVerificationKey crypto] -> + VRFElectionInput crypto -> + NE [VRFOutput crypto] -> + Either String () From 1adb5cd9ecbd3a8158c6e180cfba7d93a017afa7 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Apr 2026 09:56:52 +0200 Subject: [PATCH 02/20] Implement pure weighted Fait-Accompli logic This commit implements the deterministic core of the weighted Fait-Accompli algorithm using a precomputed extended stake distribution, shareable across multiple voting committees running on the same epoch. The implementation includes a tiebreaker mechanism to allow altering the order of pools with the same stake when the threshold index between persistent and non-persistent voters would land between them. This can later be instantiated to allow for a fair split across epochs. Co-authored-by: Nicolas BACQUEY Co-authored-by: Thomas BAGREL Co-authored-by: Agustin Mista --- ouroboros-consensus.cabal | 2 + .../Ouroboros/Consensus/Committee/WFA.hs | 403 ++++++++++++++++++ 2 files changed, 405 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 230333d77e..a9c9c35659 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -119,6 +119,7 @@ library Ouroboros.Consensus.Committee.Class Ouroboros.Consensus.Committee.Crypto Ouroboros.Consensus.Committee.Types + Ouroboros.Consensus.Committee.WFA Ouroboros.Consensus.Config Ouroboros.Consensus.Config.SecurityParam Ouroboros.Consensus.Config.SupportsNode @@ -351,6 +352,7 @@ library build-depends: FailT ^>=0.1.2, aeson, + array, base >=4.14 && <4.23, base-deriving-via, base16-bytestring >=1.0, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs new file mode 100644 index 0000000000..6dcb5461b5 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | Deterministic portion of the Weighted Fait-Accompli committee selection scheme +module Ouroboros.Consensus.Committee.WFA + ( -- * Weighted Fait-Accompli committee selection scheme + PersistentCommitteeSize (..) + , NonPersistentCommitteeSize (..) + , TotalPersistentStake (..) + , TotalNonPersistentStake (..) + , weightedFaitAccompliSplitSeats + , isAbovePersistentSeatThreshold + + -- * Cumulative stake distributions + , SeatIndex (..) + , NumPoolsWithPositiveStake (..) + , WFAError (..) + , WFATiebreaker (..) + , ExtWFAStakeDistr (..) + , mkExtWFAStakeDistr + , getCandidateInSeat + , seatIndexWithinBounds + ) where + +import Control.Exception (assert) +import Data.Array (Array, Ix, listArray) +import qualified Data.Array as Array +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Word (Word64) +import Ouroboros.Consensus.Committee.Types + ( Cumulative (..) + , LedgerStake (..) + , PoolId + , TargetCommitteeSize (..) + ) + +-- * Weighted Fait-Accompli committee selection scheme + +-- | Persistent committee size +newtype PersistentCommitteeSize + = PersistentCommitteeSize + { unPersistentCommitteeSize :: Word64 + } + deriving (Show, Eq) + +-- | Non-persistent committee size +newtype NonPersistentCommitteeSize + = NonPersistentCommitteeSize + { unNonPersistentCommitteeSize :: Word64 + } + deriving (Show, Eq) + +-- | Total persistent stake +newtype TotalPersistentStake + = TotalPersistentStake + { unTotalPersistentStake :: Cumulative LedgerStake + } + deriving (Show, Eq) + +-- | Total non-persistent stake +newtype TotalNonPersistentStake + = TotalNonPersistentStake + { unTotalNonPersistentStake :: Cumulative LedgerStake + } + deriving (Show, Eq) + +-- | Errors that can occur when trying to split the stake distribution into +-- persistent and seats via weighted Fait-Accompli. +data WFAError + = -- | The underlying stake distribution is empty + EmptyStakeDistribution + | -- | The target committee size is larger than the number of pools with positive + -- stake in the underlying stake distribution, which would lead to incorrect + -- results (e.g. granting persistent seats to voters with zero stake). + NotEnoughPoolsWithPositiveStake + TargetCommitteeSize + NumPoolsWithPositiveStake + deriving (Show, Eq) + +-- | Split a stake distrubution into persistent and non-persistent committee +-- seats according to the weighted Fait-Accompli scheme. +-- +-- This function returns: +-- * number of persistent seats granted via the weighted Fait-Accompli scheme +-- * number of non-persistent seats expected to vote via local sortition +-- * total persistent stake +-- * total non-persistent stake +weightedFaitAccompliSplitSeats :: + -- | Extended cumulative stake distribution of the potential voters + ExtWFAStakeDistr c -> + -- | Expected total committee size (persistent + non-persistent) + TargetCommitteeSize -> + Either + WFAError + ( PersistentCommitteeSize + , NonPersistentCommitteeSize + , TotalPersistentStake + , TotalNonPersistentStake + ) +weightedFaitAccompliSplitSeats extWFAStakeDistr totalSeats + -- The target committee size must not be not larger than the actual number of + -- pools with positive stake in the underlying stake distribution. Otherwise, + -- it could lead to incorrect/non-desirable results (e.g., granting persistent + -- seats to voters with zero stake). + | notEnoughPoolsWithPositiveStake = + Left + ( NotEnoughPoolsWithPositiveStake + totalSeats + (numPoolsWithPositiveStake extWFAStakeDistr) + ) + | otherwise = + -- We should have /at most/ as many persistent voters as the total + -- committee size, but not more. + assert (numPersistentVoters <= unTargetCommitteeSize totalSeats) $ + Right + ( PersistentCommitteeSize numPersistentVoters + , NonPersistentCommitteeSize numNonPersistentVoters + , TotalPersistentStake (Cumulative (LedgerStake persistentStake)) + , TotalNonPersistentStake (Cumulative (LedgerStake nonPersistentStake)) + ) + where + notEnoughPoolsWithPositiveStake = + unNumPoolsWithPositiveStake (numPoolsWithPositiveStake extWFAStakeDistr) + < unTargetCommitteeSize totalSeats + + stakeDistrArray = + unExtWFAStakeDistr extWFAStakeDistr + + ( numPersistentVoters + , persistentStake + , nonPersistentStake + ) = + traverseSeats (Array.bounds stakeDistrArray) True 0 0 0 + + numNonPersistentVoters = + unTargetCommitteeSize totalSeats + - numPersistentVoters + + traverseSeats + (currSeatIndex, lastSeatIndex) + checkPersistentSeatThreshold + accNumPersistentVoters + accPersistentStake + accNonPersistentStake + -- Reached the end + | currSeatIndex > lastSeatIndex = + ( accNumPersistentVoters + , accPersistentStake + , accNonPersistentStake + ) + -- The current voter is persistent + | isPersistent = + traverseSeats + (succ currSeatIndex, lastSeatIndex) + True + (accNumPersistentVoters + 1) + (accPersistentStake + voterStake) + accNonPersistentStake + -- The current voter is non-persistent + | otherwise = + traverseSeats + (succ currSeatIndex, lastSeatIndex) + False + accNumPersistentVoters + accPersistentStake + (accNonPersistentStake + voterStake) + where + -- Extract the entry in the array corresponding to the current seat index + (_, _, LedgerStake voterStake, cumulativeStake) = + (Array.!) stakeDistrArray currSeatIndex + + -- Check whether the current voter can be granted a persistent seat + isPersistent = + -- NOTE: because the check should behave monotonically, we can skip it + -- entirely after the first non-persistent voter is found. + checkPersistentSeatThreshold + && isAbovePersistentSeatThreshold + totalSeats + currSeatIndex + (LedgerStake voterStake) + cumulativeStake + +-- | Evaluate whether a voter with its give stake and relatile position in the +-- stake distribution can be granted a persistent seat in the voting committee. +isAbovePersistentSeatThreshold :: + -- | Total committee size (persistent + non-persistent) + TargetCommitteeSize -> + -- | Current voter seat index + SeatIndex -> + -- | Current voter stake + LedgerStake -> + -- | Cumulated stake of voters with smaller or equal stake than the current one + Cumulative LedgerStake -> + -- | Whether the current voter has a persistent seat or not + Bool +isAbovePersistentSeatThreshold + (TargetCommitteeSize totalSeats) + (SeatIndex voterSeat) + (LedgerStake voterStake) + (Cumulative (LedgerStake cumulativeStake)) + | cumulativeStake <= 0 = + False -- Avoid division by zero in the left-hand side of the inequality + | voterSeat >= totalSeats = + False -- Avoid underflow in the right-hand side of the inequality + | otherwise = + ( (1 - (voterStake / cumulativeStake)) + ^ (2 :: Integer) + ) + < ( toRational (totalSeats - voterSeat - 1) + / toRational (totalSeats - voterSeat) + ) + +-- * Cumulative stake distributions + +-- | Seat index in the voting committee +newtype SeatIndex + = SeatIndex + { unSeatIndex :: Word64 + } + deriving (Show, Eq, Ord, Enum, Ix) + +-- | Number of pools with positive stake in the underlying stake distribution +newtype NumPoolsWithPositiveStake + = NumPoolsWithPositiveStake + { unNumPoolsWithPositiveStake :: Word64 + } + deriving (Show, Eq) + +-- | Tiebreaker for voters with the same stake in the cumulative stake. +-- +-- This is needed to ensure that the cumulative stake distribution is fair with +-- respect to the edge case where there are multiple voters with the same stake +-- around the persistent seat threshold, e.g.: +-- +-- | seat index | stake | selection outcome | +-- |------------|-------|-------------------| +-- | 0 | 50 | persistent | +-- | 1 | 30 | persistent | +-- | 2 | 20 | persistent | +-- | 3 | 20 | non-persistent | +-- | 4 | 20 | non-persistent | +-- | 5 | 10 | non-persistent | +-- | ... | ... | ... | +-- +-- In the case above, the pools with seat index 2, 3 and 4 have the same stake, +-- but (under some hypothetical parameterization) only the one with seat index 2 +-- can be granted a persistent seat according to the weighted Fait-Accompli +-- scheme. Then, the job of this tiebreaker is to ensure that the seat index 2 +-- is fairly distributed among the pools with the same stake. +-- +-- One possible implementation of this tiebreaker is to sort the pools with the +-- same stake according to the hash of the epoch nonce and the pool ID. This way +-- the tiebreaker would be deterministic and resilient to manipulation since an +-- adversary would not be able to predict the epoch nonce in advance. +newtype WFATiebreaker + = WFATiebreaker + { unWFATiebreaker :: PoolId -> PoolId -> Ordering + -- ^ Given two pool IDs, returns an ordering between them to be used as a + -- tiebreaker for voters with the same stake. + } + +-- | Extended cumulative stake distribution. +-- +-- Stake distribution in descending order with precomputed right-cumulative +-- stake, i.e., the total stake of voters with smaller or equal stake than the +-- current one (including the current one itself). In addition, this wrapper +-- also allows the inclusion of an arbitrary payload of type @a@. This is useful +-- to keep track of anything else we might need to know about the voters in the +-- committee selection scheme (e.g. their public keys) in a single place. +-- +-- E.g.: given the following stake distribution: +-- +-- @ +-- PoolId 1 -> (50, PK#1) +-- PoolId 2 -> (15, PK#2) +-- PoolId 3 -> (10, PK#3) +-- PoolId 4 -> (20, PK#4) +-- PoolId 5 -> (5, PK#5) +-- @ +-- +-- We would have the following cumulative stake distribution: +-- +-- @ +-- Array.listArray +-- (SeatIndex 0, SeatIndex 4) +-- [ (PoolId 1, PK#1, LedgerStake 50, CumulativeStake 100) +-- , (PoolId 4, PK#4, LedgerStake 20, CumulativeStake 50) +-- , (PoolId 2, PK#2, LedgerStake 15, CumulativeStake 30) +-- , (PoolId 3, PK#3, LedgerStake 10, CumulativeStake 15) +-- , (PoolId 5, PK#5, LedgerStake 5, CumulativeStake 5) +-- ] +-- @ +-- +-- NOTE: this wrapper exists to allow us to share the same cumulative stake +-- distribution across multiple committee selection instances derived from the +-- same underlying stake distribution (e.g. Leios and Peras voting committees +-- for the same epoch). +data ExtWFAStakeDistr a + = ExtWFAStakeDistr + { unExtWFAStakeDistr :: + Array + SeatIndex + ( PoolId -- Voter ID of this voter + , a -- Extra payload associated to this voter + , LedgerStake -- Ledger stake of this voter + , Cumulative LedgerStake -- Right-cumulative ledger stake of this voter + ) + , numPoolsWithPositiveStake :: NumPoolsWithPositiveStake + -- ^ Number of pools with positive stake in the underlying stake distribution. + -- This is also precomputed at the beginning of the epoch to prevent invalid + -- weighted Fait-Accompli instantiations with a target committee size larger + -- than the number of pools with positive stake, which would lead to incorrect + -- results (e.g. granting persistent seats to voters with zero stake). + } + deriving Show + +-- | Construct an extended cumulative stake distribution. +-- +-- Returns an error if the underlying stake distribution is empty. +mkExtWFAStakeDistr :: + WFATiebreaker -> + Map PoolId (LedgerStake, a) -> + Either WFAError (ExtWFAStakeDistr a) +mkExtWFAStakeDistr tiebreaker pools + | Map.null pools = + Left + EmptyStakeDistribution + | otherwise = + Right + ExtWFAStakeDistr + { unExtWFAStakeDistr = stakeDistrArray + , numPoolsWithPositiveStake = numPoolsWithPositiveStakeAcc + } + where + stakeDistrArray = + listArray + ( SeatIndex 0 + , SeatIndex (fromIntegral (Map.size pools) - 1) + ) + cumulativeStakeAndPools + + ((_totalStake, numPoolsWithPositiveStakeAcc), cumulativeStakeAndPools) = + List.mapAccumR + accumStakeAndCountPoolsWithPositiveStake + ( Cumulative (LedgerStake 0) + , NumPoolsWithPositiveStake 0 + ) + . List.sortBy descendingStakeWithTiebreaker + . Map.toList + $ pools + + descendingStakeWithTiebreaker + (poolId1, (LedgerStake stake1, _)) + (poolId2, (LedgerStake stake2, _)) + -- The pools have the same stake => use the tiebreaker to sort them + | stake1 == stake2 = unWFATiebreaker tiebreaker poolId1 poolId2 + -- The pools have different stake => sort them in descending order + | otherwise = compare stake2 stake1 + + accumStakeAndCountPoolsWithPositiveStake + (Cumulative (LedgerStake stakeAccR), NumPoolsWithPositiveStake numPoolsAccR) + (poolId, (LedgerStake poolStake, poolPublicKey)) = + let stakeAccR' = + stakeAccR + poolStake + numPoolsAccR' + | poolStake > 0 = numPoolsAccR + 1 + | otherwise = numPoolsAccR + in ( + ( Cumulative (LedgerStake stakeAccR') + , NumPoolsWithPositiveStake numPoolsAccR' + ) + , + ( poolId + , poolPublicKey + , LedgerStake poolStake + , Cumulative (LedgerStake stakeAccR') + ) + ) + +-- | Retrieve the candidate information associated to a given seat index. +-- +-- PRECONDITION: the seat index must be within bounds in the stake distribution +getCandidateInSeat :: + SeatIndex -> + ExtWFAStakeDistr a -> + (PoolId, a, LedgerStake, Cumulative LedgerStake) +getCandidateInSeat seatIndex distr = + (Array.!) (unExtWFAStakeDistr distr) seatIndex + +-- | Check that a seat index is within bounds in a stake distribution +seatIndexWithinBounds :: + SeatIndex -> + ExtWFAStakeDistr a -> + Bool +seatIndexWithinBounds seatIndex distr = + unSeatIndex seatIndex >= unSeatIndex lowerBound + && unSeatIndex seatIndex <= unSeatIndex upperBound + where + (lowerBound, upperBound) = + Array.bounds (unExtWFAStakeDistr distr) From 08c3fd135c14479c12d2cec580b0c7cc798f4d36 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Apr 2026 10:03:44 +0200 Subject: [PATCH 03/20] Implement local sortition for non-persistent seats This commit implements the local sortition fallback scheme needed by wFA^LS to allocate non-persistent voters. Each non-persistent voter provides a VRF output that gets normalized and compared against the output of a numerically-stable stake-weighted Poisson distribution. Co-authored-by: Nicolas BACQUEY Co-authored-by: Thomas BAGREL Co-authored-by: Agustin Mista --- ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Committee/LS.hs | 167 ++++++++++++++++++ 2 files changed, 168 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index a9c9c35659..74fc5260ad 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -118,6 +118,7 @@ library Ouroboros.Consensus.Committee.AcrossEpochs Ouroboros.Consensus.Committee.Class Ouroboros.Consensus.Committee.Crypto + Ouroboros.Consensus.Committee.LS Ouroboros.Consensus.Committee.Types Ouroboros.Consensus.Committee.WFA Ouroboros.Consensus.Config diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs new file mode 100644 index 0000000000..27394af7ab --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Local sortition used by non-persistent members of the voting committee +module Ouroboros.Consensus.Committee.LS + ( -- * Local sortition check + LocalSortitionNumSeats (..) + , localSortitionNumSeats + ) where + +import Cardano.Ledger.BaseTypes (FixedPoint, HasZero) +import Data.Maybe (fromMaybe) +import Data.Word (Word64) +import Ouroboros.Consensus.Committee.Crypto (NormalizedVRFOutput (..)) +import Ouroboros.Consensus.Committee.Types (Cumulative (..), LedgerStake (..)) +import Ouroboros.Consensus.Committee.WFA + ( NonPersistentCommitteeSize (..) + , TotalNonPersistentStake (..) + ) + +-- * Local sortition check + +-- | Number of non-persistent seats granted by local sortition to a voter +newtype LocalSortitionNumSeats = LocalSortitionNumSeats + { unLocalSortitionNumSeats :: Word64 + } + deriving stock (Show, Eq, Ord) + deriving newtype (Num, HasZero) + +-- | Compute how many non-persistent seats can be granted by local sortition to +-- a voter given their normalized VRF output and stake +localSortitionNumSeats :: + -- | Expected number of non-persistent voters in the committee + NonPersistentCommitteeSize -> + -- | Total stake of non-persistent voters + TotalNonPersistentStake -> + -- | Stake of the voter + LedgerStake -> + -- | Normalized VRF output from the participant + NormalizedVRFOutput -> + LocalSortitionNumSeats +localSortitionNumSeats + (NonPersistentCommitteeSize numNonPersistentVoters) + (TotalNonPersistentStake (Cumulative (LedgerStake totalNonPersistentStake))) + (LedgerStake voterStake) + (NormalizedVRFOutput normalizedVRFOutput) + -- None of the non-persistent voters have any stake => nobody gets a seat. + -- NOTE: this check also exists to prevent division by zero below. + | totalNonPersistentStake <= 0 = LocalSortitionNumSeats 0 + -- This voter has no stake (but some others do) => it does not get any seat. + -- NOTE: this is an optimization to avoid the expensive computation below. + | voterStake <= 0 = LocalSortitionNumSeats 0 + -- This voter might be entitled to some seats => run the local sortition. + | otherwise = LocalSortitionNumSeats (fromIntegral expectedSeats) + where + -- Expected number of seats granted by local sortition + lambda :: FixedPoint + lambda = + fromRational $ + fromIntegral numNonPersistentVoters + * voterStake + / totalNonPersistentStake + + -- Compute the "orders" of the Poisson distribution with parameter lambda, + -- which are used as thresholds to determine how many seats we get based on + -- the normalized VRF output + orders :: [FixedPoint] + orders = + (fromRational normalizedVRFOutput / lambda) + : zipWith + (\k prev -> k * prev / lambda) + [2 ..] + orders + + -- Estimate how many seats we get by comparing the normalized VRF output + -- against the thresholds defined by the orders. + -- + -- TODO(peras): evaluate whether the limit used below (3) makes sense in + -- this context. One possible starting point would be to understand why + -- @checkLeaderNatValue@ (in Ledger) also uses 3 as its own limit when + -- computing slot leadership proofs. + expectedSeats :: Int + expectedSeats = + fromMaybe 0 $ + taylorExpCmpFirstNonLower + 3 + orders + (-lambda) + +------------------------------------------------------------------------------- +-- Helpers vendored from: +-- https://github.com/cardano-scaling/leios-wfa-ls-demo/blob/7bbd846d9765191ca83b58477dc1596f64ac80fd/leios-wfa-ls-demo/lib/Cardano/Leios/NonIntegral.hs#L227 +-- +-- TODO: merge these into @Cardano.Ledger.NonIntegral@ in @cardano-ledger@ + +data Step a + = Stop + | -- Here we have `Below n err acc divisor` + Below Int a a a + +-- Returns the index of the first element that is NOT certainly BELOW. +-- It evaluates cmps left-to-right, reusing the Taylor-expansion state +-- (acc/err/divisor/n) across elements so we don't redo work. +-- +-- Behavior: +-- * If cmp_i is proven ABOVE -> return i +-- * If max iterations reached while testing cmp_i -> return i +-- * If every element is proven BELOW -> returns Nothing +-- +-- IMPORTANT: boundX must be e^{|x|} for correct error bounds (see taylorExpCmp). +taylorExpCmpFirstNonLower :: + forall a. + RealFrac a => + -- | boundX = e^{|x|} for correct error estimation + a -> + -- | list of cmp thresholds (checked in order) + [a] -> + -- | x in e^x + a -> + Maybe Int +taylorExpCmpFirstNonLower boundX cmps x = + goList 1000 0 x 1 1 0 cmps + where + -- Traverse the list of cmps, advancing the Taylor state as needed while + -- checking if the current cmp is ABOVE or BELOW. If ABOVE, return the index. + goList :: + Int -> -- maxN + Int -> -- n + a -> -- err + a -> -- acc + a -> -- divisor + Int -> -- current index + [a] -> -- remaining cmps + Maybe Int + goList _ _ _ _ _ _ [] = Nothing + goList maxN n err acc divisor i (cmp : rest) = + case decideOne maxN n err acc divisor cmp of + Stop -> + Just i + Below n' err' acc' divisor' -> + goList maxN n' err' acc' divisor' (i + 1) rest + + -- Decide current cmp by advancing the shared Taylor state as needed. + -- If BELOW is established, returns the *advanced* state to continue with. + -- If ABOVE is established or maxN reached, returns Stop. + decideOne :: + Int -> -- maxN + Int -> -- n + a -> -- err + a -> -- acc + a -> -- divisor + a -> -- cmp + Step a + decideOne maxN n err acc divisor cmp + | maxN == n = Stop + | cmp >= acc' + errorTerm = Stop + | cmp < acc' - errorTerm = Below (n + 1) err' acc' divisor' + | otherwise = decideOne maxN (n + 1) err' acc' divisor' cmp + where + divisor' = divisor + 1 + nextX = err + acc' = acc + nextX + err' = (err * x) / divisor' + errorTerm = abs (err' * boundX) From e74632c61b66ef84f42eba8b7def4baef163d80f Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Apr 2026 10:10:51 +0200 Subject: [PATCH 04/20] Implement wFA^LS voting committee instance This commit defined the weighted Fait-Accompli with local soritition voting scheme (WFALS) using the separate WFA and LS components. This includes the definition of both persistent and non-pesistent abstract votes and abstract certificates. NOTE: it is the job of the low-level vote and certificate implementation to provide the plumbing needed to convert between abstract and concrete values, possibly allowing the same concrete definitions to work with multiple voting commitee implementations. Co-authored-by: Nicolas BACQUEY Co-authored-by: Thomas BAGREL Co-authored-by: Agustin Mista --- ouroboros-consensus.cabal | 1 + .../Ouroboros/Consensus/Committee/WFALS.hs | 634 ++++++++++++++++++ 2 files changed, 635 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 74fc5260ad..b39561adc2 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -121,6 +121,7 @@ library Ouroboros.Consensus.Committee.LS Ouroboros.Consensus.Committee.Types Ouroboros.Consensus.Committee.WFA + Ouroboros.Consensus.Committee.WFALS Ouroboros.Consensus.Config Ouroboros.Consensus.Config.SecurityParam Ouroboros.Consensus.Config.SupportsNode diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs new file mode 100644 index 0000000000..4ccdcaff95 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -0,0 +1,634 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Weighted Fait-Accompli with Local Sortition (wFA^LS) committee selection. +-- +-- This module implements a generic committee selection scheme based the on +-- Weighted Fait-Accompli with Local Sortition (wFA^LS) algorithm +-- from the paper: +-- +-- Peter Gaži, Aggelos Kiayias, and Alexander Russell. 2023. Fait Accompli +-- Committee Selection: Improving the Size-Security Tradeoff of Stake-Based +-- Committees. In Proceedings of the 2023 ACM SIGSAC Conference on Computer and +-- Communications Security (CCS '23). Association for Computing Machinery, New +-- York, NY, USA, 845–858. https://doi.org/10.1145/3576915.3623194 +-- +-- PDF: https://eprint.iacr.org/2023/1273.pdf +-- +-- For this, we combine the deterministic portion of the weighted Fait-Accompli +-- scheme (defined in @Ouroboros.Consensus.Committee.WFA@) with local sortition +-- (defined in @Ouroboros.Consensus.Committee.LS@) as a fallback scheme. +module Ouroboros.Consensus.Committee.WFALS + ( -- * Voting committee interface + WFALS + , VotingCommittee -- opaque, only the metrics below are exported + , VotingCommitteeInput (..) + , VotingCommitteeError (..) + , EligibilityWitness (..) + , Vote (..) + , Cert (..) + + -- * Metrics about the voting committee composition + , candidateSeats + , persistentCommitteeSize + , nonPersistentCommitteeSize + , totalPersistentStake + , totalNonPersistentStake + ) where + +import Cardano.Ledger.BaseTypes (NonZero (..), Nonce, nonZero) +import Control.Exception (assert) +import Control.Monad (void) +import Control.Monad.Zip (MonadZip (..)) +import qualified Data.Array as Array +import Data.Bifunctor (Bifunctor (..)) +import Data.Containers.NonEmpty (HasNonEmpty (..)) +import Data.Data (Proxy (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.NonEmpty as NEMap +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Ouroboros.Consensus.Committee.Class + ( CryptoSupportsVotingCommittee (..) + , VotesWithSameTarget + , getElectionIdFromVotes + , getRawVotes + , getVoteCandidateFromVotes + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsAggregateVoteSigning (..) + , CryptoSupportsBatchVRFVerification (..) + , CryptoSupportsVRF (..) + , CryptoSupportsVoteSigning (..) + , ElectionId + , PrivateKey + , PublicKey + , VRFPoolContext (..) + , VoteCandidate + ) +import Ouroboros.Consensus.Committee.LS + ( LocalSortitionNumSeats (..) + , localSortitionNumSeats + ) +import Ouroboros.Consensus.Committee.Types + ( Cumulative (..) + , LedgerStake (..) + , PoolId + , TargetCommitteeSize (..) + , VoteWeight (..) + ) +import Ouroboros.Consensus.Committee.WFA + ( ExtWFAStakeDistr (..) + , NonPersistentCommitteeSize + , PersistentCommitteeSize (..) + , SeatIndex (..) + , TotalNonPersistentStake (..) + , TotalPersistentStake + , WFAError + , getCandidateInSeat + , seatIndexWithinBounds + , weightedFaitAccompliSplitSeats + ) + +-- | Tag for weighted Fait-Accompli with Local Sortition (wFA^LS) +data WFALS + +instance + ( CryptoSupportsVoteSigning crypto + , CryptoSupportsAggregateVoteSigning crypto + , CryptoSupportsVRF crypto + , CryptoSupportsBatchVRFVerification crypto + ) => + CryptoSupportsVotingCommittee crypto WFALS + where + -- According to the weighted Fait-Accompli committee selection scheme, voting + -- committees are composed of two parts: + -- 1. a deterministic set of "persistent" members that are assigned at the + -- beginning of the epoch according to the weighted Fait-Accompli scheme, and + -- 2. a non-deterministic set of "non-persistent" members that are selected on + -- each election within such epoch via local sortition among the candidates + -- that were not granted a persistent seat. + -- + -- Due to 1., this interface is temporarily anchored to a given epoch, allowing + -- us partially apply much of the relevant information about the committee + -- composition at the beginning of such epoch. + data VotingCommittee crypto WFALS + = WFALSVotingCommittee + { -- Preaccumulated stake distribution used to compute committee composition + extWFAStakeDistr :: !(ExtWFAStakeDistr (PublicKey crypto)) + , -- Index of a given candidate in the cumulative stake distribution + candidateSeats :: !(Map PoolId SeatIndex) + , -- Number of persistent seats granted by the weighted Fait-Accompli scheme + persistentCommitteeSize :: !PersistentCommitteeSize + , -- Expected number of non-persistent voters + nonPersistentCommitteeSize :: !NonPersistentCommitteeSize + , -- Total stake of persistent voters + totalPersistentStake :: !TotalPersistentStake + , -- Total stake of non-persistent voters + totalNonPersistentStake :: !TotalNonPersistentStake + , -- Epoch nonce of the epoch where this committee selection takes place + epochNonce :: !Nonce + } + + data VotingCommitteeInput crypto WFALS + = WFALSVotingCommitteeInput + -- Epoch nonce for the epoch where this voting committee takes place + !Nonce + -- Expected committee size for this voting committee + !TargetCommitteeSize + -- Extended cumulative stake distribution of the potential voters + !(ExtWFAStakeDistr (PublicKey crypto)) + + data VotingCommitteeError crypto WFALS + = -- An error occurred during the computation of the committee selection + WFAError WFAError + | -- Pool ID is missing from the voting committee + MissingPoolId PoolId + | -- Voter claims to be a persistent member of the committee, but it's not + NotAPersistentMember SeatIndex + | -- Voter claims to be a non-persistent member of the committe, but it's not + NotANonPersistentMember SeatIndex + | -- VRF evaluation for local sortition failed (e.g. due to invalid proof) + LocalSortitionError String + | -- The VRF evaluation returned zero non-persistent seats + ZeroNonPersistentSeats SeatIndex + | -- The vote signature is invalid + InvalidVoteSignature String + | -- The voter eligibility is invalid + InvalidVoterEligibilityProof String + | -- The certificate signature is invalid + InvalidCertSignature String + | -- We triggered an unexpected cryptographic error + CryptoError String + deriving (Show, Eq) + + data EligibilityWitness crypto WFALS + = -- A persistent member of the voting committee + WFALSPersistentMember + !SeatIndex + !LedgerStake + | -- A realized non-persistent member of the voting committee + WFALSNonPersistentMember + !SeatIndex + !LedgerStake + !(VRFOutput crypto) + !(NonZero LocalSortitionNumSeats) + + data Vote crypto WFALS + = WFALSPersistentVote + !SeatIndex + !(ElectionId crypto) + !(VoteCandidate crypto) + !(VoteSignature crypto) + | WFALSNonPersistentVote + !SeatIndex + !(ElectionId crypto) + !(VoteCandidate crypto) + !(VRFOutput crypto) + !(VoteSignature crypto) + + data Cert crypto WFALS + = WFALSCert + !(ElectionId crypto) + !(VoteCandidate crypto) + !(NE (Map SeatIndex (Maybe (VRFOutput crypto)))) + !(AggregateVoteSignature crypto) + + mkVotingCommittee = mkWFALSVotingCommittee + checkShouldVote = implCheckShouldVote + forgeVote = implForgeVote + verifyVote = implVerifyVote + eligiblePartyVoteWeight = implEligiblePartyVoteWeight + forgeCert = implForgeCert + verifyCert = implVerifyCert + +-- | Construct a 'WFALSVotingCommittee' for a given epoch +mkWFALSVotingCommittee :: + VotingCommitteeInput crypto WFALS -> + Either + (VotingCommitteeError crypto WFALS) + (VotingCommittee crypto WFALS) +mkWFALSVotingCommittee + ( WFALSVotingCommitteeInput + nonce + totalSeats + stakeDistr + ) = do + ( numPersistentVoters + , numNonPersistentVoters + , persistentStake + , nonPersistentStake + ) <- + bimap WFAError id $ + weightedFaitAccompliSplitSeats + stakeDistr + totalSeats + + let seats = + Map.fromList + [ (poolId, seatIndex) + | (seatIndex, (poolId, _, _, _)) <- + Array.assocs (unExtWFAStakeDistr stakeDistr) + ] + + pure $ + WFALSVotingCommittee + { extWFAStakeDistr = stakeDistr + , candidateSeats = seats + , persistentCommitteeSize = numPersistentVoters + , nonPersistentCommitteeSize = numNonPersistentVoters + , totalPersistentStake = persistentStake + , totalNonPersistentStake = nonPersistentStake + , epochNonce = nonce + } + +-- | Check whether we should vote in a given election +implCheckShouldVote :: + forall crypto. + CryptoSupportsVRF crypto => + VotingCommittee crypto WFALS -> + PoolId -> + PrivateKey crypto -> + ElectionId crypto -> + Either + (VotingCommitteeError crypto WFALS) + (Maybe (EligibilityWitness crypto WFALS)) +implCheckShouldVote committee ourId ourPrivateKey electionId + | Just seatIndex <- Map.lookup ourId (candidateSeats committee) = + assert (seatIndexWithinBounds seatIndex (extWFAStakeDistr committee)) $ do + let (_, _, ourStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + let ourVRFSigningKey = + getVRFSigningKey (Proxy @crypto) ourPrivateKey + case isPersistentMember seatIndex committee of + True -> do + pure $ + Just $ + WFALSPersistentMember + seatIndex + ourStake + False -> do + let vrfContext = + VRFSignContext ourVRFSigningKey + vrfOutput <- + bimap InvalidVoteSignature id $ do + evalVRF + vrfContext + ( mkVRFElectionInput + @crypto + (epochNonce committee) + electionId + ) + let numSeats = + localSortitionNumSeats + (nonPersistentCommitteeSize committee) + (totalNonPersistentStake committee) + ourStake + (normalizeVRFOutput vrfOutput) + case nonZero numSeats of + Nothing -> + pure Nothing + Just nonZeroNumSeats -> + pure $ + Just $ + WFALSNonPersistentMember + seatIndex + ourStake + vrfOutput + nonZeroNumSeats + | otherwise = + Left (MissingPoolId ourId) + +-- | Forge a vote for a given election and candidate +implForgeVote :: + forall crypto. + CryptoSupportsVoteSigning crypto => + EligibilityWitness crypto WFALS -> + PrivateKey crypto -> + ElectionId crypto -> + VoteCandidate crypto -> + Vote crypto WFALS +implForgeVote member ourPrivateKey electionId candidate = + case member of + WFALSPersistentMember seatIndex _ -> + WFALSPersistentVote seatIndex electionId candidate sig + WFALSNonPersistentMember seatIndex _ vrfOutput _ -> + WFALSNonPersistentVote seatIndex electionId candidate vrfOutput sig + where + ourVoteSigningKey = + getVoteSigningKey (Proxy @crypto) ourPrivateKey + sig = + signVote ourVoteSigningKey electionId candidate + +-- | Verify a vote cast by a committee member in a given election +implVerifyVote :: + forall crypto. + ( CryptoSupportsVoteSigning crypto + , CryptoSupportsVRF crypto + ) => + VotingCommittee crypto WFALS -> + Vote crypto WFALS -> + Either + (VotingCommitteeError crypto WFALS) + (EligibilityWitness crypto WFALS) +implVerifyVote committee = \case + WFALSPersistentVote seatIndex electionId candidate sig + | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + , isPersistentMember seatIndex committee -> do + let (_, voterPublicKey, voterStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + let voterVerificationKey = + getVoteVerificationKey (Proxy @crypto) voterPublicKey + checkVoteSignature voterVerificationKey electionId candidate sig + pure $ + WFALSPersistentMember + seatIndex + voterStake + | otherwise -> do + Left (NotAPersistentMember seatIndex) + WFALSNonPersistentVote seatIndex electionId message vrfOutput sig + | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + , not (isPersistentMember seatIndex committee) -> do + let (_, voterPublicKey, voterStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + let voterVoteVerificationKey = + getVoteVerificationKey (Proxy @crypto) voterPublicKey + bimap InvalidVoteSignature id $ do + verifyVoteSignature + voterVoteVerificationKey + electionId + message + sig + let voterVRFVerificationKey = + getVRFVerificationKey (Proxy @crypto) voterPublicKey + let vrfContext = + VRFVerifyContext voterVRFVerificationKey vrfOutput + void $ bimap InvalidVoterEligibilityProof id $ do + evalVRF + vrfContext + ( mkVRFElectionInput + @crypto + (epochNonce committee) + electionId + ) + let numSeats = + localSortitionNumSeats + (nonPersistentCommitteeSize committee) + (totalNonPersistentStake committee) + voterStake + (normalizeVRFOutput vrfOutput) + case nonZero numSeats of + Nothing -> + Left (ZeroNonPersistentSeats seatIndex) + Just nonZeroNumSeats -> + pure $ + WFALSNonPersistentMember + seatIndex + voterStake + vrfOutput + nonZeroNumSeats + | otherwise -> + Left (NotANonPersistentMember seatIndex) + +-- | Compute the voting power of an eligible committee member +-- +-- NOTE: theres is a subtle difference between the "Ledger stake" and the "Vote +-- weight" of a given voter. On one hand, the ledger stake is the stake as +-- reflected directly by the ledger stake distribution under consideration. On +-- the other hand, the "Vote" weight refers to the voting power of that voter, +-- i.e., the stake that a voter can effectively contribute to an election, +-- which might be different from their ledger stake depending on their committee +-- membership type: +-- * for a persistent committee member, their vote weight is equal to their +-- ledger stake throughout their entire tenure in the committee, whereas +-- * for a non-persistent committee member, their vote weight (provided that +-- they are actually selected to vote via local sortition) is equal to their +-- ledger stake normalized by the total non-persistent stake. +implEligiblePartyVoteWeight :: + VotingCommittee crypto WFALS -> + EligibilityWitness crypto WFALS -> + VoteWeight +implEligiblePartyVoteWeight committee = \case + -- Persistent members have their voting power equal to their stake + WFALSPersistentMember + _seatIndex + (LedgerStake stake) -> + VoteWeight stake + -- Non-persistent members have their voting power proportional to their + -- number of seats granted by local sortition and their stake (normalized + -- by the total non-persistent stake) + WFALSNonPersistentMember + _seatIndex + (LedgerStake stake) + _vrfOutput + numSeats -> + VoteWeight $ + fromIntegral (unLocalSortitionNumSeats (unNonZero numSeats)) + * stake + / nonPersistentStake + where + TotalNonPersistentStake (Cumulative (LedgerStake nonPersistentStake)) = + totalNonPersistentStake committee + +-- | Forge a certificate attesting the winner of a given election +implForgeCert :: + forall crypto. + CryptoSupportsAggregateVoteSigning crypto => + VotesWithSameTarget crypto WFALS -> + Either + (VotingCommitteeError crypto WFALS) + (Cert crypto WFALS) +implForgeCert votes = do + aggSig <- + bimap CryptoError id $ + aggregateVoteSignatures + (Proxy @crypto) + voteSignatures + pure $ + WFALSCert + (getElectionIdFromVotes votes) + (getVoteCandidateFromVotes votes) + (NEMap.fromAscList voters) + aggSig + where + (voters, voteSignatures) = + munzip $ flip fmap votesInAscendingSeatIndexOrder $ \case + WFALSPersistentVote seatIndex _ _ sig -> + ( (seatIndex, Nothing) + , sig + ) + WFALSNonPersistentVote seatIndex _ _ vrfOutput sig -> + ( (seatIndex, Just vrfOutput) + , sig + ) + + -- Make sure we have votes in ascending seat index order, which is something + -- 'VotesWithSameTarget' cannot guarantee by itself, since seat indices are + -- an implementation detail of this voting committee scheme. + votesInAscendingSeatIndexOrder = + flip NonEmpty.sortWith (getRawVotes votes) $ \case + WFALSPersistentVote seatIndex _ _ _ -> seatIndex + WFALSNonPersistentVote seatIndex _ _ _ _ -> seatIndex + +-- | Verify a certificate attesting the winner of a given election +implVerifyCert :: + forall crypto. + ( CryptoSupportsVoteSigning crypto + , CryptoSupportsAggregateVoteSigning crypto + , CryptoSupportsVRF crypto + , CryptoSupportsBatchVRFVerification crypto + ) => + VotingCommittee crypto WFALS -> + Cert crypto WFALS -> + Either + (VotingCommitteeError crypto WFALS) + (NE [EligibilityWitness crypto WFALS]) +implVerifyCert committee = \case + WFALSCert electionId candidate voters aggSig -> do + -- Traverse the list of voters in ascending seat index order, collecting: + -- 1. their membership status + -- 2. their vote verification keys (to verify the aggregate vote signature) + -- 3. optionally, their VRF verification keys and outputs (to verify the + -- aggregate VRF output for non-persistent voters, if any) + (members, voteVerificationKeys, optionalVRFKeysAndOutputs) <- + fmap nonEmptyUnzip3 . flip traverse (NEMap.toAscList voters) $ \case + -- Persistent voter + (seatIndex, Nothing) + | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + , isPersistentMember seatIndex committee -> do + let (_, voterPublicKey, voterStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + let voterVoteVerificationKey = + getVoteVerificationKey (Proxy @crypto) voterPublicKey + pure + ( WFALSPersistentMember + seatIndex + voterStake + , voterVoteVerificationKey + , Nothing + ) + | otherwise -> + Left (NotAPersistentMember seatIndex) + -- Non-persistent voter + (seatIndex, Just vrfOutput) + | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + , not (isPersistentMember seatIndex committee) -> do + let (_, voterPublicKey, voterStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + let voterVoteVerificationKey = + getVoteVerificationKey (Proxy @crypto) voterPublicKey + let voterVRFVerificationKey = + getVRFVerificationKey (Proxy @crypto) voterPublicKey + let numSeats = + localSortitionNumSeats + (nonPersistentCommitteeSize committee) + (totalNonPersistentStake committee) + voterStake + (normalizeVRFOutput vrfOutput) + case nonZero numSeats of + Nothing -> + Left (ZeroNonPersistentSeats seatIndex) + Just nonZeroNumSeats -> + pure + ( WFALSNonPersistentMember + seatIndex + voterStake + vrfOutput + nonZeroNumSeats + , voterVoteVerificationKey + , Just (voterVRFVerificationKey, vrfOutput) + ) + | otherwise -> + Left (NotANonPersistentMember seatIndex) + + -- Verify aggregate signature + aggVerificationKey <- + bimap CryptoError id $ + aggregateVoteVerificationKeys + (Proxy @crypto) + voteVerificationKeys + bimap InvalidCertSignature id $ + verifyAggregateVoteSignature + (Proxy @crypto) + aggVerificationKey + electionId + candidate + aggSig + + -- Verify VRF outputs for non-persistent voters (if any) + case catMaybes (NonEmpty.toList optionalVRFKeysAndOutputs) of + -- No non-persistent voters => no VRF outputs to verify + [] -> do + pure () + -- Some non-persistent voters => verify their aggregate VRF outputs + vrfKeysAndOutputs -> do + let (vrfVerificationKeys, vrfOutputs) = + munzip + . NonEmpty.fromList -- safe 'vrfKeysAndOutputs' /= [] + $ vrfKeysAndOutputs + bimap InvalidCertSignature id $ + batchVerifyVRFOutputs + vrfVerificationKeys + ( mkVRFElectionInput + @crypto + (epochNonce committee) + electionId + ) + vrfOutputs + + -- Return the list of voters attesting the election winner + pure members + +-- * Helpers + +-- | Check if a voter is a persistent member of in a voting committee +isPersistentMember :: + SeatIndex -> + VotingCommittee crypto WFALS -> + Bool +isPersistentMember seatIndex committee = + unSeatIndex seatIndex + < unPersistentCommitteeSize (persistentCommitteeSize committee) + +-- | Check the validity of a vote signature +checkVoteSignature :: + forall crypto. + CryptoSupportsVoteSigning crypto => + VoteVerificationKey crypto -> + ElectionId crypto -> + VoteCandidate crypto -> + VoteSignature crypto -> + Either + (VotingCommitteeError crypto WFALS) + () +checkVoteSignature verificationKey electionId message sig = + bimap InvalidVoteSignature id $ do + verifyVoteSignature + verificationKey + electionId + message + sig + +-- | Extended unzip3 for 'NonEmpty' lists +nonEmptyUnzip3 :: + NE [(a, b, c)] -> + (NE [a], NE [b], NE [c]) +nonEmptyUnzip3 ((a, b, c) :| rest) = + ( a :| restA + , b :| restB + , c :| restC + ) + where + (restA, restB, restC) = + unzip3 rest From 8000b055c7cbc5be2b7f996e05ea1f1091e38db6 Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Thu, 9 Apr 2026 10:13:50 +0200 Subject: [PATCH 05/20] Implement EveryoneVotes voting committee instance This commit implements EveryoneVotes a simpler alternative to WFALS where every voter with non-negative stake is entitled to vote. This exists as a baseline to run benchmarks against later on. Co-authored-by: Nicolas BACQUEY Co-authored-by: Thomas BAGREL Co-authored-by: Agustin Mista --- ouroboros-consensus.cabal | 1 + .../Consensus/Committee/EveryoneVotes.hs | 353 ++++++++++++++++++ 2 files changed, 354 insertions(+) create mode 100644 ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index b39561adc2..de34af0443 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -118,6 +118,7 @@ library Ouroboros.Consensus.Committee.AcrossEpochs Ouroboros.Consensus.Committee.Class Ouroboros.Consensus.Committee.Crypto + Ouroboros.Consensus.Committee.EveryoneVotes Ouroboros.Consensus.Committee.LS Ouroboros.Consensus.Committee.Types Ouroboros.Consensus.Committee.WFA diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs new file mode 100644 index 0000000000..dfb184b34a --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A simple voting committee where pools with positive stake can vote. +module Ouroboros.Consensus.Committee.EveryoneVotes + ( -- * Voting committee interface + EveryoneVotes + , VotingCommittee -- opaque + , VotingCommitteeInput (..) + , VotingCommitteeError (..) + , EligibilityWitness (..) + , Vote (..) + , Cert (..) + + -- * Metrics about the voting committee composition + , candidateSeats + , numActiveVoters + ) where + +import Cardano.Ledger.BaseTypes (HasZero (..), NonZero, Nonce) +import Cardano.Ledger.BaseTypes.NonZero (NonZero (..), nonZero) +import Control.Exception (assert) +import Control.Monad.Zip (MonadZip (..)) +import qualified Data.Array as Array +import Data.Bifunctor (Bifunctor (..)) +import Data.Containers.NonEmpty (HasNonEmpty (..)) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Set (Set) +import qualified Data.Set.NonEmpty as NESet +import Ouroboros.Consensus.Committee.Class + ( CryptoSupportsVotingCommittee (..) + , VotesWithSameTarget + , getElectionIdFromVotes + , getRawVotes + , getVoteCandidateFromVotes + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsAggregateVoteSigning (..) + , CryptoSupportsVoteSigning (..) + , ElectionId + , PrivateKey + , PublicKey + , VoteCandidate + ) +import Ouroboros.Consensus.Committee.Types + ( LedgerStake (..) + , PoolId + , VoteWeight (..) + ) +import Ouroboros.Consensus.Committee.WFA + ( ExtWFAStakeDistr (..) + , NumPoolsWithPositiveStake (..) + , SeatIndex + , WFAError + , getCandidateInSeat + , seatIndexWithinBounds + ) + +-- | Tag for a simple voting committee where pools with positive stake can vote. +data EveryoneVotes + +instance + ( CryptoSupportsVoteSigning crypto + , CryptoSupportsAggregateVoteSigning crypto + ) => + CryptoSupportsVotingCommittee crypto EveryoneVotes + where + data VotingCommittee crypto EveryoneVotes + = EveryoneVotesVotingCommittee + { -- Preaccumulated stake distribution used to compute committee composition + extWFAStakeDistr :: !(ExtWFAStakeDistr (PublicKey crypto)) + , -- Index of a given candidate in the cumulative stake distribution + candidateSeats :: !(Map PoolId SeatIndex) + , -- Number of active voters (i.e., those with non-zero stake) + numActiveVoters :: !NumPoolsWithPositiveStake + , -- Epoch nonce of the epoch where this committee selection takes place + epochNonce :: !Nonce + } + + data VotingCommitteeInput crypto EveryoneVotes + = EveryoneVotesVotingCommitteeInput + -- Epoch nonce for the epoch where this voting committee takes place + !Nonce + -- Extended cumulative stake distribution of the potential voters + !(ExtWFAStakeDistr (PublicKey crypto)) + + data VotingCommitteeError crypto EveryoneVotes + = -- An error occurred during the computation of the committee selection + WFAError WFAError + | -- Pool ID is missing from the voting committee + MissingPoolId PoolId + | -- Seat index is out of bounds for the voting committee + MissingSeatIndex SeatIndex + | -- Pool has no stake and thus is not entitled to vote + PoolHasNoStake SeatIndex + | -- The vote signature is invalid + InvalidVoteSignature String + | -- The certificate signature is invalid + InvalidCertSignature String + | -- We triggered an unexpected cryptographic error + CryptoError String + deriving (Show, Eq) + + data EligibilityWitness crypto EveryoneVotes + = EveryoneVotesMember + !SeatIndex + !(NonZero LedgerStake) + + data Vote crypto EveryoneVotes + = EveryoneVotesVote + !SeatIndex + !(ElectionId crypto) + !(VoteCandidate crypto) + !(VoteSignature crypto) + + data Cert crypto EveryoneVotes + = EveryoneVotesCert + !(ElectionId crypto) + !(VoteCandidate crypto) + !(NE (Set SeatIndex)) + !(AggregateVoteSignature crypto) + + mkVotingCommittee = mkEveryoneVotesVotingCommittee + checkShouldVote = implCheckShouldVote + forgeVote = implForgeVote + verifyVote = implVerifyVote + eligiblePartyVoteWeight = implEligiblePartyVoteWeight + forgeCert = implForgeCert + verifyCert = implVerifyCert + +-- | Construct a 'EveryoneVotesVotingCommittee' for a given epoch +mkEveryoneVotesVotingCommittee :: + VotingCommitteeInput crypto EveryoneVotes -> + Either + (VotingCommitteeError crypto EveryoneVotes) + (VotingCommittee crypto EveryoneVotes) +mkEveryoneVotesVotingCommittee + ( EveryoneVotesVotingCommitteeInput + nonce + stakeDistr + ) = do + let accumVotersWithPositiveStake + numPoolsAcc + (seatIndex, (poolId, _, stake, _)) = + ( if isZero stake + then numPoolsAcc + else succ numPoolsAcc + , (poolId, seatIndex) + ) + + let (poolsWithPositiveStake, seats) = + bimap NumPoolsWithPositiveStake Map.fromList + . List.mapAccumL accumVotersWithPositiveStake 0 + . Array.assocs + . unExtWFAStakeDistr + $ stakeDistr + + pure $ + EveryoneVotesVotingCommittee + { extWFAStakeDistr = stakeDistr + , candidateSeats = seats + , numActiveVoters = poolsWithPositiveStake + , epochNonce = nonce + } + +-- | Check whether we should vote in a given election +implCheckShouldVote :: + forall crypto. + VotingCommittee crypto EveryoneVotes -> + PoolId -> + PrivateKey crypto -> + ElectionId crypto -> + Either + (VotingCommitteeError crypto EveryoneVotes) + (Maybe (EligibilityWitness crypto EveryoneVotes)) +implCheckShouldVote committee ourId _ourPrivateKey _electionId + | Just seatIndex <- Map.lookup ourId (candidateSeats committee) = + assert (seatIndexWithinBounds seatIndex (extWFAStakeDistr committee)) $ do + let (_, _, ourStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + case nonZero ourStake of + Nothing -> + Left (PoolHasNoStake seatIndex) + Just nonZeroOurStake -> + pure $ + Just $ + EveryoneVotesMember + seatIndex + nonZeroOurStake + | otherwise = + Left (MissingPoolId ourId) + +-- | Forge a vote for a given election and candidate +implForgeVote :: + forall crypto. + CryptoSupportsVoteSigning crypto => + EligibilityWitness crypto EveryoneVotes -> + PrivateKey crypto -> + ElectionId crypto -> + VoteCandidate crypto -> + Vote crypto EveryoneVotes +implForgeVote member ourPrivateKey electionId candidate = + EveryoneVotesVote seatIndex electionId candidate sig + where + EveryoneVotesMember seatIndex _ = + member + ourVoteSigningKey = + getVoteSigningKey (Proxy @crypto) ourPrivateKey + sig = + signVote ourVoteSigningKey electionId candidate + +-- | Verify a vote cast by a committee member in a given election +implVerifyVote :: + forall crypto. + CryptoSupportsVoteSigning crypto => + VotingCommittee crypto EveryoneVotes -> + Vote crypto EveryoneVotes -> + Either + (VotingCommitteeError crypto EveryoneVotes) + (EligibilityWitness crypto EveryoneVotes) +implVerifyVote committee = \case + EveryoneVotesVote seatIndex electionId candidate sig + | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) -> do + let (_, voterPublicKey, voterStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + let voterVerificationKey = + getVoteVerificationKey (Proxy @crypto) voterPublicKey + bimap InvalidVoteSignature id $ do + verifyVoteSignature + voterVerificationKey + electionId + candidate + sig + case nonZero voterStake of + Nothing -> + Left (PoolHasNoStake seatIndex) + Just nonZeroVoterStake -> + pure $ + EveryoneVotesMember + seatIndex + nonZeroVoterStake + | otherwise -> + Left (MissingSeatIndex seatIndex) + +-- | Compute the voting power of an eligible committee member. +-- +-- In this simple voting committee, the vote weight of a member is equal to +-- their ledger stake, as long as it is positive. +implEligiblePartyVoteWeight :: + VotingCommittee crypto EveryoneVotes -> + EligibilityWitness crypto EveryoneVotes -> + VoteWeight +implEligiblePartyVoteWeight _committee member = + VoteWeight (unLedgerStake (unNonZero voterStake)) + where + EveryoneVotesMember _ voterStake = member + +-- | Forge a certificate attesting the winner of a given election +implForgeCert :: + forall crypto. + CryptoSupportsAggregateVoteSigning crypto => + VotesWithSameTarget crypto EveryoneVotes -> + Either + (VotingCommitteeError crypto EveryoneVotes) + (Cert crypto EveryoneVotes) +implForgeCert votes = do + aggSig <- + bimap CryptoError id $ do + aggregateVoteSignatures + (Proxy @crypto) + voteSignatures + pure $ + EveryoneVotesCert + (getElectionIdFromVotes votes) + (getVoteCandidateFromVotes votes) + (NESet.fromList voters) + aggSig + where + (voters, voteSignatures) = + munzip $ flip fmap votesInAscendingSeatIndexOrder $ \case + EveryoneVotesVote seatIndex _ _ sig -> + ( seatIndex + , sig + ) + + -- Make sure we have votes in ascending seat index order, which is something + -- 'VotesWithSameTarget' cannot guarantee by itself, since seat indices are + -- an implementation detail of this voting committee scheme. + votesInAscendingSeatIndexOrder = + flip NonEmpty.sortWith (getRawVotes votes) $ \case + EveryoneVotesVote seatIndex _ _ _ -> seatIndex + +-- | Verify a certificate attesting the winner of a given election +implVerifyCert :: + forall crypto. + ( CryptoSupportsVoteSigning crypto + , CryptoSupportsAggregateVoteSigning crypto + ) => + VotingCommittee crypto EveryoneVotes -> + Cert crypto EveryoneVotes -> + Either + (VotingCommitteeError crypto EveryoneVotes) + (NE [EligibilityWitness crypto EveryoneVotes]) +implVerifyCert committee = \case + EveryoneVotesCert electionId candidate voters aggSig -> do + -- Traverse the list of voters in ascending seat index order, collecting: + -- 1. their membership status + -- 2. their vote verification keys (to verify the aggregate vote signature) + (members, voteVerificationKeys) <- + fmap munzip . flip traverse (NESet.toAscList voters) $ \case + seatIndex + | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) -> do + let (_, voterPublicKey, voterStake, _) = + getCandidateInSeat seatIndex (extWFAStakeDistr committee) + let voterVerificationKey = + getVoteVerificationKey (Proxy @crypto) voterPublicKey + case nonZero voterStake of + Nothing -> + Left (PoolHasNoStake seatIndex) + Just nonZeroVoterStake -> + pure + ( EveryoneVotesMember + seatIndex + nonZeroVoterStake + , voterVerificationKey + ) + | otherwise -> + Left (MissingSeatIndex seatIndex) + -- Verify aggregate signature + aggVerificationKey <- + bimap CryptoError id $ do + aggregateVoteVerificationKeys + (Proxy @crypto) + voteVerificationKeys + bimap InvalidCertSignature id $ + verifyAggregateVoteSignature + (Proxy @crypto) + aggVerificationKey + electionId + candidate + aggSig + + -- Return the list of voters attesting the election winner + pure members From 545a72f12ad39288abfd990f749ca98adaf8389f Mon Sep 17 00:00:00 2001 From: Agustin Mista Date: Mon, 13 Apr 2026 10:01:38 +0200 Subject: [PATCH 06/20] Add changelog Co-authored-by: Nicolas BACQUEY Co-authored-by: Thomas BAGREL Co-authored-by: Agustin Mista --- ...sta_wfals_everyonevotes_implementations.md | 26 +++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 changelog.d/20260413_100031_agustin.mista_wfals_everyonevotes_implementations.md diff --git a/changelog.d/20260413_100031_agustin.mista_wfals_everyonevotes_implementations.md b/changelog.d/20260413_100031_agustin.mista_wfals_everyonevotes_implementations.md new file mode 100644 index 0000000000..c2ad31dd44 --- /dev/null +++ b/changelog.d/20260413_100031_agustin.mista_wfals_everyonevotes_implementations.md @@ -0,0 +1,26 @@ + + + +### Non-Breaking + +- Implemented pure weighted Fait-Accompli logic. +- Implemented local sortition check for non-persistent seats. +- Implemented wFA^LS voting committee instance. +- Implemented EveryoneVotes voting committee instance. + + From 72dbffc4871100dac025cc8776234d3c203c0bea Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 15:15:00 +0200 Subject: [PATCH 07/20] Remove epochNonce from EveryoneVotes committee selection Co-authored-by: Copilot --- .../Ouroboros/Consensus/Committee/EveryoneVotes.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index dfb184b34a..7189f9f7f1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -22,7 +22,7 @@ module Ouroboros.Consensus.Committee.EveryoneVotes , numActiveVoters ) where -import Cardano.Ledger.BaseTypes (HasZero (..), NonZero, Nonce) +import Cardano.Ledger.BaseTypes (HasZero (..), NonZero) import Cardano.Ledger.BaseTypes.NonZero (NonZero (..), nonZero) import Control.Exception (assert) import Control.Monad.Zip (MonadZip (..)) @@ -82,14 +82,10 @@ instance candidateSeats :: !(Map PoolId SeatIndex) , -- Number of active voters (i.e., those with non-zero stake) numActiveVoters :: !NumPoolsWithPositiveStake - , -- Epoch nonce of the epoch where this committee selection takes place - epochNonce :: !Nonce } data VotingCommitteeInput crypto EveryoneVotes = EveryoneVotesVotingCommitteeInput - -- Epoch nonce for the epoch where this voting committee takes place - !Nonce -- Extended cumulative stake distribution of the potential voters !(ExtWFAStakeDistr (PublicKey crypto)) @@ -145,7 +141,6 @@ mkEveryoneVotesVotingCommittee :: (VotingCommittee crypto EveryoneVotes) mkEveryoneVotesVotingCommittee ( EveryoneVotesVotingCommitteeInput - nonce stakeDistr ) = do let accumVotersWithPositiveStake @@ -169,7 +164,6 @@ mkEveryoneVotesVotingCommittee { extWFAStakeDistr = stakeDistr , candidateSeats = seats , numActiveVoters = poolsWithPositiveStake - , epochNonce = nonce } -- | Check whether we should vote in a given election From 5b9c87a6cd702a3d1dd1d1454ba7b0f5a8eaa0d2 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 15:21:14 +0200 Subject: [PATCH 08/20] remove repetitive computation of numPoolsWithPositiveStake --- .../Consensus/Committee/EveryoneVotes.hs | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index 7189f9f7f1..003f51cc96 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -143,18 +143,9 @@ mkEveryoneVotesVotingCommittee ( EveryoneVotesVotingCommitteeInput stakeDistr ) = do - let accumVotersWithPositiveStake - numPoolsAcc - (seatIndex, (poolId, _, stake, _)) = - ( if isZero stake - then numPoolsAcc - else succ numPoolsAcc - , (poolId, seatIndex) - ) - - let (poolsWithPositiveStake, seats) = - bimap NumPoolsWithPositiveStake Map.fromList - . List.mapAccumL accumVotersWithPositiveStake 0 + let seats = + Map.fromList + . fmap (\(seatIndex, (poolId, _, _, _)) -> (poolId, seatIndex)) . Array.assocs . unExtWFAStakeDistr $ stakeDistr @@ -163,7 +154,7 @@ mkEveryoneVotesVotingCommittee EveryoneVotesVotingCommittee { extWFAStakeDistr = stakeDistr , candidateSeats = seats - , numActiveVoters = poolsWithPositiveStake + , numActiveVoters = numPoolsWithPositiveStake stakeDistr } -- | Check whether we should vote in a given election From 5d3a35f49de0a6388eaa4392e1ad0024d5537a55 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 15:22:48 +0200 Subject: [PATCH 09/20] Fix checkShouldVote for EveryoneVotes in the zero-stake case --- .../Ouroboros/Consensus/Committee/EveryoneVotes.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index 003f51cc96..2821d4e4ca 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -174,9 +174,9 @@ implCheckShouldVote committee ourId _ourPrivateKey _electionId getCandidateInSeat seatIndex (extWFAStakeDistr committee) case nonZero ourStake of Nothing -> - Left (PoolHasNoStake seatIndex) + Right Nothing Just nonZeroOurStake -> - pure $ + Right $ Just $ EveryoneVotesMember seatIndex From 0b46c3e77cbaabce5ce0ed3815e0c5104feb109f Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 15:26:48 +0200 Subject: [PATCH 10/20] Add doc on LS module header --- .../ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs index 27394af7ab..ddd6116299 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs @@ -5,6 +5,9 @@ {-# LANGUAGE TypeFamilies #-} -- | Local sortition used by non-persistent members of the voting committee +-- Implements the @LS@ component of the wFA^LS scheme from the Fait-Accompli +-- Committee Selection paper (https://eprint.iacr.org/2023/1273.pdf, §2.3). +-- See also https://github.com/input-output-hk/ouroboros-leios/blob/c5658913221a7f58063bc4f82efaec0900e53dab/post-cip/weighted-fait-accompli.pdf module Ouroboros.Consensus.Committee.LS ( -- * Local sortition check LocalSortitionNumSeats (..) From 7013c56ef06bc0f2a3c2fd6e4b5346a0299a2aba Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 15:44:03 +0200 Subject: [PATCH 11/20] Improve guards and comments in LS Co-authored-by: Copilot --- .../Ouroboros/Consensus/Committee/LS.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs index ddd6116299..70d914d13d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs @@ -54,8 +54,13 @@ localSortitionNumSeats -- NOTE: this check also exists to prevent division by zero below. | totalNonPersistentStake <= 0 = LocalSortitionNumSeats 0 -- This voter has no stake (but some others do) => it does not get any seat. - -- NOTE: this is an optimization to avoid the expensive computation below. + -- NOTE: this check avoids the expensive computation below and also + -- prevent division by zero in computing "orders" | voterStake <= 0 = LocalSortitionNumSeats 0 + -- If the voter has stake close to zero, the conversion from 'Rational' to + -- 'FixedPoint' for 'lambda' might underflow to zero, which would cause the + -- "orders" computation below to divide by zero. + | lambda <= 0 = LocalSortitionNumSeats 0 -- This voter might be entitled to some seats => run the local sortition. | otherwise = LocalSortitionNumSeats (fromIntegral expectedSeats) where From acacbbc7f9e9b20bb5d34a82b32f3c0c996fe27b Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 15:48:08 +0200 Subject: [PATCH 12/20] fix typos --- .../ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs | 2 +- .../Ouroboros/Consensus/Committee/WFALS.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index 6dcb5461b5..9618750926 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -183,7 +183,7 @@ weightedFaitAccompliSplitSeats extWFAStakeDistr totalSeats (LedgerStake voterStake) cumulativeStake --- | Evaluate whether a voter with its give stake and relatile position in the +-- | Evaluate whether a voter with the given stake and relative position in the -- stake distribution can be granted a persistent seat in the voting committee. isAbovePersistentSeatThreshold :: -- | Total committee size (persistent + non-persistent) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 4ccdcaff95..0cbc7d3dd1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -157,7 +157,7 @@ instance MissingPoolId PoolId | -- Voter claims to be a persistent member of the committee, but it's not NotAPersistentMember SeatIndex - | -- Voter claims to be a non-persistent member of the committe, but it's not + | -- Voter claims to be a non-persistent member of the committee, but it's not NotANonPersistentMember SeatIndex | -- VRF evaluation for local sortition failed (e.g. due to invalid proof) LocalSortitionError String @@ -403,7 +403,7 @@ implVerifyVote committee = \case -- | Compute the voting power of an eligible committee member -- --- NOTE: theres is a subtle difference between the "Ledger stake" and the "Vote +-- NOTE: there is a subtle difference between the "Ledger stake" and the "Vote -- weight" of a given voter. On one hand, the ledger stake is the stake as -- reflected directly by the ledger stake distribution under consideration. On -- the other hand, the "Vote" weight refers to the voting power of that voter, From e40135164186392232e6ce2582aa3bec6be48fb8 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 15:49:37 +0200 Subject: [PATCH 13/20] Improve doc on cumulative stake w.r.t. potential tiebreakers --- .../ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index 9618750926..4d70bdd4d7 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -192,7 +192,8 @@ isAbovePersistentSeatThreshold :: SeatIndex -> -- | Current voter stake LedgerStake -> - -- | Cumulated stake of voters with smaller or equal stake than the current one + -- | Cumulated stake of voters with smaller stake, or equal stake but smaller + -- tiebreaker than the current one Cumulative LedgerStake -> -- | Whether the current voter has a persistent seat or not Bool From 76cff08bc17a3ab868619ac385847a6611d3249d Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 16:17:57 +0200 Subject: [PATCH 14/20] Add fair tiebreaker implementation in WFA Co-authored-by: Copilot --- .../Ouroboros/Consensus/Committee/WFA.hs | 45 ++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index 4d70bdd4d7..49d8dc9f7d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -21,11 +21,22 @@ module Ouroboros.Consensus.Committee.WFA , mkExtWFAStakeDistr , getCandidateInSeat , seatIndexWithinBounds + , wFATiebreakerWithEpochNonce ) where +-- DSIGN/BLS imports are needed for the 'WFATiebreaker' using epoch nonce. +-- If we move away from BLS in the future of Peras/Leios, we might want to +-- revisit the implementation of the tiebreaker to use a different hash function. +import Cardano.Crypto.DSIGN (BLS12381MinSigDSIGN, DSIGNAlgorithm (SigDSIGN)) +import qualified Cardano.Crypto.Hash as Hash +import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce, Nonce)) +import Cardano.Ledger.Binary (runByteBuilder) +import Cardano.Ledger.Core (HASH, Hash, KeyHash (unKeyHash)) import Control.Exception (assert) import Data.Array (Array, Ix, listArray) import qualified Data.Array as Array +import qualified Data.ByteString.Builder.Extra as BS +import Data.Function (on) import qualified Data.List as List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -35,6 +46,7 @@ import Ouroboros.Consensus.Committee.Types , LedgerStake (..) , PoolId , TargetCommitteeSize (..) + , unPoolId ) -- * Weighted Fait-Accompli committee selection scheme @@ -255,7 +267,8 @@ newtype NumPoolsWithPositiveStake -- One possible implementation of this tiebreaker is to sort the pools with the -- same stake according to the hash of the epoch nonce and the pool ID. This way -- the tiebreaker would be deterministic and resilient to manipulation since an --- adversary would not be able to predict the epoch nonce in advance. +-- adversary would not be able to predict the epoch nonce in advance +-- (see 'wFATiebreakerWithEpochNonce' below). newtype WFATiebreaker = WFATiebreaker { unWFATiebreaker :: PoolId -> PoolId -> Ordering @@ -263,6 +276,36 @@ newtype WFATiebreaker -- tiebreaker for voters with the same stake. } +-- | Fair weighted Fait-Accompli tiebreaker. +-- +-- For this, we throw the current epoch nonce into the mix to avoid giving an +-- adversary an edge to manipulate the tiebreaking in their favor, as they +-- cannot predict the epoch nonce in advance. +-- +-- NOTE: this implementation uses BLS-based hashing, but could be replaced by +-- any other cryptographic hash function with similar properties. +wFATiebreakerWithEpochNonce :: Nonce -> WFATiebreaker +wFATiebreakerWithEpochNonce epochNonce = + WFATiebreaker (compare `on` hashWithNonce) + where + hashWithNonce :: PoolId -> Hash HASH (SigDSIGN BLS12381MinSigDSIGN) + hashWithNonce poolId = + Hash.castHash + . Hash.hashWith id + . runByteBuilder (32 + 32) + $ epochNonceBytes <> poolIdBytes + where + epochNonceBytes = + case epochNonce of + NeutralNonce -> mempty + Nonce h -> BS.byteStringCopy (Hash.hashToBytes h) + poolIdBytes = + BS.byteStringCopy + . Hash.hashToBytes + . unKeyHash + . unPoolId + $ poolId + -- | Extended cumulative stake distribution. -- -- Stake distribution in descending order with precomputed right-cumulative From c1d197dd48dd9577738321cd086055410bbac7f5 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 16:19:52 +0200 Subject: [PATCH 15/20] Clean-up imports in WFALS and EveryoneVotes --- .../Ouroboros/Consensus/Committee/EveryoneVotes.hs | 2 -- .../ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index 2821d4e4ca..f8ae184da3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -22,14 +22,12 @@ module Ouroboros.Consensus.Committee.EveryoneVotes , numActiveVoters ) where -import Cardano.Ledger.BaseTypes (HasZero (..), NonZero) import Cardano.Ledger.BaseTypes.NonZero (NonZero (..), nonZero) import Control.Exception (assert) import Control.Monad.Zip (MonadZip (..)) import qualified Data.Array as Array import Data.Bifunctor (Bifunctor (..)) import Data.Containers.NonEmpty (HasNonEmpty (..)) -import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 0cbc7d3dd1..a8a367dcc4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -52,13 +52,13 @@ import Control.Monad.Zip (MonadZip (..)) import qualified Data.Array as Array import Data.Bifunctor (Bifunctor (..)) import Data.Containers.NonEmpty (HasNonEmpty (..)) -import Data.Data (Proxy (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.NonEmpty as NEMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) , VotesWithSameTarget From a7a8baca31f4b68d76b667f3d3a465d1d058251e Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 16:31:44 +0200 Subject: [PATCH 16/20] Add comment on accum stake (right to left) --- .../ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index 49d8dc9f7d..e40dee37dd 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -387,6 +387,8 @@ mkExtWFAStakeDistr tiebreaker pools cumulativeStakeAndPools ((_totalStake, numPoolsWithPositiveStakeAcc), cumulativeStakeAndPools) = + -- Accum right-to-left so seat 0's cumulative = total stake + -- and the last seat's cumulative = its own stake. List.mapAccumR accumStakeAndCountPoolsWithPositiveStake ( Cumulative (LedgerStake 0) From 553d13e735f3af87d4535d101466f4b8d2ec8187 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Mon, 27 Apr 2026 16:53:45 +0200 Subject: [PATCH 17/20] merge partial getCandidateInSeat and predicate seatIndexWithinBounds into total getCandidateIfSeatWithinBounds Co-authored-by: Copilot --- .../Consensus/Committee/EveryoneVotes.hs | 42 +++---- .../Ouroboros/Consensus/Committee/WFA.hs | 29 ++--- .../Ouroboros/Consensus/Committee/WFALS.hs | 106 +++++++++--------- 3 files changed, 84 insertions(+), 93 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index f8ae184da3..2bd27dc404 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -23,7 +23,6 @@ module Ouroboros.Consensus.Committee.EveryoneVotes ) where import Cardano.Ledger.BaseTypes.NonZero (NonZero (..), nonZero) -import Control.Exception (assert) import Control.Monad.Zip (MonadZip (..)) import qualified Data.Array as Array import Data.Bifunctor (Bifunctor (..)) @@ -59,8 +58,7 @@ import Ouroboros.Consensus.Committee.WFA , NumPoolsWithPositiveStake (..) , SeatIndex , WFAError - , getCandidateInSeat - , seatIndexWithinBounds + , getCandidateIfSeatWithinBounds ) -- | Tag for a simple voting committee where pools with positive stake can vote. @@ -167,18 +165,22 @@ implCheckShouldVote :: (Maybe (EligibilityWitness crypto EveryoneVotes)) implCheckShouldVote committee ourId _ourPrivateKey _electionId | Just seatIndex <- Map.lookup ourId (candidateSeats committee) = - assert (seatIndexWithinBounds seatIndex (extWFAStakeDistr committee)) $ do - let (_, _, ourStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) - case nonZero ourStake of - Nothing -> - Right Nothing - Just nonZeroOurStake -> - Right $ - Just $ - EveryoneVotesMember - seatIndex - nonZeroOurStake + case getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) of + Nothing -> + -- This should not happen: the seat index comes from the committee's + -- own map, so it should always be within bounds. + error $ + "implCheckShouldVote: seat index " ++ show seatIndex ++ " is out of bounds for the committee" + Just (_, _, ourStake, _) -> + case nonZero ourStake of + Nothing -> + Right Nothing + Just nonZeroOurStake -> + Right $ + Just $ + EveryoneVotesMember + seatIndex + nonZeroOurStake | otherwise = Left (MissingPoolId ourId) @@ -212,9 +214,8 @@ implVerifyVote :: (EligibilityWitness crypto EveryoneVotes) implVerifyVote committee = \case EveryoneVotesVote seatIndex electionId candidate sig - | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) -> do - let (_, voterPublicKey, voterStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) -> do let voterVerificationKey = getVoteVerificationKey (Proxy @crypto) voterPublicKey bimap InvalidVoteSignature id $ do @@ -301,9 +302,8 @@ implVerifyCert committee = \case (members, voteVerificationKeys) <- fmap munzip . flip traverse (NESet.toAscList voters) $ \case seatIndex - | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) -> do - let (_, voterPublicKey, voterStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) -> do let voterVerificationKey = getVoteVerificationKey (Proxy @crypto) voterPublicKey case nonZero voterStake of diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index e40dee37dd..03795db70b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -19,8 +19,7 @@ module Ouroboros.Consensus.Committee.WFA , WFATiebreaker (..) , ExtWFAStakeDistr (..) , mkExtWFAStakeDistr - , getCandidateInSeat - , seatIndexWithinBounds + , getCandidateIfSeatWithinBounds , wFATiebreakerWithEpochNonce ) where @@ -426,24 +425,18 @@ mkExtWFAStakeDistr tiebreaker pools ) ) --- | Retrieve the candidate information associated to a given seat index. --- --- PRECONDITION: the seat index must be within bounds in the stake distribution -getCandidateInSeat :: - SeatIndex -> - ExtWFAStakeDistr a -> - (PoolId, a, LedgerStake, Cumulative LedgerStake) -getCandidateInSeat seatIndex distr = - (Array.!) (unExtWFAStakeDistr distr) seatIndex - --- | Check that a seat index is within bounds in a stake distribution -seatIndexWithinBounds :: +-- | Retrieve the candidate information associated to a given seat index, if the +-- seat index is within bounds in the stake distribution. +getCandidateIfSeatWithinBounds :: SeatIndex -> ExtWFAStakeDistr a -> - Bool -seatIndexWithinBounds seatIndex distr = - unSeatIndex seatIndex >= unSeatIndex lowerBound - && unSeatIndex seatIndex <= unSeatIndex upperBound + Maybe (PoolId, a, LedgerStake, Cumulative LedgerStake) +getCandidateIfSeatWithinBounds seatIndex distr + | unSeatIndex seatIndex >= unSeatIndex lowerBound + , unSeatIndex seatIndex <= unSeatIndex upperBound = + Just $ (Array.!) (unExtWFAStakeDistr distr) seatIndex + | otherwise = + Nothing where (lowerBound, upperBound) = Array.bounds (unExtWFAStakeDistr distr) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index a8a367dcc4..3af3c0e765 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -46,7 +46,6 @@ module Ouroboros.Consensus.Committee.WFALS ) where import Cardano.Ledger.BaseTypes (NonZero (..), Nonce, nonZero) -import Control.Exception (assert) import Control.Monad (void) import Control.Monad.Zip (MonadZip (..)) import qualified Data.Array as Array @@ -96,8 +95,7 @@ import Ouroboros.Consensus.Committee.WFA , TotalNonPersistentStake (..) , TotalPersistentStake , WFAError - , getCandidateInSeat - , seatIndexWithinBounds + , getCandidateIfSeatWithinBounds , weightedFaitAccompliSplitSeats ) @@ -266,47 +264,51 @@ implCheckShouldVote :: (Maybe (EligibilityWitness crypto WFALS)) implCheckShouldVote committee ourId ourPrivateKey electionId | Just seatIndex <- Map.lookup ourId (candidateSeats committee) = - assert (seatIndexWithinBounds seatIndex (extWFAStakeDistr committee)) $ do - let (_, _, ourStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) - let ourVRFSigningKey = - getVRFSigningKey (Proxy @crypto) ourPrivateKey - case isPersistentMember seatIndex committee of - True -> do - pure $ - Just $ - WFALSPersistentMember - seatIndex - ourStake - False -> do - let vrfContext = - VRFSignContext ourVRFSigningKey - vrfOutput <- - bimap InvalidVoteSignature id $ do - evalVRF - vrfContext - ( mkVRFElectionInput - @crypto - (epochNonce committee) - electionId - ) - let numSeats = - localSortitionNumSeats - (nonPersistentCommitteeSize committee) - (totalNonPersistentStake committee) + case getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) of + Nothing -> + -- This should not happen: the seat index comes from the committee's + -- own map, so it should always be within bounds. + error $ + "implCheckShouldVote: seat index " ++ show seatIndex ++ " is out of bounds for the committee" + Just (_, _, ourStake, _) -> do + let ourVRFSigningKey = + getVRFSigningKey (Proxy @crypto) ourPrivateKey + case isPersistentMember seatIndex committee of + True -> do + pure $ + Just $ + WFALSPersistentMember + seatIndex ourStake - (normalizeVRFOutput vrfOutput) - case nonZero numSeats of - Nothing -> - pure Nothing - Just nonZeroNumSeats -> - pure $ - Just $ - WFALSNonPersistentMember - seatIndex + False -> do + let vrfContext = + VRFSignContext ourVRFSigningKey + vrfOutput <- + bimap InvalidVoteSignature id $ do + evalVRF + vrfContext + ( mkVRFElectionInput + @crypto + (epochNonce committee) + electionId + ) + let numSeats = + localSortitionNumSeats + (nonPersistentCommitteeSize committee) + (totalNonPersistentStake committee) ourStake - vrfOutput - nonZeroNumSeats + (normalizeVRFOutput vrfOutput) + case nonZero numSeats of + Nothing -> + pure Nothing + Just nonZeroNumSeats -> + pure $ + Just $ + WFALSNonPersistentMember + seatIndex + ourStake + vrfOutput + nonZeroNumSeats | otherwise = Left (MissingPoolId ourId) @@ -344,10 +346,9 @@ implVerifyVote :: (EligibilityWitness crypto WFALS) implVerifyVote committee = \case WFALSPersistentVote seatIndex electionId candidate sig - | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) , isPersistentMember seatIndex committee -> do - let (_, voterPublicKey, voterStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) let voterVerificationKey = getVoteVerificationKey (Proxy @crypto) voterPublicKey checkVoteSignature voterVerificationKey electionId candidate sig @@ -358,10 +359,9 @@ implVerifyVote committee = \case | otherwise -> do Left (NotAPersistentMember seatIndex) WFALSNonPersistentVote seatIndex electionId message vrfOutput sig - | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) , not (isPersistentMember seatIndex committee) -> do - let (_, voterPublicKey, voterStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) let voterVoteVerificationKey = getVoteVerificationKey (Proxy @crypto) voterPublicKey bimap InvalidVoteSignature id $ do @@ -505,10 +505,9 @@ implVerifyCert committee = \case fmap nonEmptyUnzip3 . flip traverse (NEMap.toAscList voters) $ \case -- Persistent voter (seatIndex, Nothing) - | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) , isPersistentMember seatIndex committee -> do - let (_, voterPublicKey, voterStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) let voterVoteVerificationKey = getVoteVerificationKey (Proxy @crypto) voterPublicKey pure @@ -522,10 +521,9 @@ implVerifyCert committee = \case Left (NotAPersistentMember seatIndex) -- Non-persistent voter (seatIndex, Just vrfOutput) - | seatIndexWithinBounds seatIndex (extWFAStakeDistr committee) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) , not (isPersistentMember seatIndex committee) -> do - let (_, voterPublicKey, voterStake, _) = - getCandidateInSeat seatIndex (extWFAStakeDistr committee) let voterVoteVerificationKey = getVoteVerificationKey (Proxy @crypto) voterPublicKey let voterVRFVerificationKey = From 4fc545d0f55544ef2d458dc4c9600661722463f3 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 28 Apr 2026 10:05:17 +0200 Subject: [PATCH 18/20] Consistent comment on export list of Committee.{WFALS,EveryoneVotes} --- .../Ouroboros/Consensus/Committee/EveryoneVotes.hs | 2 +- .../ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index 2bd27dc404..364600510c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -10,7 +10,7 @@ module Ouroboros.Consensus.Committee.EveryoneVotes ( -- * Voting committee interface EveryoneVotes - , VotingCommittee -- opaque + , VotingCommittee -- VotingCommittee internals are not exported , VotingCommitteeInput (..) , VotingCommitteeError (..) , EligibilityWitness (..) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 3af3c0e765..98d964a7dc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -30,7 +30,7 @@ module Ouroboros.Consensus.Committee.WFALS ( -- * Voting committee interface WFALS - , VotingCommittee -- opaque, only the metrics below are exported + , VotingCommittee -- VotingCommittee internals are not exported , VotingCommitteeInput (..) , VotingCommitteeError (..) , EligibilityWitness (..) From d1c49c3a7ae02538c2d9b51f4b60d8a9c161dc4d Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 28 Apr 2026 10:26:01 +0200 Subject: [PATCH 19/20] Change the error kind from `InvalidVoteSignature` to `CryptoError` when evalVRF fails in checkShouldVote and remove redundant LocalSortitionError (in favor of InvalidVoterEligibilityProof) Co-authored-by: Copilot --- .../Ouroboros/Consensus/Committee/WFALS.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 98d964a7dc..49ae96189a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -157,8 +157,6 @@ instance NotAPersistentMember SeatIndex | -- Voter claims to be a non-persistent member of the committee, but it's not NotANonPersistentMember SeatIndex - | -- VRF evaluation for local sortition failed (e.g. due to invalid proof) - LocalSortitionError String | -- The VRF evaluation returned zero non-persistent seats ZeroNonPersistentSeats SeatIndex | -- The vote signature is invalid @@ -284,7 +282,10 @@ implCheckShouldVote committee ourId ourPrivateKey electionId let vrfContext = VRFSignContext ourVRFSigningKey vrfOutput <- - bimap InvalidVoteSignature id $ do + -- Here we are using evalVRF to compute our own VRF output, so + -- if that fails, it means something went wrong with the crypto + -- process + bimap CryptoError id $ do evalVRF vrfContext ( mkVRFElectionInput From cfd0884b0a895614437b2ba52b5f95a6c97106f4 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Tue, 28 Apr 2026 11:37:07 +0200 Subject: [PATCH 20/20] Change `VotesWithSameTarget` to `VotesNoDupNonEmptySameTarget` to ensure all invariants holds in `forgeCert` Co-authored-by: Copilot --- .../Ouroboros/Consensus/Committee/Class.hs | 95 +++++++++++++------ .../Consensus/Committee/EveryoneVotes.hs | 14 ++- .../Ouroboros/Consensus/Committee/Types.hs | 9 ++ .../Ouroboros/Consensus/Committee/WFA.hs | 11 +-- .../Ouroboros/Consensus/Committee/WFALS.hs | 14 ++- 5 files changed, 93 insertions(+), 50 deletions(-) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs index 5ec07a3cf2..c547042044 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,25 +10,26 @@ module Ouroboros.Consensus.Committee.Class CryptoSupportsVotingCommittee (..) -- * Votes with same target - , VotesWithSameTarget + , VotesNoDupNonEmptySameTarget , getElectionIdFromVotes , getVoteCandidateFromVotes , getRawVotes - , VotesWithSameTargetError (..) - , ensureSameTarget + , VotesNoDupNonEmptySameTargetError (..) + , ensureNoDupNonEmptySameTarget ) where import Data.Containers.NonEmpty (HasNonEmpty (..)) import Data.Either (partitionEithers) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Set as Set import Ouroboros.Consensus.Committee.Crypto ( CryptoSupportsVoteSigning , ElectionId , PrivateKey , VoteCandidate ) -import Ouroboros.Consensus.Committee.Types (PoolId, VoteWeight) +import Ouroboros.Consensus.Committee.Types (PoolId, SeatIndex, VoteWeight) -- * Voting committee interface @@ -102,7 +104,7 @@ class -- | Forge a certificate attesting the winner of a given election forgeCert :: - VotesWithSameTarget crypto committee -> + VotesNoDupNonEmptySameTarget crypto committee SeatIndex -> Either (VotingCommitteeError crypto committee) (Cert crypto committee) @@ -117,74 +119,105 @@ class -- * Votes with same target --- | Collection of votes all targeting the same election and candidate -data VotesWithSameTarget crypto committee - = VotesWithSameTarget +-- | Non-empty collection of votes all targeting the same election and candidate +-- with unique voter IDs. +data VotesNoDupNonEmptySameTarget crypto committee voterId + = VotesNoDupNonEmptySameTarget (ElectionId crypto) (VoteCandidate crypto) (NE [Vote crypto committee]) -- | Get the election identifier targeted by a collection of votes getElectionIdFromVotes :: - VotesWithSameTarget crypto committee -> + VotesNoDupNonEmptySameTarget crypto committee voterId -> ElectionId crypto -getElectionIdFromVotes (VotesWithSameTarget electionId _ _) = +getElectionIdFromVotes (VotesNoDupNonEmptySameTarget electionId _ _) = electionId -- | Get the vote candidate targeted by a collection of votes getVoteCandidateFromVotes :: - VotesWithSameTarget crypto committee -> + VotesNoDupNonEmptySameTarget crypto committee voterId -> VoteCandidate crypto -getVoteCandidateFromVotes (VotesWithSameTarget _ candidate _) = +getVoteCandidateFromVotes (VotesNoDupNonEmptySameTarget _ candidate _) = candidate -- | Get the raw votes from a collection of votes with the same target. -- -- NOTE: this returns votes in ascending seat index order. getRawVotes :: - VotesWithSameTarget crypto committee -> + VotesNoDupNonEmptySameTarget crypto committee voterId -> NE [Vote crypto committee] -getRawVotes (VotesWithSameTarget _ _ votes) = +getRawVotes (VotesNoDupNonEmptySameTarget _ _ votes) = votes --- | Errors when votes do not all target the same election and candidate -data VotesWithSameTargetError crypto committee +-- | Errors when votes do not respect the requirements to be grouped together to +-- eventually forge a certificate. +data VotesNoDupNonEmptySameTargetError crypto committee voterId = EmptyVotes | TargetMismatch -- First vote and the rest of the votes that match its target (NE [Vote crypto committee]) -- Votes that do not match the target of the first vote (NE [Vote crypto committee]) + | DuplicateVoter voterId --- | Check that a list of votes all target the same election and candidate -ensureSameTarget :: +-- | Check: +-- + that a list of votes is non-empty, +-- + that all votes target the same election and candidate, +-- + and that no two votes come from the same voter. +ensureNoDupNonEmptySameTarget :: ( Eq (ElectionId crypto) , Eq (VoteCandidate crypto) + , Ord voterId ) => - (Vote crypto committee -> (ElectionId crypto, VoteCandidate crypto)) -> + (Vote crypto committee -> (ElectionId crypto, VoteCandidate crypto, voterId)) -> [Vote crypto committee] -> Either - (VotesWithSameTargetError crypto committee) - (VotesWithSameTarget crypto committee) -ensureSameTarget getTarget = \case + (VotesNoDupNonEmptySameTargetError crypto committee voterId) + (VotesNoDupNonEmptySameTarget crypto committee voterId) +ensureNoDupNonEmptySameTarget getVoteInfo = \case [] -> Left EmptyVotes (firstVote : nextVotes) -> do case partitionEithers (fmap matchesTarget nextVotes) of - ([], matchingVotes) -> - Right $ - VotesWithSameTarget - electionId - candidate - (firstVote :| matchingVotes) + ([], matchingVotes) -> do + let allVotes = firstVote :| matchingVotes + case findDuplicate (\v -> let (_, _, vid) = getVoteInfo v in vid) allVotes of + Just dup -> Left (DuplicateVoter dup) + Nothing -> + Right $ + VotesNoDupNonEmptySameTarget + electionId + candidate + allVotes (firstMismatchingVote : nextMismatchingVotes, matchingVotes) -> Left $ TargetMismatch (firstVote :| matchingVotes) (firstMismatchingVote :| nextMismatchingVotes) where - target@(electionId, candidate) = - getTarget firstVote + (electionId, candidate, _) = + getVoteInfo firstVote + target = (electionId, candidate) matchesTarget v' - | getTarget v' /= target = Left v' + | let (eid, vc, _) = getVoteInfo v' + , (eid, vc) /= target = + Left v' | otherwise = Right v' + +-- | Find the first duplicate voter ID in a non-empty list of votes. +findDuplicate :: + Ord voterId => + (vote -> voterId) -> + NonEmpty vote -> + Maybe voterId +findDuplicate getId = + go Set.empty + where + go !seen (v :| rest) = + let vid = getId v + in if Set.member vid seen + then Just vid + else case rest of + [] -> Nothing + (next : more) -> go (Set.insert vid seen) (next :| more) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs index 364600510c..31d1fd38f8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -35,7 +35,7 @@ import Data.Set (Set) import qualified Data.Set.NonEmpty as NESet import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) - , VotesWithSameTarget + , VotesNoDupNonEmptySameTarget , getElectionIdFromVotes , getRawVotes , getVoteCandidateFromVotes @@ -252,11 +252,15 @@ implEligiblePartyVoteWeight _committee member = implForgeCert :: forall crypto. CryptoSupportsAggregateVoteSigning crypto => - VotesWithSameTarget crypto EveryoneVotes -> + VotesNoDupNonEmptySameTarget crypto EveryoneVotes SeatIndex -> Either (VotingCommitteeError crypto EveryoneVotes) (Cert crypto EveryoneVotes) implForgeCert votes = do + -- Voter ID uniqueness is guaranteed by the VotesNoDupNonEmptySameTarget smart + -- constructor, so fromAscList preserves length. + let voterSet = NESet.fromAscList sortedVoters + aggSig <- bimap CryptoError id $ do aggregateVoteSignatures @@ -266,10 +270,10 @@ implForgeCert votes = do EveryoneVotesCert (getElectionIdFromVotes votes) (getVoteCandidateFromVotes votes) - (NESet.fromList voters) + voterSet aggSig where - (voters, voteSignatures) = + (sortedVoters, voteSignatures) = munzip $ flip fmap votesInAscendingSeatIndexOrder $ \case EveryoneVotesVote seatIndex _ _ sig -> ( seatIndex @@ -277,7 +281,7 @@ implForgeCert votes = do ) -- Make sure we have votes in ascending seat index order, which is something - -- 'VotesWithSameTarget' cannot guarantee by itself, since seat indices are + -- 'VotesNoDupNonEmptySameTarget' cannot guarantee by itself, since seat indices are -- an implementation detail of this voting committee scheme. votesInAscendingSeatIndexOrder = flip NonEmpty.sortWith (getRawVotes votes) $ \case diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs index 1dcbffaa0a..22c6c12e25 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Types.hs @@ -8,10 +8,12 @@ module Ouroboros.Consensus.Committee.Types , VoteWeight (..) , TargetCommitteeSize (..) , Cumulative (..) + , SeatIndex (..) ) where import Cardano.Ledger.BaseTypes (HasZero) import Cardano.Ledger.Core (KeyHash, KeyRole (..)) +import Data.Array (Ix) import Data.Word (Word64) -- | Identifier of a given voter in the committee selection scheme @@ -44,3 +46,10 @@ newtype Cumulative a = Cumulative { unCumulative :: a } deriving (Show, Eq) + +-- | Seat index in the voting committee +newtype SeatIndex + = SeatIndex + { unSeatIndex :: Word64 + } + deriving (Show, Eq, Ord, Enum, Ix) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs index 03795db70b..9ba262759c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Deterministic portion of the Weighted Fait-Accompli committee selection scheme module Ouroboros.Consensus.Committee.WFA @@ -32,7 +31,7 @@ import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce, Nonce)) import Cardano.Ledger.Binary (runByteBuilder) import Cardano.Ledger.Core (HASH, Hash, KeyHash (unKeyHash)) import Control.Exception (assert) -import Data.Array (Array, Ix, listArray) +import Data.Array (Array, listArray) import qualified Data.Array as Array import qualified Data.ByteString.Builder.Extra as BS import Data.Function (on) @@ -44,6 +43,7 @@ import Ouroboros.Consensus.Committee.Types ( Cumulative (..) , LedgerStake (..) , PoolId + , SeatIndex (..) , TargetCommitteeSize (..) , unPoolId ) @@ -227,13 +227,6 @@ isAbovePersistentSeatThreshold -- * Cumulative stake distributions --- | Seat index in the voting committee -newtype SeatIndex - = SeatIndex - { unSeatIndex :: Word64 - } - deriving (Show, Eq, Ord, Enum, Ix) - -- | Number of pools with positive stake in the underlying stake distribution newtype NumPoolsWithPositiveStake = NumPoolsWithPositiveStake diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs index 49ae96189a..478f4c53ee 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -60,7 +60,7 @@ import Data.Maybe (catMaybes) import Data.Proxy (Proxy (..)) import Ouroboros.Consensus.Committee.Class ( CryptoSupportsVotingCommittee (..) - , VotesWithSameTarget + , VotesNoDupNonEmptySameTarget , getElectionIdFromVotes , getRawVotes , getVoteCandidateFromVotes @@ -446,11 +446,15 @@ implEligiblePartyVoteWeight committee = \case implForgeCert :: forall crypto. CryptoSupportsAggregateVoteSigning crypto => - VotesWithSameTarget crypto WFALS -> + VotesNoDupNonEmptySameTarget crypto WFALS SeatIndex -> Either (VotingCommitteeError crypto WFALS) (Cert crypto WFALS) implForgeCert votes = do + -- Voter ID uniqueness is guaranteed by the VotesNoDupNonEmptySameTarget smart + -- constructor, so fromAscList preserves length. + let voterMap = NEMap.fromAscList sortedVoters + aggSig <- bimap CryptoError id $ aggregateVoteSignatures @@ -460,10 +464,10 @@ implForgeCert votes = do WFALSCert (getElectionIdFromVotes votes) (getVoteCandidateFromVotes votes) - (NEMap.fromAscList voters) + voterMap aggSig where - (voters, voteSignatures) = + (sortedVoters, voteSignatures) = munzip $ flip fmap votesInAscendingSeatIndexOrder $ \case WFALSPersistentVote seatIndex _ _ sig -> ( (seatIndex, Nothing) @@ -475,7 +479,7 @@ implForgeCert votes = do ) -- Make sure we have votes in ascending seat index order, which is something - -- 'VotesWithSameTarget' cannot guarantee by itself, since seat indices are + -- 'VotesNoDupNonEmptySameTarget' cannot guarantee by itself, since seat indices are -- an implementation detail of this voting committee scheme. votesInAscendingSeatIndexOrder = flip NonEmpty.sortWith (getRawVotes votes) $ \case