diff --git a/cardano-crypto-peras/CHANGELOG.md b/cardano-crypto-peras/CHANGELOG.md index ced26b8a3..7a41fe08c 100644 --- a/cardano-crypto-peras/CHANGELOG.md +++ b/cardano-crypto-peras/CHANGELOG.md @@ -1,8 +1,21 @@ # Changelog for `cardano-crypto-peras` -## 0.1.0.1 +## 0.2.0.0 -* +* Add the Peras certificate types +* Add `PerasVotersBitmap`, the voters bitmap with its inclusive upper bound, built on + `Data.Bitmap` from `cardano-strict-containers` +* Remove the placeholder `BoostedBlock`; rename `pcBostedBlock` to `pcBoostedBlock` +* No CBOR instances, matching `cardano-crypto-leios`: `EncCBOR`/`DecCBOR` instances are + provided by `cardano-ledger-binary` +* Change `PerasRoundNo`'s representation from `Word64` to `Word32` +* Add `Cardano.Crypto.Peras.Vote` (`PerasVote`, `PerasVoteEligibilityProof`) +* Add `PerasCertSize` and `perasCertSizeUpperBound` to `Cardano.Crypto.Peras.Cert` + +### `testlib` + +* Add `Test.Cardano.Crypto.Peras.Gen` +* Add `genPerasVote`, `genPerasVoteEligibilityProof` ## 0.1.0.0 diff --git a/cardano-crypto-peras/README.md b/cardano-crypto-peras/README.md index 88b426358..ccd019d3a 100644 --- a/cardano-crypto-peras/README.md +++ b/cardano-crypto-peras/README.md @@ -7,3 +7,11 @@ needed by layers other than Consensus: coordinate the end of a cooldown. Since this addition ultimately affects block sizes (and block size checks live in Ledger), the best place to store these certificates is at the Ledger level. +- **Peras votes**: the individual, per-committee-member votes that + certificates aggregate. + +Base types live in `Cardano.Crypto.Peras`, certificates in +`Cardano.Crypto.Peras.Cert`, and votes in `Cardano.Crypto.Peras.Vote`. This +package does not provide CBOR instances for these types (matching +`cardano-crypto-leios`): `EncCBOR`/`DecCBOR` instances are provided by +`cardano-ledger-binary` instead. diff --git a/cardano-crypto-peras/cardano-crypto-peras.cabal b/cardano-crypto-peras/cardano-crypto-peras.cabal index 3ef6281e1..3bfdd3de1 100644 --- a/cardano-crypto-peras/cardano-crypto-peras.cabal +++ b/cardano-crypto-peras/cardano-crypto-peras.cabal @@ -1,8 +1,11 @@ cabal-version: 3.0 name: cardano-crypto-peras -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Crypto primitives for Peras description: + Data types and wire format for Peras certificates, shared by cardano-ledger and + ouroboros-consensus. + license: Apache-2.0 license-files: LICENSE @@ -37,8 +40,50 @@ library exposed-modules: Cardano.Crypto.Peras Cardano.Crypto.Peras.Cert + Cardano.Crypto.Peras.Vote build-depends: - base, + bytestring, + cardano-binary >=1.9.1, + cardano-crypto-class >=2.6, + cardano-slotting, + cardano-strict-containers >=0.1.7, + deepseq, nothunks, quiet, + serialise, + +library testlib + import: base, project-config + visibility: public + hs-source-dirs: testlib + exposed-modules: + Test.Cardano.Crypto.Peras.Gen + + build-depends: + QuickCheck, + bytestring, + cardano-base:testlib, + cardano-crypto-class:{cardano-crypto-class, testlib}, + cardano-crypto-peras, + cardano-slotting, + +test-suite tests + import: base, project-config + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Test.Cardano.Crypto.Peras + + build-depends: + QuickCheck, + bytestring, + cardano-crypto-class, + cardano-crypto-peras:{cardano-crypto-peras, testlib}, + cardano-slotting, + hspec, + + ghc-options: + -threaded + -rtsopts diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras.hs index 8300439e8..9bda3985a 100644 --- a/cardano-crypto-peras/src/Cardano/Crypto/Peras.hs +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras.hs @@ -1,15 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} module Cardano.Crypto.Peras ( -- * Peras round numbers PerasRoundNo (..), onPerasRoundNo, + PerasSeatIndex (..), + maxPerasSeatIndex, + PerasBlockRef (..), + perasBlockHashSize, + mkPerasBlockRef, + PerasBoostedBlock (..), + PerasDSIGN, + PerasSigningKey, + PerasVerificationKey, + PerasSignature (..), + PerasVRFOutput (..), + perasSignatureSize, + perasSignatureToBytes, + perasVRFOutputToBytes, ) where +import Cardano.Binary.FixedSizeCodec (fixedSize, rawEncodeFixedSized) +import Cardano.Crypto.DSIGN (SigDSIGN, SignKeyDSIGN, VerKeyDSIGN) +import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN) +import Cardano.Slotting.Slot (SlotNo, WithOrigin) +import Codec.Serialise (Serialise) +import Control.DeepSeq (NFData) +import Data.ByteString (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SBS import Data.Coerce (coerce) -import Data.Word (Word64) +import Data.Ord (comparing) +import Data.Proxy (Proxy (..)) +import Data.Word (Word16, Word32) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) import Quiet (Quiet (..)) @@ -18,13 +47,92 @@ import Quiet (Quiet (..)) Peras round numbers -------------------------------------------------------------------------------} -newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word64} +-- | Round number in a Peras election. +newtype PerasRoundNo = PerasRoundNo {unPerasRoundNo :: Word32} deriving (Show) via Quiet PerasRoundNo deriving stock (Generic) - deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks) + deriving newtype (Enum, Eq, Ord, Num, Bounded, NoThunks, NFData, Serialise) --- | Lift a binary operation on 'Word64' to 'PerasRoundNo' +-- | Lift a binary operation on 'Word32' to 'PerasRoundNo' onPerasRoundNo :: - (Word64 -> Word64 -> Word64) -> + (Word32 -> Word32 -> Word32) -> (PerasRoundNo -> PerasRoundNo -> PerasRoundNo) onPerasRoundNo = coerce + +{------------------------------------------------------------------------------- + Seat indices +-------------------------------------------------------------------------------} + +-- | Seat index in the voting committee used for Peras +newtype PerasSeatIndex = PerasSeatIndex {unPerasSeatIndex :: Word16} + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (Enum, Bounded, NoThunks, NFData) + +maxPerasSeatIndex :: PerasSeatIndex +maxPerasSeatIndex = maxBound + +{------------------------------------------------------------------------------- + Block references +-------------------------------------------------------------------------------} + +-- | A reference to a block: its slot number and 32-byte hash. +-- +-- NOTE: this is intended to be equivalent to a @Point blk@ when +-- @HeaderHash blk ~ ShortByteString@. +data PerasBlockRef = PerasBlockRef + { pbrSlot :: !SlotNo + , pbrHash :: !ShortByteString + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NoThunks, NFData) + +perasBlockHashSize :: Int +perasBlockHashSize = 32 + +mkPerasBlockRef :: SlotNo -> ShortByteString -> Maybe PerasBlockRef +mkPerasBlockRef slot hash + | SBS.length hash == perasBlockHashSize = Just (PerasBlockRef slot hash) + | otherwise = Nothing + +-- | The slot number and 32-byte hash of the block being voted for. +newtype PerasBoostedBlock = PerasBoostedBlock {unPerasBoostedBlock :: WithOrigin PerasBlockRef} + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (NoThunks, NFData) + +{------------------------------------------------------------------------------- + BLS cryptography +-------------------------------------------------------------------------------} + +type PerasDSIGN = BLS12381MinSigDSIGN + +type PerasSigningKey = SignKeyDSIGN PerasDSIGN + +type PerasVerificationKey = VerKeyDSIGN PerasDSIGN + +newtype PerasSignature = PerasSignature {unPerasSignature :: SigDSIGN PerasDSIGN} + deriving stock (Show, Eq, Generic) + deriving newtype (NoThunks, NFData) + +-- | 'SigDSIGN PerasDSIGN' (an elliptic curve point) has no natural total +-- order to derive an 'Ord' instance from (unlike 'Eq', which +-- @cardano-crypto-class@ provides via curve-point equality), so we compare on +-- the fixed-size wire encoding instead. +instance Ord PerasSignature where + compare = comparing perasSignatureToBytes + +newtype PerasVRFOutput = PerasVRFOutput {unPerasVRFOutput :: SigDSIGN PerasDSIGN} + deriving stock (Show, Eq, Generic) + deriving newtype (NoThunks, NFData) + +-- | See the 'Ord PerasSignature' instance: no derivable 'Ord' exists either. +instance Ord PerasVRFOutput where + compare = comparing perasVRFOutputToBytes + +perasSignatureSize :: Word +perasSignatureSize = fixedSize (Proxy @(SigDSIGN PerasDSIGN)) + +perasSignatureToBytes :: PerasSignature -> ByteString +perasSignatureToBytes = rawEncodeFixedSized . unPerasSignature + +perasVRFOutputToBytes :: PerasVRFOutput -> ByteString +perasVRFOutputToBytes = rawEncodeFixedSized . unPerasVRFOutput diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs index 022517efd..30b30561a 100644 --- a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs @@ -1,32 +1,200 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} module Cardano.Crypto.Peras.Cert ( - -- * Peras certificates + PerasVotersBitmap (..), + mkPerasVotersBitmap, + perasVotersBitmapFromSeats, + perasVotersBitmapSeats, + perasVotersBitmapSize, + PerasCertVoters (..), + mkPerasCertVoters, + perasCertVotersFromSeats, + perasCertVotersToSeats, + perasCertNumberOfVoters, + perasCertNumberOfNonPersistentVoters, + perasCertNumberOfPersistentVoters, PerasCert (..), + PerasRoundNo (..), + PerasBoostedBlock (..), + PerasSignature (..), + PerasVRFOutput (..), + PerasCertSize (..), + perasCertSizeUpperBound, ) where -import Cardano.Crypto.Peras (PerasRoundNo) +import Cardano.Crypto.Peras ( + PerasBoostedBlock (..), + PerasRoundNo (..), + PerasSeatIndex (..), + PerasSignature (..), + PerasVRFOutput (..), + ) +import Control.DeepSeq (NFData) +import Control.Monad (unless, when) +import Data.Bitmap (Bitmap) +import qualified Data.Bitmap as Bitmap +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (catMaybes, isJust, isNothing) +import Data.Word (Word16, Word32) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) {------------------------------------------------------------------------------- - Peras certificates + Voters bitmap -------------------------------------------------------------------------------} --- | Opaque type representing a boosted block. --- --- NOTE: this will be fleshed out in the future. -data BoostedBlock = BoostedBlock - deriving (Eq, Show, Generic, NoThunks) +data PerasVotersBitmap = UnsafePerasVotersBitmap + { perasVotersMaxIndex :: !Word16 + , perasVotersBits :: !Bitmap + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NoThunks, NFData) + +mkPerasVotersBitmap :: Word16 -> Bitmap -> Maybe PerasVotersBitmap +mkPerasVotersBitmap maxIx bs + | Bitmap.wellFormed (fromIntegral maxIx + 1) bs = Just (UnsafePerasVotersBitmap maxIx bs) + | otherwise = Nothing + +perasVotersBitmapFromSeats :: Word16 -> [PerasSeatIndex] -> PerasVotersBitmap +perasVotersBitmapFromSeats maxIx seats = + UnsafePerasVotersBitmap maxIx $ + Bitmap.fromIndices (fromIntegral maxIx + 1) (fromIntegral . unPerasSeatIndex <$> seats) --- | A Peras certificate indicating that a node has received a weight boost. +perasVotersBitmapSeats :: PerasVotersBitmap -> [PerasSeatIndex] +perasVotersBitmapSeats (UnsafePerasVotersBitmap maxIx bs) = + PerasSeatIndex . fromIntegral <$> Bitmap.toIndices (fromIntegral maxIx + 1) bs + +perasVotersBitmapSize :: PerasVotersBitmap -> Int +perasVotersBitmapSize = Bitmap.numSetBits . perasVotersBits + +{------------------------------------------------------------------------------- + Voters +-------------------------------------------------------------------------------} + +-- | Compact representation of the voters in a Peras certificate. -- --- NOTE: this will be fleshed out in the future. +-- This compact representation consists of a bitmap of voter seat indices and a +-- list of non-persistent eligibility proofs (VRF outputs). In this setup, the +-- last @np@ indices in the bitmap that are flipped to 1 correspond to +-- non-persistent voters, where @np@ is the length of the list of non-persistent +-- eligibility proofs. The remaining flipped indices in the bitmap correspond +-- to persistent voters. +data PerasCertVoters = UnsafePerasCertVoters + { perasCertVotersBitmap :: !PerasVotersBitmap + , perasCertNonPersistentVRFOutputs :: ![PerasVRFOutput] + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NoThunks, NFData) + +mkPerasCertVoters :: PerasVotersBitmap -> [PerasVRFOutput] -> Either String PerasCertVoters +mkPerasCertVoters bitmap vrfOutputs = do + let numVoters = perasVotersBitmapSize bitmap + numProofs = length vrfOutputs + when (numVoters == 0) $ + Left "Invalid Peras certificate: empty voters bitmap" + when (numProofs > numVoters) $ + Left $ + unlines + [ "Invalid Peras certificate:" + <> " more non-persistent voter eligibility proofs were provided" + <> " than the number of voters in the certificate" + , " * number of voters: " + <> show numVoters + , " * number of proofs: " + <> show numProofs + ] + pure (UnsafePerasCertVoters bitmap vrfOutputs) + +perasCertVotersToSeats :: PerasCertVoters -> NonEmpty (PerasSeatIndex, Maybe PerasVRFOutput) +perasCertVotersToSeats voters@UnsafePerasCertVoters {perasCertVotersBitmap, perasCertNonPersistentVRFOutputs} = + case zip seats proofs of + [] -> + error "perasCertVotersToSeats: empty voters bitmap (invariant violated via UnsafePerasCertVoters)" + x : xs -> x :| xs + where + seats = perasVotersBitmapSeats perasCertVotersBitmap + numPersistent = perasCertNumberOfPersistentVoters voters + proofs = replicate numPersistent Nothing <> fmap Just perasCertNonPersistentVRFOutputs + +perasCertVotersFromSeats :: + NonEmpty (PerasSeatIndex, Maybe PerasVRFOutput) -> + Either String PerasCertVoters +perasCertVotersFromSeats seats = do + let sorted = sortOn fst (NonEmpty.toList seats) + indices = unPerasSeatIndex . fst <$> sorted + proofs = snd <$> sorted + when (any (uncurry (==)) (zip indices (drop 1 indices))) $ + Left "Invalid Peras certificate voters: duplicate seat index" + unless (all isJust (dropWhile isNothing proofs)) $ + Left "Invalid Peras certificate voters: persistent voter after a non-persistent one" + let bitmap = perasVotersBitmapFromSeats (last indices) (fst <$> sorted) + mkPerasCertVoters bitmap (catMaybes proofs) + +perasCertNumberOfVoters :: PerasCertVoters -> Int +perasCertNumberOfVoters = perasVotersBitmapSize . perasCertVotersBitmap + +perasCertNumberOfNonPersistentVoters :: PerasCertVoters -> Int +perasCertNumberOfNonPersistentVoters = length . perasCertNonPersistentVRFOutputs + +perasCertNumberOfPersistentVoters :: PerasCertVoters -> Int +perasCertNumberOfPersistentVoters voters = + perasCertNumberOfVoters voters - perasCertNumberOfNonPersistentVoters voters + +{------------------------------------------------------------------------------- + Certificates +-------------------------------------------------------------------------------} + +-- | Concrete Peras certificates using BLS signatures data PerasCert = PerasCert { pcRoundNo :: !PerasRoundNo - -- ^ Round number - , pcBostedBlock :: !BoostedBlock - -- ^ The block that received the boost + -- ^ Election identifier + , pcBoostedBlock :: !PerasBoostedBlock + -- ^ Certificate message, i.e., the hash of the block being boosted + , pcVoters :: !PerasCertVoters + -- ^ Voters who contributed to this certificate + , pcSignature :: !PerasSignature + -- ^ Aggregate BLS signature on the hash of the election identifier and + -- the certificate message } - deriving (Eq, Show, Generic, NoThunks) + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NoThunks, NFData) + +-- | Size of a serialised 'PerasCert', in bytes. +newtype PerasCertSize = PerasCertSize {unPerasCertSize :: Word32} + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (NoThunks, NFData) + deriving (Enum, Real, Integral, Num) via Word32 + +-- | An upper bound (not necessarily tight) on the size, in bytes, of a +-- serialised 'PerasCert'. +-- +-- The three constants below are themselves upper bounds (in bits, not +-- bytes) on the CBOR encoding of the certificate's fixed overhead, of each +-- voter's contribution to the voters bitmap, and of each non-persistent +-- voter's additional VRF output, respectively. For their derivation, see +-- . +perasCertSizeUpperBound :: PerasCert -> PerasCertSize +perasCertSizeUpperBound cert = + PerasCertSize . fromIntegral $ + (`divCeiling` 8) $ + constSize + + numVoters * sizePerVoter + + numNonPersistentVoters * extraSizePerNonPersistentVoter + where + numNonPersistentVoters = perasCertNumberOfNonPersistentVoters (pcVoters cert) + numVoters = perasCertNumberOfVoters (pcVoters cert) + + constSize = 135 * 8 + sizePerVoter = 1 + extraSizePerNonPersistentVoter = 50 * 8 + + divCeiling n d = q + min 1 r + where + (q, r) = n `quotRem` d diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Vote.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Vote.hs new file mode 100644 index 000000000..4a80bdbe0 --- /dev/null +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Vote.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} + +module Cardano.Crypto.Peras.Vote ( + PerasVote (..), + PerasVoteEligibilityProof (..), +) where + +import Cardano.Crypto.Peras ( + PerasBoostedBlock (..), + PerasRoundNo (..), + PerasSeatIndex (..), + PerasSignature (..), + PerasVRFOutput (..), + ) +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +{------------------------------------------------------------------------------- + Votes +-------------------------------------------------------------------------------} + +-- | An individual vote cast by a single committee member, prior to +-- aggregation into a 'Cardano.Crypto.Peras.Cert.PerasCert'. +data PerasVote = PerasVote + { pvRoundNo :: !PerasRoundNo + -- ^ Election identifier + , pvBoostedBlock :: !PerasBoostedBlock + -- ^ Vote message, i.e., the hash of the block being voted for + , pvSeatIndex :: !PerasSeatIndex + -- ^ Seat index assigned to the committee member (identifies the voter) + , pvEligibilityProof :: !PerasVoteEligibilityProof + -- ^ Proof of eligibility for voting, depending on the type of membership to + -- the committee (persistent vs non-persistent) + , pvSignature :: !PerasSignature + -- ^ BLS signature on the hash of the election identifier and vote message + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NoThunks, NFData) + +-- | A committee member's proof of eligibility to vote in a given round. +-- +-- Persistent voters were sampled once for the whole committee's lifetime and +-- need no further proof; non-persistent voters were sampled for this round +-- only and carry the VRF output that proves it. +data PerasVoteEligibilityProof + = PersistentPerasVoteEligibilityProof + | NonPersistentPerasVoteEligibilityProof !PerasVRFOutput + deriving stock (Show, Eq, Generic) + deriving anyclass (NoThunks, NFData) diff --git a/cardano-crypto-peras/test/Main.hs b/cardano-crypto-peras/test/Main.hs new file mode 100644 index 000000000..e1e627988 --- /dev/null +++ b/cardano-crypto-peras/test/Main.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import qualified Test.Cardano.Crypto.Peras +import Test.Hspec (hspec) +import Prelude + +main :: IO () +main = hspec Test.Cardano.Crypto.Peras.spec diff --git a/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs b/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs new file mode 100644 index 000000000..4985df634 --- /dev/null +++ b/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Crypto.Peras (spec) where + +import Cardano.Crypto.DSIGN (deriveVerKeyDSIGN, signDSIGN, verifyDSIGN) +import Cardano.Crypto.Peras ( + PerasBoostedBlock (..), + PerasSeatIndex (..), + PerasSignature (..), + PerasSigningKey, + ) +import Cardano.Crypto.Peras.Cert ( + PerasCert (..), + PerasCertSize (..), + mkPerasCertVoters, + perasCertNumberOfNonPersistentVoters, + perasCertNumberOfPersistentVoters, + perasCertNumberOfVoters, + perasCertSizeUpperBound, + perasCertVotersFromSeats, + perasCertVotersToSeats, + perasVotersBitmapFromSeats, + ) +import Cardano.Crypto.Peras.Vote ( + PerasVote (..), + PerasVoteEligibilityProof (..), + ) +import Cardano.Slotting.Slot (WithOrigin (..)) +import qualified Data.ByteString as BS +import Data.Either (isLeft) +import qualified Data.List.NonEmpty as NonEmpty +import Test.Cardano.Crypto.Peras.Gen ( + genPerasCert, + genPerasCertVoters, + genPerasVRFOutput, + perasSigningKeyFromSeedByte, + ) +import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ( + forAll, + vectorOf, + (===), + ) + +spec :: Spec +spec = do + describe "PerasCertVoters" $ do + prop "perasCertVotersFromSeats . perasCertVotersToSeats" $ + forAll (genPerasCertVoters True) $ \v -> + perasCertVotersFromSeats (perasCertVotersToSeats v) === Right v + prop "counts voters" $ + forAll (genPerasCertVoters True) $ \v -> + let seats = perasCertVotersToSeats v + in ( perasCertNumberOfVoters v + , perasCertNumberOfNonPersistentVoters v + , perasCertNumberOfPersistentVoters v + ) + === ( length seats + , length (NonEmpty.filter ((/= Nothing) . snd) seats) + , length (NonEmpty.filter ((== Nothing) . snd) seats) + ) + prop "rejects a persistent voter after a non-persistent one" $ + forAll genPerasVRFOutput $ \vrf -> + perasCertVotersFromSeats + (NonEmpty.fromList [(PerasSeatIndex 0, Just vrf), (PerasSeatIndex 1, Nothing)]) + `shouldSatisfy` isLeft + prop "rejects a duplicate seat index" $ + forAll genPerasVRFOutput $ \vrf -> + perasCertVotersFromSeats + (NonEmpty.fromList [(PerasSeatIndex 3, Nothing), (PerasSeatIndex 3, Just vrf)]) + `shouldSatisfy` isLeft + it "rejects an empty bitmap" $ + mkPerasCertVoters (perasVotersBitmapFromSeats 7 []) [] `shouldSatisfy` isLeft + prop "rejects more VRF outputs than voters" $ + forAll (vectorOf 2 genPerasVRFOutput) $ \vrfs -> + mkPerasCertVoters (perasVotersBitmapFromSeats 7 [PerasSeatIndex 3]) vrfs `shouldSatisfy` isLeft + + describe "PerasCert" $ do + it "the minimal certificate's signature verifies under its key" $ + verifyDSIGN + () + (deriveVerKeyDSIGN minimalCertKey) + minimalCertMessage + (unPerasSignature (pcSignature minimalCert)) + `shouldBe` Right () + it "computes the upper bound for the minimal certificate" $ + perasCertSizeUpperBound minimalCert `shouldBe` PerasCertSize 136 + prop "perasCertSizeUpperBound is at least the constant overhead" $ + forAll (genPerasCert True) $ \c -> + unPerasCertSize (perasCertSizeUpperBound c) >= 136 + + describe "PerasVote" $ do + it "a vote's signature verifies under its key" $ + verifyDSIGN + () + (deriveVerKeyDSIGN minimalVoteKey) + minimalVoteMessage + (unPerasSignature (pvSignature minimalVote)) + `shouldBe` Right () + +minimalCert :: PerasCert +minimalCert = + PerasCert + { pcRoundNo = 0 + , pcBoostedBlock = PerasBoostedBlock Origin + , pcVoters = either error id (mkPerasCertVoters (perasVotersBitmapFromSeats 0 [PerasSeatIndex 0]) []) + , pcSignature = PerasSignature (signDSIGN () minimalCertMessage minimalCertKey) + } + +minimalCertKey :: PerasSigningKey +minimalCertKey = perasSigningKeyFromSeedByte 0x2a + +minimalCertMessage :: BS.ByteString +minimalCertMessage = "peras-golden-message" + +minimalVote :: PerasVote +minimalVote = + PerasVote + { pvRoundNo = 0 + , pvBoostedBlock = PerasBoostedBlock Origin + , pvSeatIndex = PerasSeatIndex 0 + , pvEligibilityProof = PersistentPerasVoteEligibilityProof + , pvSignature = PerasSignature (signDSIGN () minimalVoteMessage minimalVoteKey) + } + +minimalVoteKey :: PerasSigningKey +minimalVoteKey = perasSigningKeyFromSeedByte 0x2b + +minimalVoteMessage :: BS.ByteString +minimalVoteMessage = "peras-golden-vote-message" diff --git a/cardano-crypto-peras/testlib/Test/Cardano/Crypto/Peras/Gen.hs b/cardano-crypto-peras/testlib/Test/Cardano/Crypto/Peras/Gen.hs new file mode 100644 index 000000000..73c10b690 --- /dev/null +++ b/cardano-crypto-peras/testlib/Test/Cardano/Crypto/Peras/Gen.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Crypto.Peras.Gen ( + genPerasSigningKey, + perasSigningKeyFromSeedByte, + genPerasSignature, + genPerasVRFOutput, + genPerasRoundNo, + genPerasSeatIndex, + genPerasBlockRef, + genPerasBoostedBlock, + genPerasCertVoters, + genPerasCert, + genPerasVoteEligibilityProof, + genPerasVote, + generateWith, +) where + +import Cardano.Crypto.DSIGN (SigDSIGN, genKeyDSIGN, seedSizeDSIGN, signDSIGN) +import Cardano.Crypto.Peras ( + PerasBlockRef (..), + PerasBoostedBlock (..), + PerasDSIGN, + PerasRoundNo (..), + PerasSeatIndex (..), + PerasSignature (..), + PerasSigningKey, + PerasVRFOutput (..), + perasBlockHashSize, + ) +import Cardano.Crypto.Peras.Cert ( + PerasCert (..), + PerasCertVoters, + perasCertVotersFromSeats, + ) +import Cardano.Crypto.Peras.Vote ( + PerasVote (..), + PerasVoteEligibilityProof (..), + ) +import Cardano.Crypto.Seed (mkSeedFromBytes) +import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy (..)) +import Data.Word (Word16, Word8) +import Test.Cardano.Base.Bytes (genByteString) +import Test.Crypto.Util (arbitrarySeedOfSize) +import Test.QuickCheck (Gen, arbitrary, choose, frequency, sized) +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random (mkQCGen) + +genPerasSigningKey :: Gen PerasSigningKey +genPerasSigningKey = do + seed <- arbitrarySeedOfSize (seedSizeDSIGN (Proxy @PerasDSIGN)) + pure $ genKeyDSIGN seed + +perasSigningKeyFromSeedByte :: Word8 -> PerasSigningKey +perasSigningKeyFromSeedByte b = + genKeyDSIGN $ + mkSeedFromBytes $ + BS.replicate (fromIntegral (seedSizeDSIGN (Proxy @PerasDSIGN))) b + +genRawSignature :: Gen (SigDSIGN PerasDSIGN) +genRawSignature = do + sk <- genPerasSigningKey + msgLen <- choose (0, 256) + msg <- genByteString msgLen + pure $ signDSIGN () msg sk + +genPerasSignature :: Gen PerasSignature +genPerasSignature = PerasSignature <$> genRawSignature + +genPerasVRFOutput :: Gen PerasVRFOutput +genPerasVRFOutput = PerasVRFOutput <$> genRawSignature + +genPerasRoundNo :: Gen PerasRoundNo +genPerasRoundNo = PerasRoundNo <$> arbitrary + +genPerasSeatIndex :: Gen PerasSeatIndex +genPerasSeatIndex = PerasSeatIndex <$> arbitrary + +genPerasBlockRef :: Gen PerasBlockRef +genPerasBlockRef = + PerasBlockRef + <$> (SlotNo <$> arbitrary) + <*> (SBS.toShort <$> genByteString perasBlockHashSize) + +genPerasBoostedBlock :: Gen PerasBoostedBlock +genPerasBoostedBlock = + PerasBoostedBlock + <$> frequency + [ (1, pure Origin) + , (9, At <$> genPerasBlockRef) + ] + +genPerasCertVoters :: Bool -> Gen PerasCertVoters +genPerasCertVoters allowNonPersistent = do + numVoters <- sized $ \size -> (+ 1) <$> choose @Word16 (0, fromIntegral (min size 400) * 4) + numPersistent <- + if allowNonPersistent + then choose (0, numVoters) + else pure numVoters + let persistent = [(PerasSeatIndex i, Nothing) | i <- take (fromIntegral numPersistent) [0 ..]] + nonPersistent <- + mapM + (\i -> (,) (PerasSeatIndex i) . Just <$> genPerasVRFOutput) + (take (fromIntegral (numVoters - numPersistent)) [numPersistent ..]) + kept <- dropSome False (persistent <> nonPersistent) + either error pure $ perasCertVotersFromSeats (NonEmpty.fromList kept) + where + dropSome _ [] = pure [] + dropSome canDrop (x : xs) = do + keep <- frequency [(75, pure True), (if canDrop then 25 else 0, pure False)] + rest <- dropSome (canDrop || keep) xs + pure $ catMaybes [if keep then Just x else Nothing] <> rest + +genPerasCert :: Bool -> Gen PerasCert +genPerasCert allowNonPersistent = + PerasCert + <$> genPerasRoundNo + <*> genPerasBoostedBlock + <*> genPerasCertVoters allowNonPersistent + <*> genPerasSignature + +genPerasVoteEligibilityProof :: Gen PerasVoteEligibilityProof +genPerasVoteEligibilityProof = + frequency + [ (1, pure PersistentPerasVoteEligibilityProof) + , (1, NonPersistentPerasVoteEligibilityProof <$> genPerasVRFOutput) + ] + +genPerasVote :: Gen PerasVote +genPerasVote = + PerasVote + <$> genPerasRoundNo + <*> genPerasBoostedBlock + <*> genPerasSeatIndex + <*> genPerasVoteEligibilityProof + <*> genPerasSignature + +generateWith :: Integral i => Gen a -> i -> a +generateWith gen seed = unGen gen (mkQCGen (fromIntegral seed)) 30 diff --git a/cardano-strict-containers/CHANGELOG.md b/cardano-strict-containers/CHANGELOG.md index b2ba94722..a6b6c1331 100644 --- a/cardano-strict-containers/CHANGELOG.md +++ b/cardano-strict-containers/CHANGELOG.md @@ -1,8 +1,9 @@ # Changelog for `cardano-strict-containers` -## 0.1.6.1 +## 0.1.7.0 -* +* Add `Data.Bitmap`: MSB-first bitmap over `ByteString` for a given number of + indexes, the bit convention of the Leios certificate bitfield (CIP-164) ## 0.1.6.0 diff --git a/cardano-strict-containers/cardano-strict-containers.cabal b/cardano-strict-containers/cardano-strict-containers.cabal index d0c9acb4b..9c53a93b1 100644 --- a/cardano-strict-containers/cardano-strict-containers.cabal +++ b/cardano-strict-containers/cardano-strict-containers.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-strict-containers -version: 0.1.6.0 +version: 0.1.7.0 synopsis: Various strict container types license: Apache-2.0 license-files: @@ -30,6 +30,7 @@ library import: language, warnings hs-source-dirs: src exposed-modules: + Data.Bitmap Data.FingerTree.Strict Data.Maybe.Strict Data.Sequence.Strict @@ -38,6 +39,7 @@ library build-depends: aeson, base, + bytestring, cardano-binary >=1.6, containers, data-default-class, @@ -57,3 +59,24 @@ library testlib QuickCheck, base, cardano-strict-containers, + +test-suite tests + import: language, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Test.Data.Bitmap + + build-depends: + QuickCheck, + base, + bytestring, + cardano-strict-containers, + containers, + hspec, + + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N diff --git a/cardano-strict-containers/src/Data/Bitmap.hs b/cardano-strict-containers/src/Data/Bitmap.hs new file mode 100644 index 000000000..10b9b4086 --- /dev/null +++ b/cardano-strict-containers/src/Data/Bitmap.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A compact bitmap representation using serialisation-ready ByteStrings. +-- +-- Adapted from @Cardano.Leios.BitMapPV@ in the @leios-wfa-ls-demo@ package. +-- +-- NOTE: this module is meant to be imported qualified. +module Data.Bitmap ( + Bitmap (..), + numBytes, + fromIndices, + toIndices, + numSetBits, + wellFormed, +) where + +import Control.DeepSeq (NFData) +import Control.Monad (forM_, when) +import Data.Bits ( + clearBit, + complement, + countLeadingZeros, + popCount, + unsafeShiftL, + (.&.), + (.|.), + ) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Internal as ByteString +import Data.Word (Word8) +import Foreign.Marshal.Utils (fillBytes) +import Foreign.Storable (peekByteOff, pokeByteOff) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) + +-- | A bitmap over a number of indexes known to its users: @⌈n/8⌉@ bytes, +-- MSB-first, bit @i@ set iff index @i@ is set. +newtype Bitmap = Bitmap {bitmapBytes :: ByteString} + deriving stock (Show, Eq, Ord, Generic) + deriving newtype (NFData) + deriving (NoThunks) via OnlyCheckWhnfNamed "Bitmap" Bitmap + +-- | The number of indexes set (flipped to 1) in the bitmap. +numSetBits :: Bitmap -> Int +numSetBits (Bitmap arr) = + sum + [ popCount (ByteString.index arr i) + | i <- [0 .. ByteString.length arr - 1] + ] + +-- | The number of bytes of a bitmap over the given number of indexes. +numBytes :: Int -> Int +numBytes n = (n + 7) `quot` 8 + +lastByteMask :: Int -> Word8 +lastByteMask n = + complement (fromIntegral ((1 :: Int) `unsafeShiftL` (7 - (n - 1) `rem` 8)) - 1) + +-- | Construct a bitmap over the given number of indexes from a list of indexes +-- that should be set (flipped to 1). +fromIndices :: Int -> [Int] -> Bitmap +fromIndices n flipped = + Bitmap $ + ByteString.unsafeCreate nBytes $ \ptr -> do + fillBytes ptr 0 nBytes + forM_ flipped $ \i -> do + when (i >= 0 && i <= maxI) $ do + let !byteIx = i `quot` 8 + let !bitIx = 7 - i `rem` 8 + let !mask = bitMask bitIx + w <- peekByteOff ptr byteIx :: IO Word8 + pokeByteOff ptr byteIx (w .|. mask) + where + !maxI = n - 1 + !nBytes = numBytes n + + bitMask k = fromIntegral ((1 :: Int) `unsafeShiftL` k) + +-- | Retrieve all indexes that are set (flipped to 1) in a bitmap over the given +-- number of indexes, in ascending order. +toIndices :: Int -> Bitmap -> [Int] +toIndices n (Bitmap bitmap) = + goBytes 0 + where + !maxI = n - 1 + !nBytes = ByteString.length bitmap + + goBytes !byteIx + | byteIx >= nBytes = [] + | otherwise = + let !w = ByteString.index bitmap byteIx + in goBits (byteIx * 8) w <> goBytes (byteIx + 1) + + goBits !_ 0 = [] + goBits !base !w = + let !bitIx = countLeadingZeros w + !i = base + bitIx + !w' = clearBit w (7 - bitIx) + in if i <= maxI + then i : goBits base w' + else [] + +-- | Whether a bitmap is well-formed over the given number of indexes: it has +-- the expected length and no bit set beyond the last index. +wellFormed :: Int -> Bitmap -> Bool +wellFormed n (Bitmap bs) + | n <= 0 = False + | ByteString.length bs /= numBytes n = False + | ByteString.last bs .&. complement (lastByteMask n) /= 0 = False + | otherwise = True diff --git a/cardano-strict-containers/test/Main.hs b/cardano-strict-containers/test/Main.hs new file mode 100644 index 000000000..0e95242fc --- /dev/null +++ b/cardano-strict-containers/test/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import qualified Test.Data.Bitmap +import Test.Hspec (describe, hspec) + +main :: IO () +main = hspec $ describe "cardano-strict-containers" Test.Data.Bitmap.spec diff --git a/cardano-strict-containers/test/Test/Data/Bitmap.hs b/cardano-strict-containers/test/Test/Data/Bitmap.hs new file mode 100644 index 000000000..1f09c3873 --- /dev/null +++ b/cardano-strict-containers/test/Test/Data/Bitmap.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Property-based tests for 'Data.Bitmap' +module Test.Data.Bitmap (spec) where + +import Data.Bitmap (Bitmap (..)) +import qualified Data.Bitmap as Bitmap +import Data.Bits (setBit) +import qualified Data.ByteString as BS +import qualified Data.Set as Set +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) +import Test.QuickCheck ( + Gen, + Property, + choose, + forAll, + vectorOf, + (===), + (==>), + ) + +spec :: Spec +spec = + describe "Bitmap" $ + modifyMaxSuccess (* 100) $ do + prop "prop_roundtrip_toIndices" prop_roundtrip_toIndices + prop "prop_fromIndicesIsWellFormed" prop_fromIndicesIsWellFormed + prop "prop_numSetBitsAgreesWithToIndices" prop_numSetBitsAgreesWithToIndices + prop "prop_wellFormedRejectsStrayBit" prop_wellFormedRejectsStrayBit + prop "prop_wellFormedRejectsWrongLength" prop_wellFormedRejectsWrongLength + it "wellFormed rejects a non-positive number of indexes" $ do + Bitmap.wellFormed 0 (Bitmap "") `shouldBe` False + Bitmap.wellFormed (-3) (Bitmap "\x00") `shouldBe` False + it "serialises MSB-first: index i is bit 7 - (i mod 8) of byte (i div 8)" $ do + Bitmap.fromIndices 10 [0, 2, 9] `shouldBe` Bitmap "\xA0\x40" + Bitmap.fromIndices 1 [0] `shouldBe` Bitmap "\x80" + Bitmap.toIndices 10 (Bitmap "\xA0\x40") `shouldBe` [0, 2, 9] + +-- * Properties + +-- | Converting from indices to bitmap and back preserves the indices. +prop_roundtrip_toIndices :: Property +prop_roundtrip_toIndices = + forAll genNumIndexes $ \n -> + forAll (genIndices n) $ \indices -> + Set.fromList indices === Set.fromList (Bitmap.toIndices n (Bitmap.fromIndices n indices)) + +-- | 'Bitmap.fromIndices' produces a well-formed bitmap. +prop_fromIndicesIsWellFormed :: Property +prop_fromIndicesIsWellFormed = + forAll genNumIndexes $ \n -> + forAll (genIndices n) $ \indices -> + Bitmap.wellFormed n (Bitmap.fromIndices n indices) === True + +-- | 'Bitmap.numSetBits' agrees with the length of 'Bitmap.toIndices'. +prop_numSetBitsAgreesWithToIndices :: Property +prop_numSetBitsAgreesWithToIndices = + forAll genNumIndexes $ \n -> + forAll (genIndices n) $ \indices -> + let bitmap = Bitmap.fromIndices n indices + in Bitmap.numSetBits bitmap === length (Bitmap.toIndices n bitmap) + +-- | 'Bitmap.wellFormed' rejects a bit set beyond the last index. +prop_wellFormedRejectsStrayBit :: Property +prop_wellFormedRejectsStrayBit = + forAll genNumIndexes $ \n -> + forAll (genIndices n) $ \indices -> + let strayBit = 6 - (n - 1) `rem` 8 + in (strayBit >= 0) ==> + Bitmap.wellFormed n (withLastBitSet strayBit (Bitmap.fromIndices n indices)) === False + +-- | 'Bitmap.wellFormed' rejects a bitmap of the wrong length. +prop_wellFormedRejectsWrongLength :: Property +prop_wellFormedRejectsWrongLength = + forAll genNumIndexes $ \n -> + forAll (genIndices n) $ \indices -> + let Bitmap bs = Bitmap.fromIndices n indices + in (Bitmap.wellFormed n (Bitmap (bs <> "\x00")), Bitmap.wellFormed n (Bitmap (BS.drop 1 bs))) + === (False, False) + +-- * Generators + +genNumIndexes :: Gen Int +genNumIndexes = + choose (1, 10000) + +genIndices :: Int -> Gen [Int] +genIndices n = do + numIndices <- choose (0, 100) + vectorOf numIndices (choose (0, n - 1)) + +withLastBitSet :: Int -> Bitmap -> Bitmap +withLastBitSet bit (Bitmap bs) + | BS.null bs = Bitmap bs + | otherwise = Bitmap (BS.init bs <> BS.singleton (BS.last bs `setBit` bit))