{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Cardano.Ledger.State.LeiosCommitteeSpec (spec) where
import Cardano.Crypto.DSIGN (createPossessionProofDSIGN, deriveVerKeyDSIGN, genKeyDSIGN)
import Cardano.Crypto.DSIGN.BLS12381.Internal (minSigPoPDST)
import Cardano.Crypto.Seed (mkSeedFromBytes)
import Cardano.Ledger.BaseTypes (EpochInterval (..), StrictMaybe (..), addEpochInterval)
import Cardano.Ledger.Coin (CompactForm (..))
import Cardano.Ledger.Slot (EpochNo (..))
import Cardano.Ledger.State (
BlsKey (..),
BlsKeyState (..),
LeiosCandidate (..),
LeiosSeat (..),
emptyLeiosCommittee,
leiosCommitteeSeats,
selectLeiosCommittee,
)
import qualified Data.ByteString as BS
import Data.Function ((&))
import Data.List (sortOn)
import Data.Ord (Down (..))
import Data.Ratio ((%))
import qualified Data.Vector as V
import qualified Data.Vector.Strict as VS
import Data.Word (Word16, Word32, Word64)
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.KeyPair (mkKeyHash)
candidateWith :: Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith :: Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
poolId Word64
stake =
KeyHash StakePool
-> CompactForm Coin
-> Weight
-> StrictMaybe BlsKeyState
-> LeiosCandidate
LeiosCandidate (Int -> KeyHash StakePool
forall (kd :: KeyRole). Int -> KeyHash kd
mkKeyHash Int
poolId) (Word64 -> CompactForm Coin
CompactCoin Word64
stake) (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
stake Integer -> Integer -> Weight
forall a. Integral a => a -> a -> Ratio a
% Integer
1)
validKey :: Int -> BlsKey
validKey :: Int -> BlsKey
validKey Int
i =
BlsKey
{ blsPubKey :: LeiosVerificationKey
blsPubKey = SignKeyDSIGN BLS12381MinSigDSIGN -> LeiosVerificationKey
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN BLS12381MinSigDSIGN
signKey
, blsPossessionProof :: PossessionProofDSIGN BLS12381MinSigDSIGN
blsPossessionProof = ContextDSIGN BLS12381MinSigDSIGN
-> SignKeyDSIGN BLS12381MinSigDSIGN
-> PossessionProofDSIGN BLS12381MinSigDSIGN
forall v.
(DSIGNAggregatable v, HasCallStack) =>
ContextDSIGN v -> SignKeyDSIGN v -> PossessionProofDSIGN v
createPossessionProofDSIGN ContextDSIGN BLS12381MinSigDSIGN
BLS12381SignContext
minSigPoPDST SignKeyDSIGN BLS12381MinSigDSIGN
signKey
}
where
signKey :: SignKeyDSIGN BLS12381MinSigDSIGN
signKey = Seed -> SignKeyDSIGN BLS12381MinSigDSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate Int
32 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)))
keyState :: Int -> EpochNo -> BlsKeyState
keyState :: Int -> EpochNo -> BlsKeyState
keyState Int
i EpochNo
registeredIn = BlsKey -> EpochNo -> BlsKeyState
BlsKeyState (Int -> BlsKey
validKey Int
i) EpochNo
registeredIn
seatsOf :: Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf :: Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf Word16
committeeSize =
Vector LeiosSeat -> [LeiosSeat]
forall a. Vector a -> [a]
VS.toList
(Vector LeiosSeat -> [LeiosSeat])
-> ([LeiosCandidate] -> Vector LeiosSeat)
-> [LeiosCandidate]
-> [LeiosSeat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosCommittee -> Vector LeiosSeat
leiosCommitteeSeats
(LeiosCommittee -> Vector LeiosSeat)
-> ([LeiosCandidate] -> LeiosCommittee)
-> [LeiosCandidate]
-> Vector LeiosSeat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochNo
-> EpochInterval
-> Word16
-> Vector LeiosCandidate
-> LeiosCommittee
selectLeiosCommittee (Word64 -> EpochNo
EpochNo Word64
0) (Word32 -> EpochInterval
EpochInterval Word32
forall a. Bounded a => a
maxBound) Word16
committeeSize
(Vector LeiosCandidate -> LeiosCommittee)
-> ([LeiosCandidate] -> Vector LeiosCandidate)
-> [LeiosCandidate]
-> LeiosCommittee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LeiosCandidate] -> Vector LeiosCandidate
forall a. [a] -> Vector a
V.fromList
spec :: Spec
spec :: Spec
spec = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"selectLeiosCommittee" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> ([Word64] -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"a committee size of zero produces no committee" (([Word64] -> Property) -> Spec) -> ([Word64] -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
\([Word64]
stakes :: [Word64]) ->
let candidates :: [LeiosCandidate]
candidates = [Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
i Word64
s StrictMaybe BlsKeyState
forall a. StrictMaybe a
SNothing | (Int
i, Word64
s) <- [Int] -> [Word64] -> [(Int, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Word64]
stakes]
in EpochNo
-> EpochInterval
-> Word16
-> Vector LeiosCandidate
-> LeiosCommittee
selectLeiosCommittee (Word64 -> EpochNo
EpochNo Word64
0) (Word32 -> EpochInterval
EpochInterval Word32
forall a. Bounded a => a
maxBound) Word16
0 ([LeiosCandidate] -> Vector LeiosCandidate
forall a. [a] -> Vector a
V.fromList [LeiosCandidate]
candidates)
LeiosCommittee -> LeiosCommittee -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LeiosCommittee
emptyLeiosCommittee
String -> ([Word64] -> Word16 -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"seats exactly min(committeeSize, number of pools) pools" (([Word64] -> Word16 -> Property) -> Spec)
-> ([Word64] -> Word16 -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
\([Word64]
stakes :: [Word64]) (Word16
committeeSize :: Word16) ->
let candidates :: [LeiosCandidate]
candidates = [Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
i Word64
s StrictMaybe BlsKeyState
forall a. StrictMaybe a
SNothing | (Int
i, Word64
s) <- [Int] -> [Word64] -> [(Int, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Word64]
stakes]
in [LeiosSeat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf Word16
committeeSize [LeiosCandidate]
candidates)
Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
committeeSize) ([LeiosCandidate] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LeiosCandidate]
candidates)
String -> ([Word64] -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"seats pools in descending stake" (([Word64] -> Property) -> Spec) -> ([Word64] -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
\([Word64]
stakes :: [Word64]) ->
let candidates :: [LeiosCandidate]
candidates = [Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
i Word64
s StrictMaybe BlsKeyState
forall a. StrictMaybe a
SNothing | (Int
i, Word64
s) <- [Int] -> [Word64] -> [(Int, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Word64]
stakes]
weights :: [Weight]
weights = (LeiosSeat -> Weight) -> [LeiosSeat] -> [Weight]
forall a b. (a -> b) -> [a] -> [b]
map LeiosSeat -> Weight
seatWeight (Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([LeiosCandidate] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LeiosCandidate]
candidates)) [LeiosCandidate]
candidates)
in [Weight]
weights [Weight] -> [Weight] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (Weight -> Down Weight) -> [Weight] -> [Weight]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Weight -> Down Weight
forall a. a -> Down a
Down [Weight]
weights
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"seat weights not descending: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Weight] -> String
forall a. Show a => a -> String
show [Weight]
weights)
String -> ([Word64] -> Word16 -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"seats the highest-stake pools" (([Word64] -> Word16 -> Property) -> Spec)
-> ([Word64] -> Word16 -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
\([Word64]
stakes :: [Word64]) (Word16
committeeSize :: Word16) ->
let candidates :: [LeiosCandidate]
candidates = [Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
i Word64
s StrictMaybe BlsKeyState
forall a. StrictMaybe a
SNothing | (Int
i, Word64
s) <- [Int] -> [Word64] -> [(Int, Word64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Word64]
stakes]
seated :: [Weight]
seated = (LeiosSeat -> Weight) -> [LeiosSeat] -> [Weight]
forall a b. (a -> b) -> [a] -> [b]
map LeiosSeat -> Weight
seatWeight (Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf Word16
committeeSize [LeiosCandidate]
candidates)
topWeights :: [Weight]
topWeights = Int -> [Weight] -> [Weight]
forall a. Int -> [a] -> [a]
take ([Weight] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Weight]
seated) ((Weight -> Down Weight) -> [Weight] -> [Weight]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Weight -> Down Weight
forall a. a -> Down a
Down [Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s Integer -> Integer -> Weight
forall a. Integral a => a -> a -> Ratio a
% Integer
1 | Word64
s <- [Word64]
stakes])
in (Weight -> Down Weight) -> [Weight] -> [Weight]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Weight -> Down Weight
forall a. a -> Down a
Down [Weight]
seated [Weight] -> [Weight] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [Weight]
topWeights
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"an excluded pool outweighs a seated one, seated: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Weight] -> String
forall a. Show a => a -> String
show [Weight]
seated)
String -> (Positive Int -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"equal stakes are seated by ascending pool id" ((Positive Int -> Property) -> Spec)
-> (Positive Int -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
\(Positive Int
poolCount) ->
let n :: Int
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
poolCount Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
keyed :: [(LeiosCandidate, BlsKey)]
keyed =
((LeiosCandidate, BlsKey) -> KeyHash StakePool)
-> [(LeiosCandidate, BlsKey)] -> [(LeiosCandidate, BlsKey)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
(LeiosCandidate -> KeyHash StakePool
lcPoolId (LeiosCandidate -> KeyHash StakePool)
-> ((LeiosCandidate, BlsKey) -> LeiosCandidate)
-> (LeiosCandidate, BlsKey)
-> KeyHash StakePool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LeiosCandidate, BlsKey) -> LeiosCandidate
forall a b. (a, b) -> a
fst)
[(Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
i Word64
1 (BlsKeyState -> StrictMaybe BlsKeyState
forall a. a -> StrictMaybe a
SJust (Int -> EpochNo -> BlsKeyState
keyState Int
i (Word64 -> EpochNo
EpochNo Word64
0))), Int -> BlsKey
validKey Int
i) | Int
i <- [Int
1 .. Int
n]]
candidates :: [LeiosCandidate]
candidates = ((LeiosCandidate, BlsKey) -> LeiosCandidate)
-> [(LeiosCandidate, BlsKey)] -> [LeiosCandidate]
forall a b. (a -> b) -> [a] -> [b]
map (LeiosCandidate, BlsKey) -> LeiosCandidate
forall a b. (a, b) -> a
fst [(LeiosCandidate, BlsKey)]
keyed
seated :: [LeiosVerificationKey]
seated = [LeiosVerificationKey
vk | LeiosSeat Weight
_ (SJust LeiosVerificationKey
vk) <- Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) [LeiosCandidate]
candidates]
in [LeiosVerificationKey]
seated [LeiosVerificationKey] -> [LeiosVerificationKey] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [BlsKey -> LeiosVerificationKey
blsPubKey BlsKey
key | (LeiosCandidate
_, BlsKey
key) <- [(LeiosCandidate, BlsKey)]
keyed]
String -> (Int -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"a pool with no registered key gets a keyless seat" ((Int -> Property) -> Spec) -> (Int -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
\(Int
poolId :: Int) ->
(LeiosSeat -> StrictMaybe LeiosVerificationKey)
-> [LeiosSeat] -> [StrictMaybe LeiosVerificationKey]
forall a b. (a -> b) -> [a] -> [b]
map LeiosSeat -> StrictMaybe LeiosVerificationKey
seatVKey (Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf Word16
1 [Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
poolId Word64
1 StrictMaybe BlsKeyState
forall a. StrictMaybe a
SNothing]) [StrictMaybe LeiosVerificationKey]
-> [StrictMaybe LeiosVerificationKey] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [StrictMaybe LeiosVerificationKey
forall a. StrictMaybe a
SNothing]
String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a key whose proof of possession does not verify is seated keyless" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$
let mismatched :: BlsKey
mismatched = (Int -> BlsKey
validKey Int
1) {blsPossessionProof = blsPossessionProof (validKey 2)}
candidate :: LeiosCandidate
candidate = Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
0 Word64
1 (BlsKeyState -> StrictMaybe BlsKeyState
forall a. a -> StrictMaybe a
SJust (BlsKey -> EpochNo -> BlsKeyState
BlsKeyState BlsKey
mismatched (Word64 -> EpochNo
EpochNo Word64
0)))
in (LeiosSeat -> StrictMaybe LeiosVerificationKey)
-> [LeiosSeat] -> [StrictMaybe LeiosVerificationKey]
forall a b. (a -> b) -> [a] -> [b]
map LeiosSeat -> StrictMaybe LeiosVerificationKey
seatVKey (Word16 -> [LeiosCandidate] -> [LeiosSeat]
seatsOf Word16
1 [LeiosCandidate
candidate]) [StrictMaybe LeiosVerificationKey]
-> [StrictMaybe LeiosVerificationKey] -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` [StrictMaybe LeiosVerificationKey
forall a. StrictMaybe a
SNothing]
String -> (Int -> EpochNo -> Positive Word32 -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"a key is seated while honoured and keyless once it ages out" ((Int -> EpochNo -> Positive Word32 -> Property) -> Spec)
-> (Int -> EpochNo -> Positive Word32 -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
\(Int
poolId :: Int) (EpochNo
registeredIn :: EpochNo) (Positive Word32
ageWord) ->
let maxKeyAge :: EpochInterval
maxKeyAge = Word32 -> EpochInterval
EpochInterval (Word32
ageWord :: Word32)
candidate :: LeiosCandidate
candidate = Int -> Word64 -> StrictMaybe BlsKeyState -> LeiosCandidate
candidateWith Int
poolId Word64
1 (BlsKeyState -> StrictMaybe BlsKeyState
forall a. a -> StrictMaybe a
SJust (Int -> EpochNo -> BlsKeyState
keyState Int
7 EpochNo
registeredIn))
keysAt :: EpochNo -> [StrictMaybe LeiosVerificationKey]
keysAt EpochNo
e =
(LeiosSeat -> StrictMaybe LeiosVerificationKey)
-> [LeiosSeat] -> [StrictMaybe LeiosVerificationKey]
forall a b. (a -> b) -> [a] -> [b]
map LeiosSeat -> StrictMaybe LeiosVerificationKey
seatVKey
([LeiosSeat] -> [StrictMaybe LeiosVerificationKey])
-> (LeiosCommittee -> [LeiosSeat])
-> LeiosCommittee
-> [StrictMaybe LeiosVerificationKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector LeiosSeat -> [LeiosSeat]
forall a. Vector a -> [a]
VS.toList
(Vector LeiosSeat -> [LeiosSeat])
-> (LeiosCommittee -> Vector LeiosSeat)
-> LeiosCommittee
-> [LeiosSeat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosCommittee -> Vector LeiosSeat
leiosCommitteeSeats
(LeiosCommittee -> [StrictMaybe LeiosVerificationKey])
-> LeiosCommittee -> [StrictMaybe LeiosVerificationKey]
forall a b. (a -> b) -> a -> b
$ EpochNo
-> EpochInterval
-> Word16
-> Vector LeiosCandidate
-> LeiosCommittee
selectLeiosCommittee EpochNo
e EpochInterval
maxKeyAge Word16
1 ([LeiosCandidate] -> Vector LeiosCandidate
forall a. [a] -> Vector a
V.fromList [LeiosCandidate
candidate])
boundary :: EpochNo
boundary = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
registeredIn EpochInterval
maxKeyAge
in [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
[ EpochNo -> [StrictMaybe LeiosVerificationKey]
keysAt EpochNo
registeredIn [StrictMaybe LeiosVerificationKey]
-> [StrictMaybe LeiosVerificationKey] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [LeiosVerificationKey -> StrictMaybe LeiosVerificationKey
forall a. a -> StrictMaybe a
SJust (BlsKey -> LeiosVerificationKey
blsPubKey (Int -> BlsKey
validKey Int
7))]
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"not honoured in its registration epoch"
, EpochNo -> [StrictMaybe LeiosVerificationKey]
keysAt EpochNo
boundary [StrictMaybe LeiosVerificationKey]
-> [StrictMaybe LeiosVerificationKey] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [StrictMaybe LeiosVerificationKey
forall a. StrictMaybe a
SNothing]
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"still honoured at the expiry boundary"
]