{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Consensus.Peras.Voting.V1 (tests) where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Coin (Coin (..), compactCoinOrError, knownNonZeroCoin)
import Cardano.Ledger.Hashes (StakePool)
import Cardano.Ledger.Keys (KeyHash, toVRFVerKeyHash)
import Cardano.Ledger.State (BlsKey (..), IndividualPoolStake (..), PoolDistr (..))
import qualified Data.ByteString as BS
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import Ouroboros.Consensus.Committee.Crypto.BLS (KeyRole (..))
import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS
import Ouroboros.Consensus.Committee.Types (PoolId (..))
import Ouroboros.Consensus.Peras.Voting.V1 (extractPerasStakeDistrAndPublicKeys)
import Test.QuickCheck
  ( Gen
  , Property
  , counterexample
  , cover
  , elements
  , forAll
  , (===)
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Test.Util.Peras.Common
  ( NonEmptyListWithUniqueIds (..)
  , genNonEmptyListWithUniqueIds
  , genPoolId
  )
import Test.Util.Peras.V1 (genPrivateKey)

data KeyCase = NoKey | HasKey
  deriving (Int -> KeyCase -> ShowS
[KeyCase] -> ShowS
KeyCase -> String
(Int -> KeyCase -> ShowS)
-> (KeyCase -> String) -> ([KeyCase] -> ShowS) -> Show KeyCase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyCase -> ShowS
showsPrec :: Int -> KeyCase -> ShowS
$cshow :: KeyCase -> String
show :: KeyCase -> String
$cshowList :: [KeyCase] -> ShowS
showList :: [KeyCase] -> ShowS
Show, KeyCase -> KeyCase -> Bool
(KeyCase -> KeyCase -> Bool)
-> (KeyCase -> KeyCase -> Bool) -> Eq KeyCase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyCase -> KeyCase -> Bool
== :: KeyCase -> KeyCase -> Bool
$c/= :: KeyCase -> KeyCase -> Bool
/= :: KeyCase -> KeyCase -> Bool
Eq, KeyCase
KeyCase -> KeyCase -> Bounded KeyCase
forall a. a -> a -> Bounded a
$cminBound :: KeyCase
minBound :: KeyCase
$cmaxBound :: KeyCase
maxBound :: KeyCase
Bounded, Int -> KeyCase
KeyCase -> Int
KeyCase -> [KeyCase]
KeyCase -> KeyCase
KeyCase -> KeyCase -> [KeyCase]
KeyCase -> KeyCase -> KeyCase -> [KeyCase]
(KeyCase -> KeyCase)
-> (KeyCase -> KeyCase)
-> (Int -> KeyCase)
-> (KeyCase -> Int)
-> (KeyCase -> [KeyCase])
-> (KeyCase -> KeyCase -> [KeyCase])
-> (KeyCase -> KeyCase -> [KeyCase])
-> (KeyCase -> KeyCase -> KeyCase -> [KeyCase])
-> Enum KeyCase
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: KeyCase -> KeyCase
succ :: KeyCase -> KeyCase
$cpred :: KeyCase -> KeyCase
pred :: KeyCase -> KeyCase
$ctoEnum :: Int -> KeyCase
toEnum :: Int -> KeyCase
$cfromEnum :: KeyCase -> Int
fromEnum :: KeyCase -> Int
$cenumFrom :: KeyCase -> [KeyCase]
enumFrom :: KeyCase -> [KeyCase]
$cenumFromThen :: KeyCase -> KeyCase -> [KeyCase]
enumFromThen :: KeyCase -> KeyCase -> [KeyCase]
$cenumFromTo :: KeyCase -> KeyCase -> [KeyCase]
enumFromTo :: KeyCase -> KeyCase -> [KeyCase]
$cenumFromThenTo :: KeyCase -> KeyCase -> KeyCase -> [KeyCase]
enumFromThenTo :: KeyCase -> KeyCase -> KeyCase -> [KeyCase]
Enum)

genBlsKeyFor :: KeyHash StakePool -> Gen BlsKey
genBlsKeyFor :: KeyHash StakePool -> Gen BlsKey
genBlsKeyFor KeyHash StakePool
stakePoolHash = do
  sk <- Proxy POP -> Gen (PrivateKey POP)
forall (r :: KeyRole). Proxy r -> Gen (PrivateKey r)
genPrivateKey (forall {k} (t :: k). Proxy t
forall (t :: KeyRole). Proxy t
Proxy @POP)
  let pk = PrivateKey POP -> PublicKey POP
forall (r :: KeyRole). PrivateKey r -> PublicKey r
BLS.derivePublicKey PrivateKey POP
sk
      pop = PrivateKey POP -> KeyHash StakePool -> ProofOfPossession
BLS.createProofOfPossession PrivateKey POP
sk KeyHash StakePool
stakePoolHash
  pure
    BlsKey
      { blsPubKey = BLS.rawPublicKey pk
      , blsPossessionProof = BLS.rawProofOfPossession pop
      }

mkStake :: StrictMaybe BlsKey -> IndividualPoolStake
mkStake :: StrictMaybe BlsKey -> IndividualPoolStake
mkStake StrictMaybe BlsKey
blsKey =
  IndividualPoolStake
    { individualPoolStake :: Ratio Integer
individualPoolStake = Ratio Integer
1
    , individualTotalPoolStake :: CompactForm Coin
individualTotalPoolStake = HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError (Integer -> Coin
Coin Integer
1)
    , individualPoolStakeVrf :: VRFVerKeyHash StakePoolVRF
individualPoolStakeVrf = VRFVerKeyHash StakePoolVRF
forall {r :: KeyRoleVRF}. VRFVerKeyHash r
dummyVrf
    , individualPoolStakeBls :: StrictMaybe BlsKey
individualPoolStakeBls = StrictMaybe BlsKey
blsKey
    }
 where
  dummyVrf :: VRFVerKeyHash r
dummyVrf =
    Hash HASH (VerKeyVRF (ZonkAny 0)) -> VRFVerKeyHash r
forall v (r :: KeyRoleVRF).
Hash HASH (VerKeyVRF v) -> VRFVerKeyHash r
toVRFVerKeyHash
      (Hash HASH (VerKeyVRF (ZonkAny 0)) -> VRFVerKeyHash r)
-> (ByteString -> Hash HASH (VerKeyVRF (ZonkAny 0)))
-> ByteString
-> VRFVerKeyHash r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash HASH ByteString -> Hash HASH (VerKeyVRF (ZonkAny 0))
forall h a b. Hash h a -> Hash h b
Hash.castHash
      (Hash HASH ByteString -> Hash HASH (VerKeyVRF (ZonkAny 0)))
-> (ByteString -> Hash HASH ByteString)
-> ByteString
-> Hash HASH (VerKeyVRF (ZonkAny 0))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> ByteString -> Hash HASH ByteString
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith ByteString -> ByteString
forall a. a -> a
id
      (ByteString -> VRFVerKeyHash r) -> ByteString -> VRFVerKeyHash r
forall a b. (a -> b) -> a -> b
$ (ByteString
"ledgerkeys-test-vrf" :: BS.ByteString)

genPoolEntry :: Gen (PoolId, KeyCase, IndividualPoolStake)
genPoolEntry :: Gen (PoolId, KeyCase, IndividualPoolStake)
genPoolEntry = do
  poolId <- Gen PoolId
genPoolId
  keyCase <- elements [minBound .. maxBound]
  stake <- case keyCase of
    KeyCase
NoKey -> IndividualPoolStake -> Gen IndividualPoolStake
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StrictMaybe BlsKey -> IndividualPoolStake
mkStake StrictMaybe BlsKey
forall a. StrictMaybe a
SNothing)
    KeyCase
HasKey -> StrictMaybe BlsKey -> IndividualPoolStake
mkStake (StrictMaybe BlsKey -> IndividualPoolStake)
-> (BlsKey -> StrictMaybe BlsKey) -> BlsKey -> IndividualPoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlsKey -> StrictMaybe BlsKey
forall a. a -> StrictMaybe a
SJust (BlsKey -> IndividualPoolStake)
-> Gen BlsKey -> Gen IndividualPoolStake
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash StakePool -> Gen BlsKey
genBlsKeyFor (PoolId -> KeyHash StakePool
unPoolId PoolId
poolId)
  pure (poolId, keyCase, stake)

prop_extractPerasStakeDistrAndPublicKeys :: Property
prop_extractPerasStakeDistrAndPublicKeys :: Property
prop_extractPerasStakeDistrAndPublicKeys =
  Gen
  (NonEmptyListWithUniqueIds (PoolId, KeyCase, IndividualPoolStake))
-> (NonEmptyListWithUniqueIds
      (PoolId, KeyCase, IndividualPoolStake)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll
    (((PoolId, KeyCase, IndividualPoolStake) -> PoolId)
-> Gen (PoolId, KeyCase, IndividualPoolStake)
-> Gen
     (NonEmptyListWithUniqueIds (PoolId, KeyCase, IndividualPoolStake))
forall idTy a.
Ord idTy =>
(a -> idTy) -> Gen a -> Gen (NonEmptyListWithUniqueIds a)
genNonEmptyListWithUniqueIds (\(PoolId
poolId, KeyCase
_, IndividualPoolStake
_) -> PoolId
poolId) Gen (PoolId, KeyCase, IndividualPoolStake)
genPoolEntry)
    ((NonEmptyListWithUniqueIds (PoolId, KeyCase, IndividualPoolStake)
  -> Property)
 -> Property)
-> (NonEmptyListWithUniqueIds
      (PoolId, KeyCase, IndividualPoolStake)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(NonEmptyListWithUniqueIds NonEmpty (PoolId, KeyCase, IndividualPoolStake)
entries') -> do
      let entries :: [(PoolId, KeyCase, IndividualPoolStake)]
entries = NonEmpty (PoolId, KeyCase, IndividualPoolStake)
-> [(PoolId, KeyCase, IndividualPoolStake)]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (PoolId, KeyCase, IndividualPoolStake)
entries'
      let poolDistr :: PoolDistr
poolDistr =
            PoolDistr
              { unPoolDistr :: Map (KeyHash StakePool) IndividualPoolStake
unPoolDistr = [(KeyHash StakePool, IndividualPoolStake)]
-> Map (KeyHash StakePool) IndividualPoolStake
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PoolId -> KeyHash StakePool
unPoolId PoolId
poolId, IndividualPoolStake
stake) | (PoolId
poolId, KeyCase
_, IndividualPoolStake
stake) <- [(PoolId, KeyCase, IndividualPoolStake)]
entries]
              , pdTotalActiveStake :: NonZero Coin
pdTotalActiveStake = forall (n :: Natural). (KnownNat n, 1 <= n) => NonZero Coin
knownNonZeroCoin @1
              }
      let expectedPoolIds :: Set PoolId
expectedPoolIds =
            [PoolId] -> Set PoolId
forall a. Ord a => [a] -> Set a
Set.fromList [PoolId
poolId | (PoolId
poolId, KeyCase
HasKey, IndividualPoolStake
_) <- [(PoolId, KeyCase, IndividualPoolStake)]
entries]
      let result :: Map PoolId (LedgerStake, PerasPublicKey)
result =
            PoolDistr -> Map PoolId (LedgerStake, PerasPublicKey)
extractPerasStakeDistrAndPublicKeys PoolDistr
poolDistr
      let hasCase :: KeyCase -> Bool
hasCase KeyCase
keyCase =
            ((PoolId, KeyCase, IndividualPoolStake) -> Bool)
-> [(PoolId, KeyCase, IndividualPoolStake)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(PoolId
_, KeyCase
keyCase', IndividualPoolStake
_) -> KeyCase
keyCase' KeyCase -> KeyCase -> Bool
forall a. Eq a => a -> a -> Bool
== KeyCase
keyCase) [(PoolId, KeyCase, IndividualPoolStake)]
entries
      let coverageLabels :: [(KeyCase, String)]
coverageLabels =
            [ (KeyCase
NoKey, String
"contains a pool with no registered key")
            , (KeyCase
HasKey, String
"contains a pool with a registered key")
            ]
      ((KeyCase, String) -> Property -> Property)
-> Property -> [(KeyCase, String)] -> Property
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
        (\(KeyCase
keyCase, String
label) -> Double -> Bool -> String -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> String -> prop -> Property
cover Double
1 (KeyCase -> Bool
hasCase KeyCase
keyCase) String
label)
        (String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample ([(PoolId, KeyCase, IndividualPoolStake)] -> String
forall a. Show a => a -> String
show [(PoolId, KeyCase, IndividualPoolStake)]
entries) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Map PoolId (LedgerStake, PerasPublicKey) -> Set PoolId
forall k a. Map k a -> Set k
Map.keysSet Map PoolId (LedgerStake, PerasPublicKey)
result Set PoolId -> Set PoolId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Set PoolId
expectedPoolIds)
        [(KeyCase, String)]
coverageLabels

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"V1"
    [ String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty
        String
"extractPerasStakeDistrAndPublicKeys includes exactly the pools with a registered key"
        Property
prop_extractPerasStakeDistrAndPublicKeys
    ]