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

-- | Test properties for the weighted Fait-Accompli implementation using TestCrypto.
module Test.Consensus.Committee.WFALS.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 Data.Proxy (Proxy (..))
import Ouroboros.Consensus.Committee.Class
  ( CryptoSupportsVotingCommittee (..)
  , ensureUniqueVotesWithSameTarget
  )
import Ouroboros.Consensus.Committee.Crypto
  ( CryptoSupportsVRF (..)
  , ElectionId
  , PrivateKey
  , PublicKey
  , VRFPoolContext (..)
  , evalVRF
  , mkVRFElectionInput
  )
import Ouroboros.Consensus.Committee.LS (LocalSortitionNumSeats (..))
import qualified Ouroboros.Consensus.Committee.LS as LS
import Ouroboros.Consensus.Committee.Types
  ( LedgerStake (..)
  , PoolId
  , TargetCommitteeSize (..)
  )
import Ouroboros.Consensus.Committee.WFA
  ( NonPersistentCommitteeSize (..)
  , PersistentCommitteeSize (..)
  , SeatIndex (..)
  , mkExtWFAStakeDistr
  )
import Ouroboros.Consensus.Committee.WFALS
  ( EligibilityWitness (..)
  , Vote (..)
  , VotingCommitteeInput (..)
  , WFALS
  , nonPersistentCommitteeSize
  , persistentCommitteeSize
  , totalNonPersistentStake
  )
import Test.Consensus.Committee.TestCrypto (TestCrypto)
import qualified Test.Consensus.Committee.TestCrypto as TestCrypto
import Test.Consensus.Committee.Utils
  ( eqWithShowCmp
  , genEpochNonce
  , genPools
  , 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 TargetCommitteeSize
-> (TargetCommitteeSize -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
-> Gen TargetCommitteeSize
genTargetCommitteeSize Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools) ((TargetCommitteeSize -> Property) -> Property)
-> (TargetCommitteeSize -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TargetCommitteeSize
targetCommitteeSize ->
      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 Nonce -> (Nonce -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Nonce
genEpochNonce ((Nonce -> Property) -> Property)
-> (Nonce -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Nonce
epochNonce ->
          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 WFALS
committee =
                    forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommitteeInput crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (VotingCommittee crypto committee)
mkVotingCommittee @TestCrypto @WFALS
                      ( Nonce
-> TargetCommitteeSize
-> ExtWFAStakeDistr (PublicKey TestCrypto)
-> VotingCommitteeInput TestCrypto WFALS
forall crypto.
Nonce
-> TargetCommitteeSize
-> ExtWFAStakeDistr (PublicKey crypto)
-> VotingCommitteeInput crypto WFALS
WFALSVotingCommitteeInput
                          Nonce
epochNonce
                          TargetCommitteeSize
targetCommitteeSize
                          ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
ExtWFAStakeDistr (PublicKey TestCrypto)
extWFAStakeDistr
                      )
                      Either
  (VotingCommitteeError TestCrypto WFALS)
  (VotingCommittee TestCrypto WFALS)
-> (VotingCommitteeError TestCrypto WFALS
    -> VotingCommittee TestCrypto WFALS)
-> VotingCommittee TestCrypto WFALS
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto WFALS
err ->
                        [Char] -> VotingCommittee TestCrypto WFALS
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkVotingCommittee failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
err)
              let shouldVote :: Maybe (EligibilityWitness TestCrypto WFALS)
shouldVote =
                    VotingCommittee TestCrypto WFALS
-> PoolId
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> Either
     (VotingCommitteeError TestCrypto WFALS)
     (Maybe (EligibilityWitness TestCrypto WFALS))
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 WFALS
committee
                      PoolId
poolId
                      (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
poolPrivateKey
                      Word64
ElectionId TestCrypto
electionId
                      Either
  (VotingCommitteeError TestCrypto WFALS)
  (Maybe (EligibilityWitness TestCrypto WFALS))
-> (VotingCommitteeError TestCrypto WFALS
    -> Maybe (EligibilityWitness TestCrypto WFALS))
-> Maybe (EligibilityWitness TestCrypto WFALS)
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto WFALS
err ->
                        [Char] -> Maybe (EligibilityWitness TestCrypto WFALS)
forall a. HasCallStack => [Char] -> a
error ([Char]
"checkShouldVote failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
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
. TargetCommitteeSize -> Property -> Property
tabulateTargetCommitteeSize TargetCommitteeSize
targetCommitteeSize
                (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 WFALS) -> Property -> Property
tabulateShouldVote Maybe (EligibilityWitness TestCrypto WFALS)
shouldVote
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case Maybe (EligibilityWitness TestCrypto WFALS)
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 WFALS
witness -> do
                    let vote :: Vote TestCrypto WFALS
vote =
                          EligibilityWitness TestCrypto WFALS
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> VoteCandidate TestCrypto
-> Vote TestCrypto WFALS
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
EligibilityWitness crypto committee
-> PrivateKey crypto
-> ElectionId crypto
-> VoteCandidate crypto
-> Vote crypto committee
forgeVote
                            EligibilityWitness TestCrypto WFALS
witness
                            (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
poolPrivateKey
                            Word64
ElectionId TestCrypto
electionId
                            ByteString
VoteCandidate TestCrypto
candidate
                    case VotingCommittee TestCrypto WFALS
-> Vote TestCrypto WFALS
-> Either
     (VotingCommitteeError TestCrypto WFALS)
     (EligibilityWitness TestCrypto WFALS)
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> Vote crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (EligibilityWitness crypto committee)
verifyVote VotingCommittee TestCrypto WFALS
committee Vote TestCrypto WFALS
vote of
                      Left VotingCommitteeError TestCrypto WFALS
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 WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
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 WFALS
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 WFALS -> [Char])
-> (EligibilityWitness TestCrypto WFALS
    -> EligibilityWitness TestCrypto WFALS -> Bool)
-> EligibilityWitness TestCrypto WFALS
-> EligibilityWitness TestCrypto WFALS
-> Property
forall a. (a -> [Char]) -> (a -> a -> Bool) -> a -> a -> Property
eqWithShowCmp
                            EligibilityWitness TestCrypto WFALS -> [Char]
showWitness
                            EligibilityWitness TestCrypto WFALS
-> EligibilityWitness TestCrypto WFALS -> Bool
cmpWitness
                            EligibilityWitness TestCrypto WFALS
witness
                            EligibilityWitness TestCrypto WFALS
witness'
                  -- The pool is not eligible to vote => do nothing
                  Maybe (EligibilityWitness TestCrypto WFALS)
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 ->
    Gen TargetCommitteeSize
-> (TargetCommitteeSize -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
-> Gen TargetCommitteeSize
genTargetCommitteeSize Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools) ((TargetCommitteeSize -> Property) -> Property)
-> (TargetCommitteeSize -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TargetCommitteeSize
targetCommitteeSize -> 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 Nonce -> (Nonce -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Nonce
genEpochNonce ((Nonce -> Property) -> Property)
-> (Nonce -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Nonce
epochNonce ->
          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 WFALS
committee =
                    forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommitteeInput crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (VotingCommittee crypto committee)
mkVotingCommittee @TestCrypto @WFALS
                      ( Nonce
-> TargetCommitteeSize
-> ExtWFAStakeDistr (PublicKey TestCrypto)
-> VotingCommitteeInput TestCrypto WFALS
forall crypto.
Nonce
-> TargetCommitteeSize
-> ExtWFAStakeDistr (PublicKey crypto)
-> VotingCommitteeInput crypto WFALS
WFALSVotingCommitteeInput
                          Nonce
epochNonce
                          TargetCommitteeSize
targetCommitteeSize
                          ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
ExtWFAStakeDistr (PublicKey TestCrypto)
extWFAStakeDistr
                      )
                      Either
  (VotingCommitteeError TestCrypto WFALS)
  (VotingCommittee TestCrypto WFALS)
-> (VotingCommitteeError TestCrypto WFALS
    -> VotingCommittee TestCrypto WFALS)
-> VotingCommittee TestCrypto WFALS
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto WFALS
err ->
                        [Char] -> VotingCommittee TestCrypto WFALS
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkVotingCommittee failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
err)
              Gen
  (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto WFALS)
    -> [Char])
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto WFALS)
    -> Property)
-> Property
forall prop a.
Testable prop =>
Gen a -> (a -> [Char]) -> (a -> prop) -> Property
forAllShow
                ( VotingCommittee TestCrypto WFALS
-> PrivateKey TestCrypto
-> LedgerStake
-> Nonce
-> ElectionId TestCrypto
-> Gen
     (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
genFakeEligibilityWitness
                    VotingCommittee TestCrypto WFALS
committee
                    (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
poolPrivateKey
                    LedgerStake
poolStake
                    Nonce
epochNonce
                    Word64
ElectionId TestCrypto
electionId
                )
                (EligibilityWitness TestCrypto WFALS -> [Char]
showWitness (EligibilityWitness TestCrypto WFALS -> [Char])
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto WFALS)
    -> EligibilityWitness TestCrypto WFALS)
-> (FakeEligibilityWitnessType,
    EligibilityWitness TestCrypto WFALS)
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
-> EligibilityWitness TestCrypto WFALS
forall a b. (a, b) -> b
snd)
                (((FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
  -> Property)
 -> Property)
-> ((FakeEligibilityWitnessType,
     EligibilityWitness TestCrypto WFALS)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(FakeEligibilityWitnessType
fakeWitnessType, EligibilityWitness TestCrypto WFALS
fakeWitness) -> do
                  let fakeVote :: Vote TestCrypto WFALS
fakeVote =
                        EligibilityWitness TestCrypto WFALS
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> VoteCandidate TestCrypto
-> Vote TestCrypto WFALS
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
EligibilityWitness crypto committee
-> PrivateKey crypto
-> ElectionId crypto
-> VoteCandidate crypto
-> Vote crypto committee
forgeVote
                          EligibilityWitness TestCrypto WFALS
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
. TargetCommitteeSize -> Property -> Property
tabulateTargetCommitteeSize TargetCommitteeSize
targetCommitteeSize
                    (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FakeEligibilityWitnessType -> Property -> Property
tabulateFakePersistentWitnessType FakeEligibilityWitnessType
fakeWitnessType
                    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ do
                      case VotingCommittee TestCrypto WFALS
-> Vote TestCrypto WFALS
-> Either
     (VotingCommitteeError TestCrypto WFALS)
     (EligibilityWitness TestCrypto WFALS)
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> Vote crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (EligibilityWitness crypto committee)
verifyVote VotingCommittee TestCrypto WFALS
committee Vote TestCrypto WFALS
fakeVote of
                        Left VotingCommitteeError TestCrypto WFALS
_ ->
                          Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                        Right EligibilityWitness TestCrypto WFALS
_ ->
                          [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 TargetCommitteeSize
-> (TargetCommitteeSize -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
-> Gen TargetCommitteeSize
genTargetCommitteeSize Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools) ((TargetCommitteeSize -> Property) -> Property)
-> (TargetCommitteeSize -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \TargetCommitteeSize
targetCommitteeSize ->
      Gen Nonce -> (Nonce -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Nonce
genEpochNonce ((Nonce -> Property) -> Property)
-> (Nonce -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Nonce
epochNonce ->
        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 WFALS
committee =
                  forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommitteeInput crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (VotingCommittee crypto committee)
mkVotingCommittee @TestCrypto @WFALS
                    ( Nonce
-> TargetCommitteeSize
-> ExtWFAStakeDistr (PublicKey TestCrypto)
-> VotingCommitteeInput TestCrypto WFALS
forall crypto.
Nonce
-> TargetCommitteeSize
-> ExtWFAStakeDistr (PublicKey crypto)
-> VotingCommitteeInput crypto WFALS
WFALSVotingCommitteeInput
                        Nonce
epochNonce
                        TargetCommitteeSize
targetCommitteeSize
                        ExtWFAStakeDistr (PublicKey SIGN, PublicKey VRF)
ExtWFAStakeDistr (PublicKey TestCrypto)
extWFAStakeDistr
                    )
                    Either
  (VotingCommitteeError TestCrypto WFALS)
  (VotingCommittee TestCrypto WFALS)
-> (VotingCommitteeError TestCrypto WFALS
    -> VotingCommittee TestCrypto WFALS)
-> VotingCommittee TestCrypto WFALS
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto WFALS
err ->
                      [Char] -> VotingCommittee TestCrypto WFALS
forall a. HasCallStack => [Char] -> a
error ([Char]
"mkVotingCommittee failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
err)
            -- Forge votes from all eligible pools
            let ([Vote TestCrypto WFALS]
votes, [EligibilityWitness TestCrypto WFALS]
originalWitnesses) =
                  [(Vote TestCrypto WFALS, EligibilityWitness TestCrypto WFALS)]
-> ([Vote TestCrypto WFALS], [EligibilityWitness TestCrypto WFALS])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Vote TestCrypto WFALS, EligibilityWitness TestCrypto WFALS)]
 -> ([Vote TestCrypto WFALS],
     [EligibilityWitness TestCrypto WFALS]))
-> [(Vote TestCrypto WFALS, EligibilityWitness TestCrypto WFALS)]
-> ([Vote TestCrypto WFALS], [EligibilityWitness TestCrypto WFALS])
forall a b. (a -> b) -> a -> b
$
                    [ ( EligibilityWitness TestCrypto WFALS
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> VoteCandidate TestCrypto
-> Vote TestCrypto WFALS
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
EligibilityWitness crypto committee
-> PrivateKey crypto
-> ElectionId crypto
-> VoteCandidate crypto
-> Vote crypto committee
forgeVote EligibilityWitness TestCrypto WFALS
witness (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
privateKey Word64
ElectionId TestCrypto
electionId ByteString
VoteCandidate TestCrypto
candidate
                      , EligibilityWitness TestCrypto WFALS
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 WFALS
witness <-
                        [ VotingCommittee TestCrypto WFALS
-> PoolId
-> PrivateKey TestCrypto
-> ElectionId TestCrypto
-> Either
     (VotingCommitteeError TestCrypto WFALS)
     (Maybe (EligibilityWitness TestCrypto WFALS))
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 WFALS
committee
                            PoolId
poolId
                            (PrivateKey SIGN, PrivateKey VRF)
PrivateKey TestCrypto
privateKey
                            Word64
ElectionId TestCrypto
electionId
                            Either
  (VotingCommitteeError TestCrypto WFALS)
  (Maybe (EligibilityWitness TestCrypto WFALS))
-> (VotingCommitteeError TestCrypto WFALS
    -> Maybe (EligibilityWitness TestCrypto WFALS))
-> Maybe (EligibilityWitness TestCrypto WFALS)
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto WFALS
err ->
                              [Char] -> Maybe (EligibilityWitness TestCrypto WFALS)
forall a. HasCallStack => [Char] -> a
error ([Char]
"checkShouldVote failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
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 WFALS] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Vote TestCrypto WFALS]
votes)
              (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetCommitteeSize -> Property -> Property
tabulateTargetCommitteeSize TargetCommitteeSize
targetCommitteeSize
              (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case [Vote TestCrypto WFALS]
votes of
                [] ->
                  -- No eligible voters, nothing to test
                  Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
                Vote TestCrypto WFALS
firstVote : [Vote TestCrypto WFALS]
nextVotes -> do
                  let uniqueVotesWithSameTarget :: UniqueVotesWithSameTarget TestCrypto WFALS
uniqueVotesWithSameTarget =
                        (Vote TestCrypto WFALS
 -> (ElectionId TestCrypto, VoteCandidate TestCrypto))
-> (Vote TestCrypto WFALS -> Vote TestCrypto WFALS -> Ordering)
-> NE [Vote TestCrypto WFALS]
-> Either
     (UniqueVotesWithSameTargetError (Vote TestCrypto WFALS))
     (UniqueVotesWithSameTarget TestCrypto WFALS)
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
                              WFALSPersistentVote SeatIndex
_ ElectionId TestCrypto
eid VoteCandidate TestCrypto
cand VoteSignature TestCrypto
_ -> (ElectionId TestCrypto
eid, VoteCandidate TestCrypto
cand)
                              WFALSNonPersistentVote SeatIndex
_ ElectionId TestCrypto
eid VoteCandidate TestCrypto
cand VRFOutput TestCrypto
_ VoteSignature TestCrypto
_ -> (ElectionId TestCrypto
eid, VoteCandidate TestCrypto
cand)
                          )
                          ( SeatIndex -> SeatIndex -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (SeatIndex -> SeatIndex -> Ordering)
-> (Vote TestCrypto WFALS -> SeatIndex)
-> Vote TestCrypto WFALS
-> Vote TestCrypto WFALS
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \case
                              WFALSPersistentVote SeatIndex
seatIndex ElectionId TestCrypto
_ VoteCandidate TestCrypto
_ VoteSignature TestCrypto
_ -> SeatIndex
seatIndex
                              WFALSNonPersistentVote SeatIndex
seatIndex ElectionId TestCrypto
_ VoteCandidate TestCrypto
_ VRFOutput TestCrypto
_ VoteSignature TestCrypto
_ -> SeatIndex
seatIndex
                          )
                          (Vote TestCrypto WFALS
firstVote Vote TestCrypto WFALS
-> [Vote TestCrypto WFALS] -> NonEmpty (Vote TestCrypto WFALS)
forall a. a -> [a] -> NonEmpty a
:| [Vote TestCrypto WFALS]
nextVotes)
                          Either
  (UniqueVotesWithSameTargetError (Vote TestCrypto WFALS))
  (UniqueVotesWithSameTarget TestCrypto WFALS)
-> (UniqueVotesWithSameTargetError (Vote TestCrypto WFALS)
    -> UniqueVotesWithSameTarget TestCrypto WFALS)
-> UniqueVotesWithSameTarget TestCrypto WFALS
forall err a. Either err a -> (err -> a) -> a
`onError` \UniqueVotesWithSameTargetError (Vote TestCrypto WFALS)
_ ->
                            [Char] -> UniqueVotesWithSameTarget TestCrypto WFALS
forall a. HasCallStack => [Char] -> a
error [Char]
"votes don't have the same target!"
                  let cert :: Cert TestCrypto WFALS
cert =
                        UniqueVotesWithSameTarget TestCrypto WFALS
-> Either
     (VotingCommitteeError TestCrypto WFALS) (Cert TestCrypto WFALS)
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
UniqueVotesWithSameTarget crypto committee
-> Either
     (VotingCommitteeError crypto committee) (Cert crypto committee)
forgeCert UniqueVotesWithSameTarget TestCrypto WFALS
uniqueVotesWithSameTarget
                          Either
  (VotingCommitteeError TestCrypto WFALS) (Cert TestCrypto WFALS)
-> (VotingCommitteeError TestCrypto WFALS -> Cert TestCrypto WFALS)
-> Cert TestCrypto WFALS
forall err a. Either err a -> (err -> a) -> a
`onError` \VotingCommitteeError TestCrypto WFALS
err ->
                            [Char] -> Cert TestCrypto WFALS
forall a. HasCallStack => [Char] -> a
error ([Char]
"forgeCert failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VotingCommitteeError TestCrypto WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
err)
                  case VotingCommittee TestCrypto WFALS
-> Cert TestCrypto WFALS
-> Either
     (VotingCommitteeError TestCrypto WFALS)
     (NE [EligibilityWitness TestCrypto WFALS])
forall crypto committee.
CryptoSupportsVotingCommittee crypto committee =>
VotingCommittee crypto committee
-> Cert crypto committee
-> Either
     (VotingCommitteeError crypto committee)
     (NE [EligibilityWitness crypto committee])
verifyCert VotingCommittee TestCrypto WFALS
committee Cert TestCrypto WFALS
cert of
                    Left VotingCommitteeError TestCrypto WFALS
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 WFALS -> [Char]
forall a. Show a => a -> [Char]
show VotingCommitteeError TestCrypto WFALS
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 WFALS]
witnesses -> do
                      let witnessesFromCert :: [EligibilityWitness TestCrypto WFALS]
witnessesFromCert = NonEmpty (EligibilityWitness TestCrypto WFALS)
-> [EligibilityWitness TestCrypto WFALS]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (EligibilityWitness TestCrypto WFALS)
NE [EligibilityWitness TestCrypto WFALS]
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 WFALS] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EligibilityWitness TestCrypto WFALS]
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 WFALS -> [Char])
-> [EligibilityWitness TestCrypto WFALS] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EligibilityWitness TestCrypto WFALS -> [Char]
showWitness [EligibilityWitness TestCrypto WFALS]
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 WFALS] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EligibilityWitness TestCrypto WFALS]
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 WFALS -> [Char])
-> [EligibilityWitness TestCrypto WFALS] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EligibilityWitness TestCrypto WFALS -> [Char]
showWitness [EligibilityWitness TestCrypto WFALS]
witnessesFromCert)
                            ]
                        )
                        (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ [EligibilityWitness TestCrypto WFALS]
-> [EligibilityWitness TestCrypto WFALS] -> Bool
cmpWitnesses [EligibilityWitness TestCrypto WFALS]
originalWitnesses [EligibilityWitness TestCrypto WFALS]
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
    ]

genTargetCommitteeSize ::
  Map PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake) ->
  Gen TargetCommitteeSize
genTargetCommitteeSize :: Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
-> Gen TargetCommitteeSize
genTargetCommitteeSize Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools = do
  let hasPositiveStake :: (a, b, LedgerStake) -> Bool
hasPositiveStake (a
_, b
_, LedgerStake Ratio Integer
stake) =
        Ratio Integer
stake Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Ratio Integer
0
  let poolsWithPositiveStake :: Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
poolsWithPositiveStake =
        (((PrivateKey SIGN, PrivateKey VRF),
  (PublicKey SIGN, PublicKey VRF), LedgerStake)
 -> Bool)
-> Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Map
     PoolId
     ((PrivateKey SIGN, PrivateKey VRF),
      (PublicKey SIGN, PublicKey VRF), LedgerStake)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((PrivateKey SIGN, PrivateKey VRF),
 (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Bool
forall {a} {b}. (a, b, LedgerStake) -> Bool
hasPositiveStake Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
Map
  PoolId (PrivateKey TestCrypto, PublicKey TestCrypto, LedgerStake)
pools
  numPools <-
    (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
-> Int
forall k a. Map k a -> Int
Map.size Map
  PoolId
  ((PrivateKey SIGN, PrivateKey VRF),
   (PublicKey SIGN, PublicKey VRF), LedgerStake)
poolsWithPositiveStake)
  pure $ TargetCommitteeSize (fromIntegral numPools)

data FakeEligibilityWitnessType
  = NotAPersistentMember
  | NotANonPersistentMember
  | NonPersistentMemberWithZeroSeats
  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 witnesses in three ways:
--  1. generating a persistent member witness with an index outside of the
--     persistent members range,
--  2. generating a non-persistent member witness with an index outside of the
--     non-persistent members range, and
--  3. generating a non-persistent member witness with a VRF output that leads
--     to zero non-persistent seats.
genFakeEligibilityWitness ::
  VotingCommittee TestCrypto WFALS ->
  PrivateKey TestCrypto ->
  LedgerStake ->
  Nonce ->
  ElectionId TestCrypto ->
  Gen (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
genFakeEligibilityWitness :: VotingCommittee TestCrypto WFALS
-> PrivateKey TestCrypto
-> LedgerStake
-> Nonce
-> ElectionId TestCrypto
-> Gen
     (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
genFakeEligibilityWitness
  VotingCommittee TestCrypto WFALS
committee
  PrivateKey TestCrypto
poolPrivateKey
  LedgerStake
poolStake
  Nonce
epochNonce
  ElectionId TestCrypto
electionId = do
    [(Int,
  Gen
    (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS))]
-> Gen
     (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [
        ( if Word64
numNonPersistentSeats Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 then Int
1 else Int
0
        , Gen
  (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
genFakePersistentMemberWitness
        )
      ,
        ( if Word64
numPersistentSeats Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0 then Int
1 else Int
0
        , Gen
  (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
genFakeNonPersistentMemberWitness
        )
      ]
   where
    numPersistentSeats :: Word64
numPersistentSeats =
      PersistentCommitteeSize -> Word64
unPersistentCommitteeSize (VotingCommittee TestCrypto WFALS -> PersistentCommitteeSize
forall crypto.
VotingCommittee crypto WFALS -> PersistentCommitteeSize
persistentCommitteeSize VotingCommittee TestCrypto WFALS
committee)

    numNonPersistentSeats :: Word64
numNonPersistentSeats =
      NonPersistentCommitteeSize -> Word64
unNonPersistentCommitteeSize (VotingCommittee TestCrypto WFALS -> NonPersistentCommitteeSize
forall crypto.
VotingCommittee crypto WFALS -> NonPersistentCommitteeSize
nonPersistentCommitteeSize VotingCommittee TestCrypto WFALS
committee)

    persistentRange :: (Word64, Word64)
persistentRange =
      (Word64
0, Word64
numPersistentSeats Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)

    nonPersistentRange :: (Word64, Word64)
nonPersistentRange =
      (Word64
numPersistentSeats, Word64
numPersistentSeats Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
numNonPersistentSeats Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)

    -- This witness looks like a persistent member, but its seat index lies
    -- outside the persistent members range (case 1).
    genFakePersistentMemberWitness :: Gen
  (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
genFakePersistentMemberWitness = 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, Word64)
nonPersistentRange
      pure
        ( NotAPersistentMember
        , WFALSPersistentMember
            seatIndex
            poolStake
        )

    -- This witness looks like a non-persistent member, but depending on whether
    -- the VRF output leads to a positive number of seats or not, it breaks
    -- the structure of a valid witness either by having an index outside of the
    -- non-persistent members range (case 2) or by failing to claim a non-zero
    -- number of non-persistent seats (case 3).
    genFakeNonPersistentMemberWitness :: Gen
  (FakeEligibilityWitnessType, EligibilityWitness TestCrypto WFALS)
genFakeNonPersistentMemberWitness = do
      let vrfOutput :: VRFOutput TestCrypto
vrfOutput =
            forall crypto.
CryptoSupportsVRF crypto =>
VRFPoolContext crypto
-> VRFElectionInput crypto -> Either [Char] (VRFOutput crypto)
evalVRF @TestCrypto
              (VRFSigningKey TestCrypto -> VRFPoolContext TestCrypto
forall crypto. VRFSigningKey crypto -> VRFPoolContext crypto
VRFSignContext (Proxy TestCrypto
-> PrivateKey TestCrypto -> VRFSigningKey TestCrypto
forall crypto.
CryptoSupportsVRF crypto =>
Proxy crypto -> PrivateKey crypto -> VRFSigningKey crypto
getVRFSigningKey (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestCrypto) PrivateKey TestCrypto
poolPrivateKey))
              (Nonce -> ElectionId TestCrypto -> VRFElectionInput TestCrypto
forall crypto.
CryptoSupportsVRF crypto =>
Nonce -> ElectionId crypto -> VRFElectionInput crypto
mkVRFElectionInput Nonce
epochNonce ElectionId TestCrypto
electionId)
              Either [Char] (VRFOutput TestCrypto)
-> ([Char] -> VRFOutput TestCrypto) -> VRFOutput TestCrypto
forall err a. Either err a -> (err -> a) -> a
`onError` \[Char]
err ->
                [Char] -> VRFOutput TestCrypto
forall a. HasCallStack => [Char] -> a
error ([Char]
"evalVRF failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
err)
      let numSeats :: LocalSortitionNumSeats
numSeats =
            NonPersistentCommitteeSize
-> TotalNonPersistentStake
-> LedgerStake
-> NormalizedVRFOutput
-> LocalSortitionNumSeats
LS.localSortitionNumSeats
              (VotingCommittee TestCrypto WFALS -> NonPersistentCommitteeSize
forall crypto.
VotingCommittee crypto WFALS -> NonPersistentCommitteeSize
nonPersistentCommitteeSize VotingCommittee TestCrypto WFALS
committee)
              (VotingCommittee TestCrypto WFALS -> TotalNonPersistentStake
forall crypto.
VotingCommittee crypto WFALS -> TotalNonPersistentStake
totalNonPersistentStake VotingCommittee TestCrypto WFALS
committee)
              LedgerStake
poolStake
              (VRFOutput TestCrypto -> NormalizedVRFOutput
forall crypto.
CryptoSupportsVRF crypto =>
VRFOutput crypto -> NormalizedVRFOutput
normalizeVRFOutput VRFOutput TestCrypto
vrfOutput)

      case LocalSortitionNumSeats -> Maybe (NonZero LocalSortitionNumSeats)
forall a. HasZero a => a -> Maybe (NonZero a)
nonZero LocalSortitionNumSeats
numSeats of
        Just NonZero LocalSortitionNumSeats
nonZeroNumSeats -> 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, Word64)
persistentRange
          pure
            ( NotANonPersistentMember
            , WFALSNonPersistentMember
                seatIndex
                poolStake
                vrfOutput
                nonZeroNumSeats
            )
        Maybe (NonZero LocalSortitionNumSeats)
Nothing -> 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, Word64)
nonPersistentRange
          pure
            ( NonPersistentMemberWithZeroSeats
            , WFALSNonPersistentMember
                seatIndex
                poolStake
                vrfOutput
                (unsafeNonZero numSeats)
            )

-- * Property helpers

showWitness ::
  EligibilityWitness TestCrypto WFALS ->
  String
showWitness :: EligibilityWitness TestCrypto WFALS -> [Char]
showWitness EligibilityWitness TestCrypto WFALS
witness =
  case EligibilityWitness TestCrypto WFALS
witness of
    WFALSPersistentMember SeatIndex
seatIndex LedgerStake
_ ->
      [Char]
"PersistentMember(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]
")"
    WFALSNonPersistentMember SeatIndex
seatIndex LedgerStake
_ VRFOutput TestCrypto
vrfOutput NonZero LocalSortitionNumSeats
numSeats ->
      [Char]
"NonPersistentMember(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]
", VRFOutput="
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VRFOutput TestCrypto -> [Char]
forall a. Show a => a -> [Char]
show VRFOutput TestCrypto
vrfOutput
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", NumSeats="
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show (LocalSortitionNumSeats -> Word64
unLocalSortitionNumSeats (NonZero LocalSortitionNumSeats -> LocalSortitionNumSeats
forall a. NonZero a -> a
unNonZero NonZero LocalSortitionNumSeats
numSeats))
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"

cmpWitness ::
  EligibilityWitness TestCrypto WFALS ->
  EligibilityWitness TestCrypto WFALS ->
  Bool
cmpWitness :: EligibilityWitness TestCrypto WFALS
-> EligibilityWitness TestCrypto WFALS -> Bool
cmpWitness EligibilityWitness TestCrypto WFALS
w1 EligibilityWitness TestCrypto WFALS
w2 =
  case (EligibilityWitness TestCrypto WFALS
w1, EligibilityWitness TestCrypto WFALS
w2) of
    ( WFALSPersistentMember SeatIndex
seatIndex1 LedgerStake
_
      , WFALSPersistentMember SeatIndex
seatIndex2 LedgerStake
_
      ) ->
        SeatIndex
seatIndex1 SeatIndex -> SeatIndex -> Bool
forall a. Eq a => a -> a -> Bool
== SeatIndex
seatIndex2
    ( WFALSNonPersistentMember SeatIndex
seatIndex1 LedgerStake
_ VRFOutput TestCrypto
vrfOutput1 NonZero LocalSortitionNumSeats
numSeats1
      , WFALSNonPersistentMember SeatIndex
seatIndex2 LedgerStake
_ VRFOutput TestCrypto
vrfOutput2 NonZero LocalSortitionNumSeats
numSeats2
      ) ->
        SeatIndex
seatIndex1 SeatIndex -> SeatIndex -> Bool
forall a. Eq a => a -> a -> Bool
== SeatIndex
seatIndex2
          Bool -> Bool -> Bool
&& VRFOutput TestCrypto
vrfOutput1 VRFOutput TestCrypto -> VRFOutput TestCrypto -> Bool
forall a. Eq a => a -> a -> Bool
== VRFOutput TestCrypto
vrfOutput2
          Bool -> Bool -> Bool
&& NonZero LocalSortitionNumSeats
numSeats1 NonZero LocalSortitionNumSeats
-> NonZero LocalSortitionNumSeats -> Bool
forall a. Eq a => a -> a -> Bool
== NonZero LocalSortitionNumSeats
numSeats2
    (EligibilityWitness TestCrypto WFALS,
 EligibilityWitness TestCrypto WFALS)
_ ->
      Bool
False

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

-- * Tabulation helpers

tabulateTargetCommitteeSize ::
  TargetCommitteeSize ->
  Property ->
  Property
tabulateTargetCommitteeSize :: TargetCommitteeSize -> Property -> Property
tabulateTargetCommitteeSize (TargetCommitteeSize Word64
size) =
  [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate
    [Char]
"Target committee size"
    [Integer -> Integer -> [Char]
mkBucket Integer
100 (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
size)]

tabulateShouldVote ::
  Maybe (EligibilityWitness TestCrypto WFALS) ->
  Property ->
  Property
tabulateShouldVote :: Maybe (EligibilityWitness TestCrypto WFALS) -> Property -> Property
tabulateShouldVote Maybe (EligibilityWitness TestCrypto WFALS)
shouldVote =
  [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate
    [Char]
"Should vote"
    [ case Maybe (EligibilityWitness TestCrypto WFALS)
shouldVote of
        Maybe (EligibilityWitness TestCrypto WFALS)
Nothing ->
          [Char]
"NoVote"
        Just (WFALSPersistentMember SeatIndex
_ LedgerStake
_) ->
          [Char]
"PersistentVote"
        Just (WFALSNonPersistentMember SeatIndex
_ LedgerStake
_ VRFOutput TestCrypto
_ NonZero LocalSortitionNumSeats
numSeats) ->
          [Char]
"NonPersistentVote(NumSeats="
            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show (LocalSortitionNumSeats -> Word64
unLocalSortitionNumSeats (NonZero LocalSortitionNumSeats -> LocalSortitionNumSeats
forall a. NonZero a -> a
unNonZero NonZero LocalSortitionNumSeats
numSeats))
            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
    ]

tabulateFakePersistentWitnessType ::
  FakeEligibilityWitnessType ->
  Property ->
  Property
tabulateFakePersistentWitnessType :: FakeEligibilityWitnessType -> Property -> Property
tabulateFakePersistentWitnessType 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)]