{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Test properties for the EveryoneVotes implementation using TestCrypto.
module Test.Consensus.Committee.EveryoneVotes.Tests (tests) where

import Cardano.Ledger.BaseTypes
import Data.Function (on)
import Data.List (intercalate, sortOn)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Ouroboros.Consensus.Committee.Class
  ( CryptoSupportsVotingCommittee (..)
  , ensureUniqueVotesWithSameTarget
  )
import Ouroboros.Consensus.Committee.Crypto
  ( PrivateKey
  , PublicKey
  )
import Ouroboros.Consensus.Committee.EveryoneVotes
  ( EligibilityWitness (..)
  , EveryoneVotes
  , Vote (..)
  , VotingCommitteeInput (..)
  , candidateSeats
  , numActiveVoters
  )
import Ouroboros.Consensus.Committee.Types
  ( LedgerStake (..)
  , PoolId
  )
import Ouroboros.Consensus.Committee.WFA
  ( NumPoolsWithPositiveStake (..)
  , SeatIndex (..)
  , mkExtWFAStakeDistr
  )
import Test.Consensus.Committee.TestCrypto (TestCrypto)
import qualified Test.Consensus.Committee.TestCrypto as TestCrypto
import Test.Consensus.Committee.Utils
  ( eqWithShowCmp
  , genPools
  , genPositiveStake
  , mkBucket
  , onError
  , tabulateNumPools
  , tabulatePoolStake
  , unfairWFATiebreaker
  )
import Test.QuickCheck
  ( Gen
  , Property
  , Testable (..)
  , choose
  , counterexample
  , elements
  , forAll
  , forAllShow
  , frequency
  , tabulate
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Test.Util.TestEnv (adjustQuickCheckTests)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"Implementation tests using TestCrypto"
    [ (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
          [Char]
"prop_checkShouldVote_verifyVote"
          Property
prop_checkShouldVote_verifyVote
    , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
          [Char]
"prop_fakeVotesDontVerify"
          Property
prop_fakeVotesDontVerify
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
        [Char]
"prop_forgeCert_verifyCert"
        Property
prop_forgeCert_verifyCert
    ]

-- | If a pool is entitled to vote in a given committee, the vote it casts
-- should be verifiable under the same committee.
prop_checkShouldVote_verifyVote :: Property
prop_checkShouldVote_verifyVote :: Property
prop_checkShouldVote_verifyVote =
  Gen
  (Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake))
-> (Map
      PoolId
      ((PrivateKey SIGN, PrivateKey VRF),
       (PublicKey SIGN, PublicKey VRF), LedgerStake)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int
-> Gen
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF))
-> Gen
     (Map
        PoolId
        ((PrivateKey SIGN, PrivateKey VRF),
         (PublicKey SIGN, PublicKey VRF), LedgerStake))
forall privateKey publicKey.
Int
-> Gen (privateKey, publicKey)
-> Gen (Map PoolId (privateKey, publicKey, LedgerStake))
genPools Int
1000 Gen
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF))
Gen (PrivateKey TestCrypto, PublicKey TestCrypto)
TestCrypto.genKeyPair) ((Map
    PoolId
    ((PrivateKey SIGN, PrivateKey VRF),
     (PublicKey SIGN, PublicKey VRF), LedgerStake)
  -> Property)
 -> Property)
-> (Map
      PoolId
      ((PrivateKey SIGN, PrivateKey VRF),
       (PublicKey SIGN, PublicKey VRF), LedgerStake)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools ->
    Gen (PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
-> ((PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
-> Gen (PoolId, PrivateKey TestCrypto, LedgerStake)
samplePool Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools) (((PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
  -> Property)
 -> Property)
-> ((PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(PoolId
poolId, (PrivateKey SIGN, PrivateKey VRF)
poolPrivateKey, LedgerStake
poolStake) ->
      Gen Word64 -> (Word64 -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Word64
Gen (ElectionId TestCrypto)
TestCrypto.genElectionId ((Word64 -> Property) -> Property)
-> (Word64 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Word64
electionId ->
        Gen ByteString -> (ByteString -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ByteString
Gen (VoteCandidate TestCrypto)
TestCrypto.genVoteCandidate ((ByteString -> Property) -> Property)
-> (ByteString -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ByteString
candidate -> do
          let extWFAStakeDistr :: ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
extWFAStakeDistr =
                WFATiebreaker
-> Map PoolId (LedgerStake, (PublicKey SIGN, PublicKey VRF))
-> Either
     WFAError (ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
forall a.
WFATiebreaker
-> Map PoolId (LedgerStake, a)
-> Either WFAError (ExtWFAStakeDistr a)
mkExtWFAStakeDistr
                  WFATiebreaker
unfairWFATiebreaker
                  ((((PrivateKey SIGN, PrivateKey VRF),
  (PublicKey SIGN, PublicKey VRF), LedgerStake)
 -> (LedgerStake, (PublicKey SIGN, PublicKey VRF)))
-> Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Map PoolId (LedgerStake, (PublicKey SIGN, PublicKey VRF))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\((PrivateKey SIGN, PrivateKey VRF)
_, (PublicKey SIGN, PublicKey VRF)
pubKey, LedgerStake
stake) -> (LedgerStake
stake, (PublicKey SIGN, PublicKey VRF)
pubKey)) Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools)
                  Either WFAError (ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
-> (WFAError -> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
-> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
forall err a. Either err a -> (err -> a) -> a
`onError` \WFAError
err ->
                    [Char] -> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkExtWFAStakeDistr failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> WFAError -> [Char]
forall a. Show a => a -> [Char]
show WFAError
err)
          let committee :: VotingCommittee TestCrypto EveryoneVotes
committee =
                forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommitteeInput crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (VotingCommittee crypto committee)
mkVotingCommittee @TestCrypto @EveryoneVotes
                  ( ExtWFAStakeDistr (PublicKey TestCrypto)
-> VotingCommitteeInput TestCrypto EveryoneVotes
forall crypto.
ExtWFAStakeDistr (PublicKey crypto)
-> VotingCommitteeInput crypto EveryoneVotes
EveryoneVotesVotingCommitteeInput
                      ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
ExtWFAStakeDistr (PublicKey TestCrypto)
extWFAStakeDistr
                  )
                  Either
  (VotingCommitteeError TestCrypto EveryoneVotes)
  (VotingCommittee TestCrypto EveryoneVotes)
-> (VotingCommitteeError TestCrypto EveryoneVotes
    -> VotingCommittee TestCrypto EveryoneVotes)
-> VotingCommittee TestCrypto EveryoneVotes
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto EveryoneVotes
err ->
                    [Char] -> VotingCommittee TestCrypto EveryoneVotes
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkVotingCommittee failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
          let shouldVote :: Maybe (EligibilityWitness TestCrypto EveryoneVotes)
shouldVote =
                VotingCommittee TestCrypto EveryoneVotes
-> PoolId
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> Either
     (VotingCommitteeError TestCrypto EveryoneVotes)
     (Maybe (EligibilityWitness TestCrypto EveryoneVotes))
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> PoolId
-> PrivateKey crypto
-> ElectionId crypto
-> Either
     (VotingCommitteeError crypto committee)
     (Maybe (EligibilityWitness crypto committee))
checkShouldVote
                  VotingCommittee TestCrypto EveryoneVotes
committee
                  PoolId
poolId
                  (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
poolPrivateKey
                  Word64
ElectionId TestCrypto
electionId
                  Either
  (VotingCommitteeError TestCrypto EveryoneVotes)
  (Maybe (EligibilityWitness TestCrypto EveryoneVotes))
-> (VotingCommitteeError TestCrypto EveryoneVotes
    -> Maybe (EligibilityWitness TestCrypto EveryoneVotes))
-> Maybe (EligibilityWitness TestCrypto EveryoneVotes)
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto EveryoneVotes
err ->
                    [Char] -> Maybe (EligibilityWitness TestCrypto EveryoneVotes)
forall a. HasCallStack => [Char] -> a
error ([Char]
"checkShouldVote failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
          Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Property -> Property
forall privateKey publicKey.
Map PoolId (privateKey, publicKey, LedgerStake)
-> Property -> Property
tabulateNumPools Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools
            (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerStake -> Property -> Property
tabulatePoolStake LedgerStake
poolStake
            (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (EligibilityWitness TestCrypto EveryoneVotes)
-> Property -> Property
tabulateShouldVote Maybe (EligibilityWitness TestCrypto EveryoneVotes)
shouldVote
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case Maybe (EligibilityWitness TestCrypto EveryoneVotes)
shouldVote of
              -- The pool is eligible to vote => cast a vote using their
              -- eligibility witness and make sure it verifies under the
              -- same voting committee.
              Just EligibilityWitness TestCrypto EveryoneVotes
witness -> do
                let vote :: Vote TestCrypto EveryoneVotes
vote =
                      EligibilityWitness TestCrypto EveryoneVotes
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> VoteCandidate TestCrypto
-> Vote TestCrypto EveryoneVotes
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
EligibilityWitness crypto committee
-> PrivateKey crypto
-> ElectionId crypto
-> VoteCandidate crypto
-> Vote crypto committee
forgeVote
                        EligibilityWitness TestCrypto EveryoneVotes
witness
                        (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
poolPrivateKey
                        Word64
ElectionId TestCrypto
electionId
                        ByteString
VoteCandidate TestCrypto
candidate
                case VotingCommittee TestCrypto EveryoneVotes
-> Vote TestCrypto EveryoneVotes
-> Either
     (VotingCommitteeError TestCrypto EveryoneVotes)
     (EligibilityWitness TestCrypto EveryoneVotes)
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> Vote crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (EligibilityWitness crypto committee)
verifyVote VotingCommittee TestCrypto EveryoneVotes
committee Vote TestCrypto EveryoneVotes
vote of
                  Left VotingCommitteeError TestCrypto EveryoneVotes
err ->
                    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
                      ([Char]
"vote verification failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
                      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                  Right EligibilityWitness TestCrypto EveryoneVotes
witness' ->
                    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
                      [Char]
"vote verification mismatch"
                      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ (EligibilityWitness TestCrypto EveryoneVotes -> [Char])
-> (EligibilityWitness TestCrypto EveryoneVotes
    -> EligibilityWitness TestCrypto EveryoneVotes -> Bool)
-> EligibilityWitness TestCrypto EveryoneVotes
-> EligibilityWitness TestCrypto EveryoneVotes
-> Property
forall a. (a -> [Char]) -> (a -> a -> Bool) -> a -> a -> Property
eqWithShowCmp
                        EligibilityWitness TestCrypto EveryoneVotes -> [Char]
showWitness
                        EligibilityWitness TestCrypto EveryoneVotes
-> EligibilityWitness TestCrypto EveryoneVotes -> Bool
cmpWitness
                        EligibilityWitness TestCrypto EveryoneVotes
witness
                        EligibilityWitness TestCrypto EveryoneVotes
witness'
              -- The pool is not eligible to vote => do nothing
              Maybe (EligibilityWitness TestCrypto EveryoneVotes)
Nothing ->
                Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True

-- | Votes cast using fake eligibility witnesses should fail verification.
prop_fakeVotesDontVerify :: Property
prop_fakeVotesDontVerify :: Property
prop_fakeVotesDontVerify =
  Gen
  (Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake))
-> (Map
      PoolId
      ((PrivateKey SIGN, PrivateKey VRF),
       (PublicKey SIGN, PublicKey VRF), LedgerStake)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int
-> Gen
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF))
-> Gen
     (Map
        PoolId
        ((PrivateKey SIGN, PrivateKey VRF),
         (PublicKey SIGN, PublicKey VRF), LedgerStake))
forall privateKey publicKey.
Int
-> Gen (privateKey, publicKey)
-> Gen (Map PoolId (privateKey, publicKey, LedgerStake))
genPools Int
1000 Gen
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF))
Gen (PrivateKey TestCrypto, PublicKey TestCrypto)
TestCrypto.genKeyPair) ((Map
    PoolId
    ((PrivateKey SIGN, PrivateKey VRF),
     (PublicKey SIGN, PublicKey VRF), LedgerStake)
  -> Property)
 -> Property)
-> (Map
      PoolId
      ((PrivateKey SIGN, PrivateKey VRF),
       (PublicKey SIGN, PublicKey VRF), LedgerStake)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools -> do
    Gen (PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
-> ((PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
-> Gen (PoolId, PrivateKey TestCrypto, LedgerStake)
samplePool Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools) (((PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
  -> Property)
 -> Property)
-> ((PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(PoolId
_, (PrivateKey SIGN, PrivateKey VRF)
poolPrivateKey, LedgerStake
poolStake) ->
      Gen Word64 -> (Word64 -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Word64
Gen (ElectionId TestCrypto)
TestCrypto.genElectionId ((Word64 -> Property) -> Property)
-> (Word64 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Word64
electionId ->
        Gen ByteString -> (ByteString -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ByteString
Gen (VoteCandidate TestCrypto)
TestCrypto.genVoteCandidate ((ByteString -> Property) -> Property)
-> (ByteString -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ByteString
candidate -> do
          let extWFAStakeDistr :: ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
extWFAStakeDistr =
                WFATiebreaker
-> Map PoolId (LedgerStake, (PublicKey SIGN, PublicKey VRF))
-> Either
     WFAError (ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
forall a.
WFATiebreaker
-> Map PoolId (LedgerStake, a)
-> Either WFAError (ExtWFAStakeDistr a)
mkExtWFAStakeDistr
                  WFATiebreaker
unfairWFATiebreaker
                  ((((PrivateKey SIGN, PrivateKey VRF),
  (PublicKey SIGN, PublicKey VRF), LedgerStake)
 -> (LedgerStake, (PublicKey SIGN, PublicKey VRF)))
-> Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Map PoolId (LedgerStake, (PublicKey SIGN, PublicKey VRF))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\((PrivateKey SIGN, PrivateKey VRF)
_, (PublicKey SIGN, PublicKey VRF)
pubKey, LedgerStake
stake) -> (LedgerStake
stake, (PublicKey SIGN, PublicKey VRF)
pubKey)) Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools)
                  Either WFAError (ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
-> (WFAError -> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
-> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
forall err a. Either err a -> (err -> a) -> a
`onError` \WFAError
err ->
                    [Char] -> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkExtWFAStakeDistr failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> WFAError -> [Char]
forall a. Show a => a -> [Char]
show WFAError
err)
          let committee :: VotingCommittee TestCrypto EveryoneVotes
committee =
                forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommitteeInput crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (VotingCommittee crypto committee)
mkVotingCommittee @TestCrypto @EveryoneVotes
                  ( ExtWFAStakeDistr (PublicKey TestCrypto)
-> VotingCommitteeInput TestCrypto EveryoneVotes
forall crypto.
ExtWFAStakeDistr (PublicKey crypto)
-> VotingCommitteeInput crypto EveryoneVotes
EveryoneVotesVotingCommitteeInput
                      ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
ExtWFAStakeDistr (PublicKey TestCrypto)
extWFAStakeDistr
                  )
                  Either
  (VotingCommitteeError TestCrypto EveryoneVotes)
  (VotingCommittee TestCrypto EveryoneVotes)
-> (VotingCommitteeError TestCrypto EveryoneVotes
    -> VotingCommittee TestCrypto EveryoneVotes)
-> VotingCommittee TestCrypto EveryoneVotes
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto EveryoneVotes
err ->
                    [Char] -> VotingCommittee TestCrypto EveryoneVotes
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkVotingCommittee failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
          Gen
  (FakeEligibilityWitnessType,
   EligibilityWitness TestCrypto EveryoneVotes)
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto EveryoneVotes)
    -> [Char])
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto EveryoneVotes)
    -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [Char]) -> (a -> prop) -> Property
forAllShow
            ( VotingCommittee TestCrypto EveryoneVotes
-> LedgerStake
-> Gen
     (FakeEligibilityWitnessType,
      EligibilityWitness TestCrypto EveryoneVotes)
genFakeEligibilityWitness
                VotingCommittee TestCrypto EveryoneVotes
committee
                LedgerStake
poolStake
            )
            (EligibilityWitness TestCrypto EveryoneVotes -> [Char]
showWitness (EligibilityWitness TestCrypto EveryoneVotes -> [Char])
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto EveryoneVotes)
    -> EligibilityWitness TestCrypto EveryoneVotes)
-> (FakeEligibilityWitnessType,
    EligibilityWitness TestCrypto EveryoneVotes)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FakeEligibilityWitnessType,
 EligibilityWitness TestCrypto EveryoneVotes)
-> EligibilityWitness TestCrypto EveryoneVotes
forall a b. (a, b) -> b
snd)
            (((FakeEligibilityWitnessType,
   EligibilityWitness TestCrypto EveryoneVotes)
  -> Property)
 -> Property)
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto EveryoneVotes)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(FakeEligibilityWitnessType
fakeWitnessType, EligibilityWitness TestCrypto EveryoneVotes
fakeWitness) -> do
              let fakeVote :: Vote TestCrypto EveryoneVotes
fakeVote =
                    EligibilityWitness TestCrypto EveryoneVotes
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> VoteCandidate TestCrypto
-> Vote TestCrypto EveryoneVotes
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
EligibilityWitness crypto committee
-> PrivateKey crypto
-> ElectionId crypto
-> VoteCandidate crypto
-> Vote crypto committee
forgeVote
                      EligibilityWitness TestCrypto EveryoneVotes
fakeWitness
                      (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
poolPrivateKey
                      Word64
ElectionId TestCrypto
electionId
                      ByteString
VoteCandidate TestCrypto
candidate
              Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Property -> Property
forall privateKey publicKey.
Map PoolId (privateKey, publicKey, LedgerStake)
-> Property -> Property
tabulateNumPools Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools
                (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FakeEligibilityWitnessType -> Property -> Property
tabulateFakeWitnessType FakeEligibilityWitnessType
fakeWitnessType
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case VotingCommittee TestCrypto EveryoneVotes
-> Vote TestCrypto EveryoneVotes
-> Either
     (VotingCommitteeError TestCrypto EveryoneVotes)
     (EligibilityWitness TestCrypto EveryoneVotes)
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> Vote crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (EligibilityWitness crypto committee)
verifyVote VotingCommittee TestCrypto EveryoneVotes
committee Vote TestCrypto EveryoneVotes
fakeVote of
                  Left VotingCommitteeError TestCrypto EveryoneVotes
_ ->
                    Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                  Right EligibilityWitness TestCrypto EveryoneVotes
_ ->
                    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
                      ( [[Char]] -> [Char]
unlines
                          [ [Char]
"vote verification succeeded but should have failed:"
                          , [Char]
"fake witness type: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FakeEligibilityWitnessType -> [Char]
forall a. Show a => a -> [Char]
show FakeEligibilityWitnessType
fakeWitnessType
                          ]
                      )
                      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False

-- | If we forge a certificate from many votes with the same target, verifying
-- it should succeed and return the eligibility witnesses.
prop_forgeCert_verifyCert :: Property
prop_forgeCert_verifyCert :: Property
prop_forgeCert_verifyCert =
  Gen
  (Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake))
-> (Map
      PoolId
      ((PrivateKey SIGN, PrivateKey VRF),
       (PublicKey SIGN, PublicKey VRF), LedgerStake)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Int
-> Gen
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF))
-> Gen
     (Map
        PoolId
        ((PrivateKey SIGN, PrivateKey VRF),
         (PublicKey SIGN, PublicKey VRF), LedgerStake))
forall privateKey publicKey.
Int
-> Gen (privateKey, publicKey)
-> Gen (Map PoolId (privateKey, publicKey, LedgerStake))
genPools Int
1000 Gen
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF))
Gen (PrivateKey TestCrypto, PublicKey TestCrypto)
TestCrypto.genKeyPair) ((Map
    PoolId
    ((PrivateKey SIGN, PrivateKey VRF),
     (PublicKey SIGN, PublicKey VRF), LedgerStake)
  -> Property)
 -> Property)
-> (Map
      PoolId
      ((PrivateKey SIGN, PrivateKey VRF),
       (PublicKey SIGN, PublicKey VRF), LedgerStake)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools ->
    Gen Word64 -> (Word64 -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Word64
Gen (ElectionId TestCrypto)
TestCrypto.genElectionId ((Word64 -> Property) -> Property)
-> (Word64 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Word64
electionId ->
      Gen ByteString -> (ByteString -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ByteString
Gen (VoteCandidate TestCrypto)
TestCrypto.genVoteCandidate ((ByteString -> Property) -> Property)
-> (ByteString -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ByteString
candidate -> do
        let extWFAStakeDistr :: ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
extWFAStakeDistr =
              WFATiebreaker
-> Map PoolId (LedgerStake, (PublicKey SIGN, PublicKey VRF))
-> Either
     WFAError (ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
forall a.
WFATiebreaker
-> Map PoolId (LedgerStake, a)
-> Either WFAError (ExtWFAStakeDistr a)
mkExtWFAStakeDistr
                WFATiebreaker
unfairWFATiebreaker
                ((((PrivateKey SIGN, PrivateKey VRF),
  (PublicKey SIGN, PublicKey VRF), LedgerStake)
 -> (LedgerStake, (PublicKey SIGN, PublicKey VRF)))
-> Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Map PoolId (LedgerStake, (PublicKey SIGN, PublicKey VRF))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\((PrivateKey SIGN, PrivateKey VRF)
_, (PublicKey SIGN, PublicKey VRF)
pubKey, LedgerStake
stake) -> (LedgerStake
stake, (PublicKey SIGN, PublicKey VRF)
pubKey)) Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools)
                Either WFAError (ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
-> (WFAError -> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF))
-> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
forall err a. Either err a -> (err -> a) -> a
`onError` \WFAError
err ->
                  [Char] -> ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkExtWFAStakeDistr failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> WFAError -> [Char]
forall a. Show a => a -> [Char]
show WFAError
err)
        let committee :: VotingCommittee TestCrypto EveryoneVotes
committee =
              forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommitteeInput crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (VotingCommittee crypto committee)
mkVotingCommittee @TestCrypto @EveryoneVotes
                ( ExtWFAStakeDistr (PublicKey TestCrypto)
-> VotingCommitteeInput TestCrypto EveryoneVotes
forall crypto.
ExtWFAStakeDistr (PublicKey crypto)
-> VotingCommitteeInput crypto EveryoneVotes
EveryoneVotesVotingCommitteeInput
                    ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
ExtWFAStakeDistr (PublicKey TestCrypto)
extWFAStakeDistr
                )
                Either
  (VotingCommitteeError TestCrypto EveryoneVotes)
  (VotingCommittee TestCrypto EveryoneVotes)
-> (VotingCommitteeError TestCrypto EveryoneVotes
    -> VotingCommittee TestCrypto EveryoneVotes)
-> VotingCommittee TestCrypto EveryoneVotes
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto EveryoneVotes
err ->
                  [Char] -> VotingCommittee TestCrypto EveryoneVotes
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkVotingCommittee failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
        -- Forge votes from all eligible pools
        let ([Vote TestCrypto EveryoneVotes]
votes, [EligibilityWitness TestCrypto EveryoneVotes]
originalWitnesses) =
              [(Vote TestCrypto EveryoneVotes,
  EligibilityWitness TestCrypto EveryoneVotes)]
-> ([Vote TestCrypto EveryoneVotes],
    [EligibilityWitness TestCrypto EveryoneVotes])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Vote TestCrypto EveryoneVotes,
   EligibilityWitness TestCrypto EveryoneVotes)]
 -> ([Vote TestCrypto EveryoneVotes],
     [EligibilityWitness TestCrypto EveryoneVotes]))
-> [(Vote TestCrypto EveryoneVotes,
     EligibilityWitness TestCrypto EveryoneVotes)]
-> ([Vote TestCrypto EveryoneVotes],
    [EligibilityWitness TestCrypto EveryoneVotes])
forall a b. (a -> b) -> a -> b
$
                [ ( EligibilityWitness TestCrypto EveryoneVotes
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> VoteCandidate TestCrypto
-> Vote TestCrypto EveryoneVotes
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
EligibilityWitness crypto committee
-> PrivateKey crypto
-> ElectionId crypto
-> VoteCandidate crypto
-> Vote crypto committee
forgeVote EligibilityWitness TestCrypto EveryoneVotes
witness (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
privateKey Word64
ElectionId TestCrypto
electionId ByteString
VoteCandidate TestCrypto
candidate
                  , EligibilityWitness TestCrypto EveryoneVotes
witness
                  )
                | (PoolId
poolId, ((PrivateKey SIGN, PrivateKey VRF)
privateKey, (PublicKey SIGN, PublicKey VRF)
_, LedgerStake
_)) <- Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> [(PoolId,
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools
                , Just EligibilityWitness TestCrypto EveryoneVotes
witness <-
                    [ VotingCommittee TestCrypto EveryoneVotes
-> PoolId
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> Either
     (VotingCommitteeError TestCrypto EveryoneVotes)
     (Maybe (EligibilityWitness TestCrypto EveryoneVotes))
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> PoolId
-> PrivateKey crypto
-> ElectionId crypto
-> Either
     (VotingCommitteeError crypto committee)
     (Maybe (EligibilityWitness crypto committee))
checkShouldVote
                        VotingCommittee TestCrypto EveryoneVotes
committee
                        PoolId
poolId
                        (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
privateKey
                        Word64
ElectionId TestCrypto
electionId
                        Either
  (VotingCommitteeError TestCrypto EveryoneVotes)
  (Maybe (EligibilityWitness TestCrypto EveryoneVotes))
-> (VotingCommitteeError TestCrypto EveryoneVotes
    -> Maybe (EligibilityWitness TestCrypto EveryoneVotes))
-> Maybe (EligibilityWitness TestCrypto EveryoneVotes)
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto EveryoneVotes
err ->
                          [Char] -> Maybe (EligibilityWitness TestCrypto EveryoneVotes)
forall a. HasCallStack => [Char] -> a
error ([Char]
"checkShouldVote failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
                    ]
                ]
        Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Property -> Property
forall privateKey publicKey.
Map PoolId (privateKey, publicKey, LedgerStake)
-> Property -> Property
tabulateNumPools Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
pools
          (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Property -> Property
tabulateNumVotes ([Vote TestCrypto EveryoneVotes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Vote TestCrypto EveryoneVotes]
votes)
          (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case [Vote TestCrypto EveryoneVotes]
votes of
            [] ->
              -- No eligible voters, nothing to test
              Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
            Vote TestCrypto EveryoneVotes
firstVote : [Vote TestCrypto EveryoneVotes]
nextVotes -> do
              let uniqueVotesWithSameTarget :: UniqueVotesWithSameTarget TestCrypto EveryoneVotes
uniqueVotesWithSameTarget =
                    (Vote TestCrypto EveryoneVotes
 -> (ElectionId TestCrypto, VoteCandidate TestCrypto))
-> (Vote TestCrypto EveryoneVotes
    -> Vote TestCrypto EveryoneVotes -> Ordering)
-> NE [Vote TestCrypto EveryoneVotes]
-> Either
     (UniqueVotesWithSameTargetError (Vote TestCrypto EveryoneVotes))
     (UniqueVotesWithSameTarget TestCrypto EveryoneVotes)
forall crypto committee.
(Eq (ElectionId crypto), Eq (VoteCandidate crypto)) =>
(Vote crypto committee
 -> (ElectionId crypto, VoteCandidate crypto))
-> (Vote crypto committee -> Vote crypto committee -> Ordering)
-> NE [Vote crypto committee]
-> Either
     (UniqueVotesWithSameTargetError (Vote crypto committee))
     (UniqueVotesWithSameTarget crypto committee)
ensureUniqueVotesWithSameTarget
                      ( \case
                          EveryoneVotesVote SeatIndex
_ ElectionId TestCrypto
eid VoteCandidate TestCrypto
cand VoteSignature TestCrypto
_ -> (ElectionId TestCrypto
eid, VoteCandidate TestCrypto
cand)
                      )
                      ( SeatIndex -> SeatIndex -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SeatIndex -> SeatIndex -> Ordering)
-> (Vote TestCrypto EveryoneVotes -> SeatIndex)
-> Vote TestCrypto EveryoneVotes
-> Vote TestCrypto EveryoneVotes
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \case
                          EveryoneVotesVote SeatIndex
seatIndex ElectionId TestCrypto
_ VoteCandidate TestCrypto
_ VoteSignature TestCrypto
_ -> SeatIndex
seatIndex
                      )
                      (Vote TestCrypto EveryoneVotes
firstVote Vote TestCrypto EveryoneVotes
-> [Vote TestCrypto EveryoneVotes]
-> NonEmpty (Vote TestCrypto EveryoneVotes)
forall a. a -> [a] -> NonEmpty a
:| [Vote TestCrypto EveryoneVotes]
nextVotes)
                      Either
  (UniqueVotesWithSameTargetError (Vote TestCrypto EveryoneVotes))
  (UniqueVotesWithSameTarget TestCrypto EveryoneVotes)
-> (UniqueVotesWithSameTargetError (Vote TestCrypto EveryoneVotes)
    -> UniqueVotesWithSameTarget TestCrypto EveryoneVotes)
-> UniqueVotesWithSameTarget TestCrypto EveryoneVotes
forall err a. Either err a -> (err -> a) -> a
`onError` \UniqueVotesWithSameTargetError (Vote TestCrypto EveryoneVotes)
_ ->
                        [Char] -> UniqueVotesWithSameTarget TestCrypto EveryoneVotes
forall a. HasCallStack => [Char] -> a
error [Char]
"votes don't have the same target!"
              let cert :: Cert TestCrypto EveryoneVotes
cert =
                    UniqueVotesWithSameTarget TestCrypto EveryoneVotes
-> Either
     (VotingCommitteeError TestCrypto EveryoneVotes)
     (Cert TestCrypto EveryoneVotes)
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
UniqueVotesWithSameTarget crypto committee
-> Either
     (VotingCommitteeError crypto committee) (Cert crypto committee)
forgeCert UniqueVotesWithSameTarget TestCrypto EveryoneVotes
uniqueVotesWithSameTarget
                      Either
  (VotingCommitteeError TestCrypto EveryoneVotes)
  (Cert TestCrypto EveryoneVotes)
-> (VotingCommitteeError TestCrypto EveryoneVotes
    -> Cert TestCrypto EveryoneVotes)
-> Cert TestCrypto EveryoneVotes
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto EveryoneVotes
err ->
                        [Char] -> Cert TestCrypto EveryoneVotes
forall a. HasCallStack => [Char] -> a
error ([Char]
"forgeCert failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
              case VotingCommittee TestCrypto EveryoneVotes
-> Cert TestCrypto EveryoneVotes
-> Either
     (VotingCommitteeError TestCrypto EveryoneVotes)
     (NE [EligibilityWitness TestCrypto EveryoneVotes])
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> Cert crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (NE [EligibilityWitness crypto committee])
verifyCert VotingCommittee TestCrypto EveryoneVotes
committee Cert TestCrypto EveryoneVotes
cert of
                Left VotingCommitteeError TestCrypto EveryoneVotes
err ->
                  [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
                    ([Char]
"certificate verification failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto EveryoneVotes -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto EveryoneVotes
err)
                    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                Right NE [EligibilityWitness TestCrypto EveryoneVotes]
witnesses -> do
                  let witnessesFromCert :: [EligibilityWitness TestCrypto EveryoneVotes]
witnessesFromCert = NonEmpty (EligibilityWitness TestCrypto EveryoneVotes)
-> [EligibilityWitness TestCrypto EveryoneVotes]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (EligibilityWitness TestCrypto EveryoneVotes)
NE [EligibilityWitness TestCrypto EveryoneVotes]
witnesses
                  [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
                    ( [[Char]] -> [Char]
unlines
                        [ [Char]
"witnesses mismatch!"
                        , [Char]
"expected these " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([EligibilityWitness TestCrypto EveryoneVotes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EligibilityWitness TestCrypto EveryoneVotes]
originalWitnesses) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" witnesses:"
                        , [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ((EligibilityWitness TestCrypto EveryoneVotes -> [Char])
-> [EligibilityWitness TestCrypto EveryoneVotes] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EligibilityWitness TestCrypto EveryoneVotes -> [Char]
showWitness [EligibilityWitness TestCrypto EveryoneVotes]
originalWitnesses)
                        , [Char]
"but got these " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([EligibilityWitness TestCrypto EveryoneVotes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EligibilityWitness TestCrypto EveryoneVotes]
witnessesFromCert) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" witnesses:"
                        , [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ((EligibilityWitness TestCrypto EveryoneVotes -> [Char])
-> [EligibilityWitness TestCrypto EveryoneVotes] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EligibilityWitness TestCrypto EveryoneVotes -> [Char]
showWitness [EligibilityWitness TestCrypto EveryoneVotes]
witnessesFromCert)
                        ]
                    )
                    (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [EligibilityWitness TestCrypto EveryoneVotes]
-> [EligibilityWitness TestCrypto EveryoneVotes] -> Bool
cmpWitnesses [EligibilityWitness TestCrypto EveryoneVotes]
originalWitnesses [EligibilityWitness TestCrypto EveryoneVotes]
witnessesFromCert

-- * Generators

samplePool ::
  Map PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake) ->
  Gen (PoolId, PrivateKey TestCrypto, LedgerStake)
samplePool :: Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
-> Gen (PoolId, PrivateKey TestCrypto, LedgerStake)
samplePool Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools =
  [(PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)]
-> Gen (PoolId, (PrivateKey SIGN, PrivateKey VRF), LedgerStake)
forall a. HasCallStack => [a] -> Gen a
elements
    [ (PoolId
poolId, (PrivateKey SIGN, PrivateKey VRF)
privateKey, LedgerStake
ledgerStake)
    | (PoolId
poolId, ((PrivateKey SIGN, PrivateKey VRF)
privateKey, (PublicKey SIGN, PublicKey VRF)
_, LedgerStake
ledgerStake)) <- Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> [(PoolId,
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools
    ]

data FakeEligibilityWitnessType
  = PoolWithZeroStake
  | SeatIndexOutOfBounds
  deriving Int -> FakeEligibilityWitnessType -> [Char] -> [Char]
[FakeEligibilityWitnessType] -> [Char] -> [Char]
FakeEligibilityWitnessType -> [Char]
(Int -> FakeEligibilityWitnessType -> [Char] -> [Char])
-> (FakeEligibilityWitnessType -> [Char])
-> ([FakeEligibilityWitnessType] -> [Char] -> [Char])
-> Show FakeEligibilityWitnessType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FakeEligibilityWitnessType -> [Char] -> [Char]
showsPrec :: Int -> FakeEligibilityWitnessType -> [Char] -> [Char]
$cshow :: FakeEligibilityWitnessType -> [Char]
show :: FakeEligibilityWitnessType -> [Char]
$cshowList :: [FakeEligibilityWitnessType] -> [Char] -> [Char]
showList :: [FakeEligibilityWitnessType] -> [Char] -> [Char]
Show

-- | Generate a fake eligibility witness that would fail verification if used
-- to cast a vote.
--
-- This breaks the structure of a valid witness in two ways:
--  1. generating a witness for a pool with zero stake, or
--  2. generating a witness with a seat index outside of the valid range.
genFakeEligibilityWitness ::
  VotingCommittee TestCrypto EveryoneVotes ->
  LedgerStake ->
  Gen (FakeEligibilityWitnessType, EligibilityWitness TestCrypto EveryoneVotes)
genFakeEligibilityWitness :: VotingCommittee TestCrypto EveryoneVotes
-> LedgerStake
-> Gen
     (FakeEligibilityWitnessType,
      EligibilityWitness TestCrypto EveryoneVotes)
genFakeEligibilityWitness
  VotingCommittee TestCrypto EveryoneVotes
committee
  LedgerStake
poolStake = do
    [(Int,
  Gen
    (FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto EveryoneVotes))]
-> Gen
     (FakeEligibilityWitnessType,
      EligibilityWitness TestCrypto EveryoneVotes)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [
        ( if Word64
totalSeats Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
nonZeroStakeSeats then Int
1 else Int
0
        , Gen
  (FakeEligibilityWitnessType,
   EligibilityWitness TestCrypto EveryoneVotes)
genPoolWithZeroStakeWitness
        )
      ,
        ( Int
1
        , Gen
  (FakeEligibilityWitnessType,
   EligibilityWitness TestCrypto EveryoneVotes)
genSeatIndexOutOfBoundsWitness
        )
      ]
   where
    totalSeats :: Word64
totalSeats = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map PoolId SeatIndex -> Int
forall k a. Map k a -> Int
Map.size (VotingCommittee TestCrypto EveryoneVotes -> Map PoolId SeatIndex
forall crypto.
VotingCommittee crypto EveryoneVotes -> Map PoolId SeatIndex
candidateSeats VotingCommittee TestCrypto EveryoneVotes
committee))
    nonZeroStakeSeats :: Word64
nonZeroStakeSeats = NumPoolsWithPositiveStake -> Word64
unNumPoolsWithPositiveStake (VotingCommittee TestCrypto EveryoneVotes
-> NumPoolsWithPositiveStake
forall crypto.
VotingCommittee crypto EveryoneVotes -> NumPoolsWithPositiveStake
numActiveVoters VotingCommittee TestCrypto EveryoneVotes
committee)

    -- This witness points to a valid seat index but it fakes a non-zero stake
    -- for a pool that actually has zero stake (case 1).
    genPoolWithZeroStakeWitness :: Gen
  (FakeEligibilityWitnessType,
   EligibilityWitness TestCrypto EveryoneVotes)
genPoolWithZeroStakeWitness = do
      seatIndex <- Word64 -> SeatIndex
SeatIndex (Word64 -> SeatIndex) -> Gen Word64 -> Gen SeatIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
nonZeroStakeSeats, Word64
totalSeats Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
      ledgerStake <- genPositiveStake
      -- traceShow (">>>>>", nonZeroStakeSeats, totalSeats, seatIndex) $
      pure
        ( PoolWithZeroStake
        , EveryoneVotesMember
            seatIndex
            (unsafeNonZero ledgerStake)
        )

    -- This witness has a seat index that lies outside the valid range (case 2).
    genSeatIndexOutOfBoundsWitness :: Gen
  (FakeEligibilityWitnessType,
   EligibilityWitness TestCrypto EveryoneVotes)
genSeatIndexOutOfBoundsWitness = do
      seatIndex <- Word64 -> SeatIndex
SeatIndex (Word64 -> SeatIndex) -> Gen Word64 -> Gen SeatIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
totalSeats, Word64
totalSeats Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
100)
      pure
        ( SeatIndexOutOfBounds
        , EveryoneVotesMember
            seatIndex
            (unsafeNonZero poolStake)
        )

-- * Property helpers

showWitness ::
  EligibilityWitness TestCrypto EveryoneVotes ->
  String
showWitness :: EligibilityWitness TestCrypto EveryoneVotes -> [Char]
showWitness EligibilityWitness TestCrypto EveryoneVotes
witness =
  case EligibilityWitness TestCrypto EveryoneVotes
witness of
    EveryoneVotesMember SeatIndex
seatIndex NonZero LedgerStake
stake ->
      [Char]
"Member(SeatIndex="
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SeatIndex -> [Char]
forall a. Show a => a -> [Char]
show SeatIndex
seatIndex
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", Stake="
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Ratio Integer -> [Char]
forall a. Show a => a -> [Char]
show (LedgerStake -> Ratio Integer
unLedgerStake (NonZero LedgerStake -> LedgerStake
forall a. NonZero a -> a
unNonZero NonZero LedgerStake
stake))
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"

cmpWitness ::
  EligibilityWitness TestCrypto EveryoneVotes ->
  EligibilityWitness TestCrypto EveryoneVotes ->
  Bool
cmpWitness :: EligibilityWitness TestCrypto EveryoneVotes
-> EligibilityWitness TestCrypto EveryoneVotes -> Bool
cmpWitness EligibilityWitness TestCrypto EveryoneVotes
w1 EligibilityWitness TestCrypto EveryoneVotes
w2 =
  case (EligibilityWitness TestCrypto EveryoneVotes
w1, EligibilityWitness TestCrypto EveryoneVotes
w2) of
    ( EveryoneVotesMember SeatIndex
seatIndex1 NonZero LedgerStake
stake1
      , EveryoneVotesMember SeatIndex
seatIndex2 NonZero LedgerStake
stake2
      ) ->
        SeatIndex
seatIndex1 SeatIndex -> SeatIndex -> Bool
forall a. Eq a => a -> a -> Bool
== SeatIndex
seatIndex2
          Bool -> Bool -> Bool
&& NonZero LedgerStake
stake1 NonZero LedgerStake -> NonZero LedgerStake -> Bool
forall a. Eq a => a -> a -> Bool
== NonZero LedgerStake
stake2

cmpWitnesses ::
  [EligibilityWitness TestCrypto EveryoneVotes] ->
  [EligibilityWitness TestCrypto EveryoneVotes] ->
  Bool
cmpWitnesses :: [EligibilityWitness TestCrypto EveryoneVotes]
-> [EligibilityWitness TestCrypto EveryoneVotes] -> Bool
cmpWitnesses [EligibilityWitness TestCrypto EveryoneVotes]
ws1 [EligibilityWitness TestCrypto EveryoneVotes]
ws2 =
  [EligibilityWitness TestCrypto EveryoneVotes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EligibilityWitness TestCrypto EveryoneVotes]
ws1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [EligibilityWitness TestCrypto EveryoneVotes] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EligibilityWitness TestCrypto EveryoneVotes]
ws2
    Bool -> Bool -> Bool
&& ((EligibilityWitness TestCrypto EveryoneVotes,
  EligibilityWitness TestCrypto EveryoneVotes)
 -> Bool)
-> [(EligibilityWitness TestCrypto EveryoneVotes,
     EligibilityWitness TestCrypto EveryoneVotes)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
      ((EligibilityWitness TestCrypto EveryoneVotes
 -> EligibilityWitness TestCrypto EveryoneVotes -> Bool)
-> (EligibilityWitness TestCrypto EveryoneVotes,
    EligibilityWitness TestCrypto EveryoneVotes)
-> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry EligibilityWitness TestCrypto EveryoneVotes
-> EligibilityWitness TestCrypto EveryoneVotes -> Bool
cmpWitness)
      ([EligibilityWitness TestCrypto EveryoneVotes]
-> [EligibilityWitness TestCrypto EveryoneVotes]
-> [(EligibilityWitness TestCrypto EveryoneVotes,
     EligibilityWitness TestCrypto EveryoneVotes)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([EligibilityWitness TestCrypto EveryoneVotes]
-> [EligibilityWitness TestCrypto EveryoneVotes]
forall {crypto}.
[EligibilityWitness crypto EveryoneVotes]
-> [EligibilityWitness crypto EveryoneVotes]
sortBySeatIndex [EligibilityWitness TestCrypto EveryoneVotes]
ws1) ([EligibilityWitness TestCrypto EveryoneVotes]
-> [EligibilityWitness TestCrypto EveryoneVotes]
forall {crypto}.
[EligibilityWitness crypto EveryoneVotes]
-> [EligibilityWitness crypto EveryoneVotes]
sortBySeatIndex [EligibilityWitness TestCrypto EveryoneVotes]
ws2))
 where
  sortBySeatIndex :: [EligibilityWitness crypto EveryoneVotes]
-> [EligibilityWitness crypto EveryoneVotes]
sortBySeatIndex =
    (EligibilityWitness crypto EveryoneVotes -> SeatIndex)
-> [EligibilityWitness crypto EveryoneVotes]
-> [EligibilityWitness crypto EveryoneVotes]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((EligibilityWitness crypto EveryoneVotes -> SeatIndex)
 -> [EligibilityWitness crypto EveryoneVotes]
 -> [EligibilityWitness crypto EveryoneVotes])
-> (EligibilityWitness crypto EveryoneVotes -> SeatIndex)
-> [EligibilityWitness crypto EveryoneVotes]
-> [EligibilityWitness crypto EveryoneVotes]
forall a b. (a -> b) -> a -> b
$ \case
      EveryoneVotesMember SeatIndex
seatIndex NonZero LedgerStake
_ -> SeatIndex
seatIndex

-- * Tabulation helpers

tabulateShouldVote ::
  Maybe (EligibilityWitness TestCrypto EveryoneVotes) ->
  Property ->
  Property
tabulateShouldVote :: Maybe (EligibilityWitness TestCrypto EveryoneVotes)
-> Property -> Property
tabulateShouldVote Maybe (EligibilityWitness TestCrypto EveryoneVotes)
shouldVote =
  [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate
    [Char]
"Should vote"
    [ case Maybe (EligibilityWitness TestCrypto EveryoneVotes)
shouldVote of
        Maybe (EligibilityWitness TestCrypto EveryoneVotes)
Nothing ->
          [Char]
"NoVote"
        Just (EveryoneVotesMember SeatIndex
_ NonZero LedgerStake
_) ->
          [Char]
"Vote"
    ]

tabulateFakeWitnessType ::
  FakeEligibilityWitnessType ->
  Property ->
  Property
tabulateFakeWitnessType :: FakeEligibilityWitnessType -> Property -> Property
tabulateFakeWitnessType FakeEligibilityWitnessType
fakeWitnessType =
  [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate
    [Char]
"Fake witness type"
    [FakeEligibilityWitnessType -> [Char]
forall a. Show a => a -> [Char]
show FakeEligibilityWitnessType
fakeWitnessType]

tabulateNumVotes ::
  Int ->
  Property ->
  Property
tabulateNumVotes :: Int -> Property -> Property
tabulateNumVotes Int
numVotes =
  [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate
    [Char]
"Number of votes"
    [Integer -> Integer -> [Char]
mkBucket Integer
100 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numVotes)]