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. + + diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 230333d77e..de34af0443 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -118,7 +118,11 @@ 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 + Ouroboros.Consensus.Committee.WFALS Ouroboros.Consensus.Config Ouroboros.Consensus.Config.SecurityParam Ouroboros.Consensus.Config.SupportsNode @@ -351,6 +355,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/Class.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Class.hs index 6d656d14e5..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,8 +104,10 @@ class -- | Forge a certificate attesting the winner of a given election forgeCert :: - VotesWithSameTarget crypto committee -> - Cert crypto committee + VotesNoDupNonEmptySameTarget crypto committee SeatIndex -> + Either + (VotingCommitteeError crypto committee) + (Cert crypto committee) -- | Verify a certificate attesting the winner of a given election verifyCert :: @@ -115,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/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 () 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..31d1fd38f8 --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/EveryoneVotes.hs @@ -0,0 +1,340 @@ +{-# 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 -- VotingCommittee internals are not exported + , VotingCommitteeInput (..) + , VotingCommitteeError (..) + , EligibilityWitness (..) + , Vote (..) + , Cert (..) + + -- * Metrics about the voting committee composition + , candidateSeats + , numActiveVoters + ) where + +import Cardano.Ledger.BaseTypes.NonZero (NonZero (..), nonZero) +import Control.Monad.Zip (MonadZip (..)) +import qualified Data.Array as Array +import Data.Bifunctor (Bifunctor (..)) +import Data.Containers.NonEmpty (HasNonEmpty (..)) +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 (..) + , VotesNoDupNonEmptySameTarget + , 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 + , getCandidateIfSeatWithinBounds + ) + +-- | 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 + } + + data VotingCommitteeInput crypto EveryoneVotes + = EveryoneVotesVotingCommitteeInput + -- 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 + stakeDistr + ) = do + let seats = + Map.fromList + . fmap (\(seatIndex, (poolId, _, _, _)) -> (poolId, seatIndex)) + . Array.assocs + . unExtWFAStakeDistr + $ stakeDistr + + pure $ + EveryoneVotesVotingCommittee + { extWFAStakeDistr = stakeDistr + , candidateSeats = seats + , numActiveVoters = numPoolsWithPositiveStake stakeDistr + } + +-- | 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) = + 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) + +-- | 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 + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) -> do + 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 => + 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 + (Proxy @crypto) + voteSignatures + pure $ + EveryoneVotesCert + (getElectionIdFromVotes votes) + (getVoteCandidateFromVotes votes) + voterSet + aggSig + where + (sortedVoters, voteSignatures) = + munzip $ flip fmap votesInAscendingSeatIndexOrder $ \case + EveryoneVotesVote seatIndex _ _ sig -> + ( seatIndex + , sig + ) + + -- Make sure we have votes in ascending seat index order, which is something + -- 'VotesNoDupNonEmptySameTarget' 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 + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) -> do + 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 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..70d914d13d --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/LS.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# 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 (..) + , 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 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 + -- 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) 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 new file mode 100644 index 0000000000..9ba262759c --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFA.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | 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 + , getCandidateIfSeatWithinBounds + , 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, 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 +import Data.Word (Word64) +import Ouroboros.Consensus.Committee.Types + ( Cumulative (..) + , LedgerStake (..) + , PoolId + , SeatIndex (..) + , TargetCommitteeSize (..) + , unPoolId + ) + +-- * 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 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) + TargetCommitteeSize -> + -- | Current voter seat index + SeatIndex -> + -- | Current voter stake + LedgerStake -> + -- | 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 +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 + +-- | 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 +-- (see 'wFATiebreakerWithEpochNonce' below). +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. + } + +-- | 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 +-- 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) = + -- 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) + , 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, if the +-- seat index is within bounds in the stake distribution. +getCandidateIfSeatWithinBounds :: + SeatIndex -> + ExtWFAStakeDistr a -> + 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 new file mode 100644 index 0000000000..478f4c53ee --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/WFALS.hs @@ -0,0 +1,637 @@ +{-# 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 -- VotingCommittee internals are not 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.Monad (void) +import Control.Monad.Zip (MonadZip (..)) +import qualified Data.Array as Array +import Data.Bifunctor (Bifunctor (..)) +import Data.Containers.NonEmpty (HasNonEmpty (..)) +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 (..) + , VotesNoDupNonEmptySameTarget + , 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 + , getCandidateIfSeatWithinBounds + , 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 committee, but it's not + NotANonPersistentMember SeatIndex + | -- 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) = + 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 + False -> do + let vrfContext = + VRFSignContext ourVRFSigningKey + vrfOutput <- + -- 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 + @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 + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) + , isPersistentMember seatIndex committee -> do + 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 + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) + , not (isPersistentMember seatIndex committee) -> do + 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: 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, +-- 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 => + 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 + (Proxy @crypto) + voteSignatures + pure $ + WFALSCert + (getElectionIdFromVotes votes) + (getVoteCandidateFromVotes votes) + voterMap + aggSig + where + (sortedVoters, 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 + -- 'VotesNoDupNonEmptySameTarget' 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) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) + , isPersistentMember seatIndex committee -> do + let voterVoteVerificationKey = + getVoteVerificationKey (Proxy @crypto) voterPublicKey + pure + ( WFALSPersistentMember + seatIndex + voterStake + , voterVoteVerificationKey + , Nothing + ) + | otherwise -> + Left (NotAPersistentMember seatIndex) + -- Non-persistent voter + (seatIndex, Just vrfOutput) + | Just (_, voterPublicKey, voterStake, _) <- + getCandidateIfSeatWithinBounds seatIndex (extWFAStakeDistr committee) + , not (isPersistentMember seatIndex committee) -> do + 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