From c0a2086bb1d0df6d0cfbf84a0be5829fad34fdd2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Thu, 17 Sep 2026 15:10:32 +0200 Subject: [PATCH 01/15] cardano-strict-containers: add Data.Bitmap --- cardano-strict-containers/CHANGELOG.md | 8 +- .../cardano-strict-containers.cabal | 28 ++- cardano-strict-containers/src/Data/Bitmap.hs | 172 ++++++++++++++++++ cardano-strict-containers/test/Main.hs | 7 + .../test/Test/Data/Bitmap.hs | 100 ++++++++++ .../Cardano/StrictContainers/Instances.hs | 10 +- 6 files changed, 320 insertions(+), 5 deletions(-) create mode 100644 cardano-strict-containers/src/Data/Bitmap.hs create mode 100644 cardano-strict-containers/test/Main.hs create mode 100644 cardano-strict-containers/test/Test/Data/Bitmap.hs diff --git a/cardano-strict-containers/CHANGELOG.md b/cardano-strict-containers/CHANGELOG.md index b2ba94722..9f21aca84 100644 --- a/cardano-strict-containers/CHANGELOG.md +++ b/cardano-strict-containers/CHANGELOG.md @@ -1,8 +1,12 @@ # Changelog for `cardano-strict-containers` -## 0.1.6.1 +## 0.1.7.0 -* +* Add `Data.Bitmap` + +### `testlib` + +* Add `genBitmap` ## 0.1.6.0 diff --git a/cardano-strict-containers/cardano-strict-containers.cabal b/cardano-strict-containers/cardano-strict-containers.cabal index d0c9acb4b..6ca1712bf 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, @@ -54,6 +56,28 @@ library testlib Test.Cardano.StrictContainers.Instances build-depends: - QuickCheck, base, cardano-strict-containers, + QuickCheck, + +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: + base, + bytestring, + cardano-binary, + cardano-strict-containers:{cardano-strict-containers, testlib}, + containers, + hspec, + QuickCheck, + + 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..8e7a4549b --- /dev/null +++ b/cardano-strict-containers/src/Data/Bitmap.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# 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, + fromIndices, + toIndices, + numSetBits, + logicalUpperBound, + rawSerialise, + rawDeserialise, + expectedBytes, +) where + +import Cardano.Binary ( + FromCBOR (..), + ToCBOR (..), + decodeBytes, + decodeListLenOf, + encodeBytes, + encodeListLen, + ) +import Control.DeepSeq (NFData) +import Control.Monad (forM_, when) +import Data.Bits ( + complement, + countTrailingZeros, + 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) + +-- | A compact bitmap representation over an index type. +-- +-- NOTE: the logical upper bound is stored explicitly so serialisation +-- round-trips exactly. +data Bitmap a + = Bitmap + -- | Logical upper bound + !a + -- | Payload + !ByteString + deriving stock (Eq, Ord, Generic) + +instance NFData a => NFData (Bitmap a) + +instance NoThunks a => NoThunks (Bitmap a) + +instance Show a => Show (Bitmap a) where + show (Bitmap maxIx bs) = + "Bitmap{maxIx=" + <> show maxIx + <> ",bytes=" + <> show (ByteString.length bs) + <> ",set=" + <> show (countSetBits bs) + <> "}" + +countSetBits :: ByteString -> Int +countSetBits arr = + sum + [ popCount (ByteString.index arr i) + | i <- [0 .. ByteString.length arr - 1] + ] + +expectedBytes :: Integral a => a -> Int +expectedBytes maxIx = (fromIntegral maxIx `quot` 8) + 1 + +lastByteMask :: Integral a => a -> Word8 +lastByteMask maxIx = + fromIntegral ((1 :: Int) `unsafeShiftL` (fromIntegral maxIx `rem` 8 + 1)) - 1 + +-- | Construct a 'Bitmap' from a list of indexes that should be set (flipped to +-- 1) and a maximum index (inclusive logical upper bound). +fromIndices :: Integral a => a -> [a] -> Bitmap a +fromIndices maxIx flipped = + Bitmap maxIx $ + ByteString.unsafeCreate nBytes $ \ptr -> do + fillBytes ptr 0 nBytes + forM_ flipped $ \ix -> do + let !i = fromIntegral ix :: Int + when (i >= 0 && i <= maxI) $ do + let !byteIx = i `quot` 8 + let !bitIx = i `rem` 8 + let !mask = bitMask bitIx + w <- peekByteOff ptr byteIx :: IO Word8 + pokeByteOff ptr byteIx (w .|. mask) + where + !maxI = fromIntegral maxIx :: Int + !nBytes = expectedBytes maxIx + + bitMask k = fromIntegral ((1 :: Int) `unsafeShiftL` k) + +-- | Retrieve all indexes that are set (flipped to 1) in the bitmap, in +-- ascending order. +toIndices :: Integral a => Bitmap a -> [a] +toIndices (Bitmap maxIx bitmap) = + goBytes 0 + where + !maxI = fromIntegral maxIx :: Int + !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 = countTrailingZeros w + !i = base + bitIx + !w' = w .&. (w - 1) + in if i <= maxI + then fromIntegral i : goBits base w' + else [] + +numSetBits :: Bitmap a -> Int +numSetBits (Bitmap _ bs) = countSetBits bs + +-- | Get the logical upper bound of a bitmap +logicalUpperBound :: Bitmap a -> a +logicalUpperBound (Bitmap a _) = a + +-- | Raw serialisation of the bitmap (just the underlying bytes, without the +-- logical upper bound). +rawSerialise :: Bitmap a -> ByteString +rawSerialise (Bitmap _ bs) = bs + +-- | Raw deserialisation of a bitmap from a logical upper bound and a ByteString +-- +-- Returns 'Nothing' if the byte string length does not match the expected size +-- for the given upper bound. +rawDeserialise :: Integral a => a -> ByteString -> Maybe (Bitmap a) +rawDeserialise maxIx bs + | maxIx < 0 = Nothing + | ByteString.length bs /= expectedBytes maxIx = Nothing + | ByteString.last bs .&. complement (lastByteMask maxIx) /= 0 = Nothing + | otherwise = Just (Bitmap maxIx bs) + +instance ToCBOR a => ToCBOR (Bitmap a) where + toCBOR (Bitmap maxIx bs) = + encodeListLen 2 + <> toCBOR maxIx + <> encodeBytes bs + +instance (Integral a, FromCBOR a) => FromCBOR (Bitmap a) where + fromCBOR = do + decodeListLenOf 2 + maxIx <- fromCBOR + bs <- decodeBytes + case rawDeserialise maxIx bs of + Nothing -> + fail "Bitmap: invalid bitmap data or size mismatch" + Just bitmap -> + pure bitmap 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..04317a357 --- /dev/null +++ b/cardano-strict-containers/test/Test/Data/Bitmap.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Property-based tests for 'Bitmap' +module Test.Data.Bitmap (spec) where + +import Cardano.Binary ( + decodeFull, + serialize, + ) +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 Data.Word (Word16) +import Test.Cardano.StrictContainers.Instances (genBitmap) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) +import Test.QuickCheck ( + Gen, + Property, + Testable (..), + arbitrary, + choose, + counterexample, + forAll, + vectorOf, + (===), + (==>), + ) + +spec :: Spec +spec = + describe "Bitmap" $ + modifyMaxSuccess (* 100) $ do + prop "prop_roundtrip_toIndices" prop_roundtrip_toIndices + prop "prop_roundtrip_serialisation" prop_roundtrip_serialisation + prop "numSetBits agrees with toIndices" $ + forAll genWord16Bitmap $ \bm -> + Bitmap.numSetBits bm === length (Bitmap.toIndices bm) + prop "rawDeserialise rejects a bit set above the upper bound" $ + forAll genWord16Bitmap $ \bm -> + let maxIx = Bitmap.logicalUpperBound bm + strayBit = fromIntegral (maxIx `rem` 8) + 1 + in (strayBit <= 7) ==> + Bitmap.rawDeserialise maxIx (withLastBitSet strayBit (Bitmap.rawSerialise bm)) + === Nothing + it "rawDeserialise rejects a negative upper bound" $ do + Bitmap.rawDeserialise (-8 :: Int) "" `shouldBe` Nothing + Bitmap.rawDeserialise (-3 :: Int) "\x00" `shouldBe` Nothing + +-- * Properties + +-- | Converting from indices to bitmap and back preserves the indices. +prop_roundtrip_toIndices :: Property +prop_roundtrip_toIndices = + forAll genMaxIndex $ \maxIndex -> + forAll genNumIndices $ \numIndices -> do + forAll (genIndices numIndices maxIndex) $ \indices -> do + let bitmap = Bitmap.fromIndices maxIndex indices + let indices' = Bitmap.toIndices bitmap + Set.fromList indices === Set.fromList indices' + +-- | Serialisation roundtrip preserves the bitmap. +prop_roundtrip_serialisation :: Property +prop_roundtrip_serialisation = + forAll genMaxIndex $ \maxIndex -> + forAll genNumIndices $ \numIndices -> do + forAll (genIndices numIndices maxIndex) $ \indices -> do + let bitmap = Bitmap.fromIndices maxIndex indices + let encoded = serialize bitmap + case decodeFull encoded of + Left err -> + counterexample ("Deserialization failed: " <> show err) $ + property False + Right bitmap' -> + bitmap === bitmap' + +-- * Generators + +genMaxIndex :: Gen Int +genMaxIndex = + choose (0, 10000) + +genNumIndices :: Gen Int +genNumIndices = + choose (0, 100) + +genIndices :: Int -> Int -> Gen [Int] +genIndices numIndices maxIndex = + vectorOf numIndices (choose (0, maxIndex)) + +genWord16Bitmap :: Gen (Bitmap Word16) +genWord16Bitmap = genBitmap arbitrary + +withLastBitSet :: Int -> BS.ByteString -> BS.ByteString +withLastBitSet bit bs + | BS.null bs = bs + | otherwise = BS.init bs <> BS.singleton (BS.last bs `setBit` bit) diff --git a/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs b/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs index d0c4a3ad8..ddef9537e 100644 --- a/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs +++ b/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs @@ -2,8 +2,10 @@ module Test.Cardano.StrictContainers.Instances where -import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck (Arbitrary (..), Gen, chooseInt, frequency, listOf) +import Data.Bitmap (Bitmap) +import qualified Data.Bitmap as Bitmap import Data.Foldable (toList) import Data.Maybe.Strict import Data.Sequence.Strict (StrictSeq (..)) @@ -16,3 +18,9 @@ instance Arbitrary e => Arbitrary (StrictSeq e) where instance Arbitrary e => Arbitrary (StrictMaybe e) where arbitrary = maybeToStrictMaybe <$> arbitrary shrink = fmap maybeToStrictMaybe . shrink . strictMaybeToMaybe + +genBitmap :: Integral a => Gen a -> Gen (Bitmap a) +genBitmap genIx = do + maxIx <- frequency [(9, fromIntegral <$> chooseInt (0, 2000)), (1, genIx)] + indices <- listOf (fromIntegral <$> chooseInt (0, fromIntegral maxIx)) + pure $ Bitmap.fromIndices maxIx indices From b6bbe9e808bb5fb06cb98ca12519f17d689c95db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 30 Sep 2026 11:32:40 +0200 Subject: [PATCH 02/15] cardano-strict-containers: drop Bitmap's CBOR instances, haddock and test nits --- .../cardano-strict-containers.cabal | 1 - cardano-strict-containers/src/Data/Bitmap.hs | 26 +---------- .../test/Test/Data/Bitmap.hs | 44 +++++++++---------- 3 files changed, 21 insertions(+), 50 deletions(-) diff --git a/cardano-strict-containers/cardano-strict-containers.cabal b/cardano-strict-containers/cardano-strict-containers.cabal index 6ca1712bf..01977f2a8 100644 --- a/cardano-strict-containers/cardano-strict-containers.cabal +++ b/cardano-strict-containers/cardano-strict-containers.cabal @@ -71,7 +71,6 @@ test-suite tests build-depends: base, bytestring, - cardano-binary, cardano-strict-containers:{cardano-strict-containers, testlib}, containers, hspec, diff --git a/cardano-strict-containers/src/Data/Bitmap.hs b/cardano-strict-containers/src/Data/Bitmap.hs index 8e7a4549b..1f4c83b90 100644 --- a/cardano-strict-containers/src/Data/Bitmap.hs +++ b/cardano-strict-containers/src/Data/Bitmap.hs @@ -19,14 +19,6 @@ module Data.Bitmap ( expectedBytes, ) where -import Cardano.Binary ( - FromCBOR (..), - ToCBOR (..), - decodeBytes, - decodeListLenOf, - encodeBytes, - encodeListLen, - ) import Control.DeepSeq (NFData) import Control.Monad (forM_, when) import Data.Bits ( @@ -131,6 +123,7 @@ toIndices (Bitmap maxIx bitmap) = then fromIntegral i : goBits base w' else [] +-- | The number of indexes set (flipped to 1) in the bitmap. numSetBits :: Bitmap a -> Int numSetBits (Bitmap _ bs) = countSetBits bs @@ -153,20 +146,3 @@ rawDeserialise maxIx bs | ByteString.length bs /= expectedBytes maxIx = Nothing | ByteString.last bs .&. complement (lastByteMask maxIx) /= 0 = Nothing | otherwise = Just (Bitmap maxIx bs) - -instance ToCBOR a => ToCBOR (Bitmap a) where - toCBOR (Bitmap maxIx bs) = - encodeListLen 2 - <> toCBOR maxIx - <> encodeBytes bs - -instance (Integral a, FromCBOR a) => FromCBOR (Bitmap a) where - fromCBOR = do - decodeListLenOf 2 - maxIx <- fromCBOR - bs <- decodeBytes - case rawDeserialise maxIx bs of - Nothing -> - fail "Bitmap: invalid bitmap data or size mismatch" - Just bitmap -> - pure bitmap diff --git a/cardano-strict-containers/test/Test/Data/Bitmap.hs b/cardano-strict-containers/test/Test/Data/Bitmap.hs index 04317a357..7831ceba7 100644 --- a/cardano-strict-containers/test/Test/Data/Bitmap.hs +++ b/cardano-strict-containers/test/Test/Data/Bitmap.hs @@ -4,10 +4,6 @@ -- | Property-based tests for 'Bitmap' module Test.Data.Bitmap (spec) where -import Cardano.Binary ( - decodeFull, - serialize, - ) import Data.Bitmap (Bitmap) import qualified Data.Bitmap as Bitmap import Data.Bits (setBit) @@ -20,10 +16,8 @@ import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck ( Gen, Property, - Testable (..), arbitrary, choose, - counterexample, forAll, vectorOf, (===), @@ -36,16 +30,8 @@ spec = modifyMaxSuccess (* 100) $ do prop "prop_roundtrip_toIndices" prop_roundtrip_toIndices prop "prop_roundtrip_serialisation" prop_roundtrip_serialisation - prop "numSetBits agrees with toIndices" $ - forAll genWord16Bitmap $ \bm -> - Bitmap.numSetBits bm === length (Bitmap.toIndices bm) - prop "rawDeserialise rejects a bit set above the upper bound" $ - forAll genWord16Bitmap $ \bm -> - let maxIx = Bitmap.logicalUpperBound bm - strayBit = fromIntegral (maxIx `rem` 8) + 1 - in (strayBit <= 7) ==> - Bitmap.rawDeserialise maxIx (withLastBitSet strayBit (Bitmap.rawSerialise bm)) - === Nothing + prop "prop_numSetBitsAgreesWithToIndices" prop_numSetBitsAgreesWithToIndices + prop "prop_rawDeserialiseRejectsStrayBit" prop_rawDeserialiseRejectsStrayBit it "rawDeserialise rejects a negative upper bound" $ do Bitmap.rawDeserialise (-8 :: Int) "" `shouldBe` Nothing Bitmap.rawDeserialise (-3 :: Int) "\x00" `shouldBe` Nothing @@ -62,20 +48,30 @@ prop_roundtrip_toIndices = let indices' = Bitmap.toIndices bitmap Set.fromList indices === Set.fromList indices' --- | Serialisation roundtrip preserves the bitmap. +-- | Raw serialisation roundtrip preserves the bitmap. prop_roundtrip_serialisation :: Property prop_roundtrip_serialisation = forAll genMaxIndex $ \maxIndex -> forAll genNumIndices $ \numIndices -> do forAll (genIndices numIndices maxIndex) $ \indices -> do let bitmap = Bitmap.fromIndices maxIndex indices - let encoded = serialize bitmap - case decodeFull encoded of - Left err -> - counterexample ("Deserialization failed: " <> show err) $ - property False - Right bitmap' -> - bitmap === bitmap' + Bitmap.rawDeserialise maxIndex (Bitmap.rawSerialise bitmap) === Just bitmap + +-- | 'Bitmap.numSetBits' agrees with the length of 'Bitmap.toIndices'. +prop_numSetBitsAgreesWithToIndices :: Property +prop_numSetBitsAgreesWithToIndices = + forAll genWord16Bitmap $ \bm -> + Bitmap.numSetBits bm === length (Bitmap.toIndices bm) + +-- | 'Bitmap.rawDeserialise' rejects a bit set above the logical upper bound. +prop_rawDeserialiseRejectsStrayBit :: Property +prop_rawDeserialiseRejectsStrayBit = + forAll genWord16Bitmap $ \bm -> + let maxIx = Bitmap.logicalUpperBound bm + strayBit = fromIntegral (maxIx `rem` 8) + 1 + in (strayBit <= 7) ==> + Bitmap.rawDeserialise maxIx (withLastBitSet strayBit (Bitmap.rawSerialise bm)) + === Nothing -- * Generators From 362c800af311980ec7f8720a669ade0d872a15b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 5 Oct 2026 11:08:56 +0200 Subject: [PATCH 03/15] cardano-strict-containers: MSB-first Data.Bitmap --- cardano-strict-containers/CHANGELOG.md | 5 ++++- cardano-strict-containers/src/Data/Bitmap.hs | 11 ++++++----- cardano-strict-containers/test/Test/Data/Bitmap.hs | 8 ++++++-- 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/cardano-strict-containers/CHANGELOG.md b/cardano-strict-containers/CHANGELOG.md index 9f21aca84..85b001084 100644 --- a/cardano-strict-containers/CHANGELOG.md +++ b/cardano-strict-containers/CHANGELOG.md @@ -2,7 +2,10 @@ ## 0.1.7.0 -* Add `Data.Bitmap` +* Add `Data.Bitmap`, a bitmap with an explicit inclusive upper bound. Bits are + MSB-first within a byte, the convention of the Leios certificate bitfield + (CIP-164); decoding rejects a payload of the wrong length or with bits set + above the bound. ### `testlib` diff --git a/cardano-strict-containers/src/Data/Bitmap.hs b/cardano-strict-containers/src/Data/Bitmap.hs index 1f4c83b90..6cc1b77ce 100644 --- a/cardano-strict-containers/src/Data/Bitmap.hs +++ b/cardano-strict-containers/src/Data/Bitmap.hs @@ -22,8 +22,9 @@ module Data.Bitmap ( import Control.DeepSeq (NFData) import Control.Monad (forM_, when) import Data.Bits ( + clearBit, complement, - countTrailingZeros, + countLeadingZeros, popCount, unsafeShiftL, (.&.), @@ -76,7 +77,7 @@ expectedBytes maxIx = (fromIntegral maxIx `quot` 8) + 1 lastByteMask :: Integral a => a -> Word8 lastByteMask maxIx = - fromIntegral ((1 :: Int) `unsafeShiftL` (fromIntegral maxIx `rem` 8 + 1)) - 1 + complement (fromIntegral ((1 :: Int) `unsafeShiftL` (7 - fromIntegral maxIx `rem` 8)) - 1) -- | Construct a 'Bitmap' from a list of indexes that should be set (flipped to -- 1) and a maximum index (inclusive logical upper bound). @@ -89,7 +90,7 @@ fromIndices maxIx flipped = let !i = fromIntegral ix :: Int when (i >= 0 && i <= maxI) $ do let !byteIx = i `quot` 8 - let !bitIx = i `rem` 8 + let !bitIx = 7 - i `rem` 8 let !mask = bitMask bitIx w <- peekByteOff ptr byteIx :: IO Word8 pokeByteOff ptr byteIx (w .|. mask) @@ -116,9 +117,9 @@ toIndices (Bitmap maxIx bitmap) = goBits !_ 0 = [] goBits !base !w = - let !bitIx = countTrailingZeros w + let !bitIx = countLeadingZeros w !i = base + bitIx - !w' = w .&. (w - 1) + !w' = clearBit w (7 - bitIx) in if i <= maxI then fromIntegral i : goBits base w' else [] diff --git a/cardano-strict-containers/test/Test/Data/Bitmap.hs b/cardano-strict-containers/test/Test/Data/Bitmap.hs index 7831ceba7..7d4e52629 100644 --- a/cardano-strict-containers/test/Test/Data/Bitmap.hs +++ b/cardano-strict-containers/test/Test/Data/Bitmap.hs @@ -35,6 +35,10 @@ spec = it "rawDeserialise rejects a negative upper bound" $ do Bitmap.rawDeserialise (-8 :: Int) "" `shouldBe` Nothing Bitmap.rawDeserialise (-3 :: Int) "\x00" `shouldBe` Nothing + it "serialises MSB-first: seat i is bit 7 - (i mod 8) of byte (i div 8)" $ do + Bitmap.rawSerialise (Bitmap.fromIndices (9 :: Int) [0, 2, 9]) `shouldBe` "\xA0\x40" + Bitmap.rawSerialise (Bitmap.fromIndices (0 :: Int) [0]) `shouldBe` "\x80" + fmap Bitmap.toIndices (Bitmap.rawDeserialise (9 :: Int) "\xA0\x40") `shouldBe` Just [0, 2, 9] -- * Properties @@ -68,8 +72,8 @@ prop_rawDeserialiseRejectsStrayBit :: Property prop_rawDeserialiseRejectsStrayBit = forAll genWord16Bitmap $ \bm -> let maxIx = Bitmap.logicalUpperBound bm - strayBit = fromIntegral (maxIx `rem` 8) + 1 - in (strayBit <= 7) ==> + strayBit = 6 - fromIntegral (maxIx `rem` 8) + in (strayBit >= 0) ==> Bitmap.rawDeserialise maxIx (withLastBitSet strayBit (Bitmap.rawSerialise bm)) === Nothing From c4c02fd8f4258ec1c8314a917fb0f6d50b25c99d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 7 Oct 2026 09:29:52 +0200 Subject: [PATCH 04/15] cardano-strict-containers: Data.Bitmap as a newtype over ByteString with an explicit number of indexes --- cardano-strict-containers/CHANGELOG.md | 10 +- .../cardano-strict-containers.cabal | 2 +- cardano-strict-containers/src/Data/Bitmap.hs | 120 +++++++----------- .../test/Test/Data/Bitmap.hs | 109 ++++++++-------- .../Cardano/StrictContainers/Instances.hs | 10 +- 5 files changed, 101 insertions(+), 150 deletions(-) diff --git a/cardano-strict-containers/CHANGELOG.md b/cardano-strict-containers/CHANGELOG.md index 85b001084..a6b6c1331 100644 --- a/cardano-strict-containers/CHANGELOG.md +++ b/cardano-strict-containers/CHANGELOG.md @@ -2,14 +2,8 @@ ## 0.1.7.0 -* Add `Data.Bitmap`, a bitmap with an explicit inclusive upper bound. Bits are - MSB-first within a byte, the convention of the Leios certificate bitfield - (CIP-164); decoding rejects a payload of the wrong length or with bits set - above the bound. - -### `testlib` - -* Add `genBitmap` +* 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 01977f2a8..ca1e3e4fa 100644 --- a/cardano-strict-containers/cardano-strict-containers.cabal +++ b/cardano-strict-containers/cardano-strict-containers.cabal @@ -71,7 +71,7 @@ test-suite tests build-depends: base, bytestring, - cardano-strict-containers:{cardano-strict-containers, testlib}, + cardano-strict-containers, containers, hspec, QuickCheck, diff --git a/cardano-strict-containers/src/Data/Bitmap.hs b/cardano-strict-containers/src/Data/Bitmap.hs index 6cc1b77ce..10b9b4086 100644 --- a/cardano-strict-containers/src/Data/Bitmap.hs +++ b/cardano-strict-containers/src/Data/Bitmap.hs @@ -1,6 +1,9 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -- | A compact bitmap representation using serialisation-ready ByteStrings. @@ -9,14 +12,12 @@ -- -- NOTE: this module is meant to be imported qualified. module Data.Bitmap ( - Bitmap, + Bitmap (..), + numBytes, fromIndices, toIndices, numSetBits, - logicalUpperBound, - rawSerialise, - rawDeserialise, - expectedBytes, + wellFormed, ) where import Control.DeepSeq (NFData) @@ -37,57 +38,39 @@ import Data.Word (Word8) import Foreign.Marshal.Utils (fillBytes) import Foreign.Storable (peekByteOff, pokeByteOff) import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) +import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) --- | A compact bitmap representation over an index type. --- --- NOTE: the logical upper bound is stored explicitly so serialisation --- round-trips exactly. -data Bitmap a - = Bitmap - -- | Logical upper bound - !a - -- | Payload - !ByteString - deriving stock (Eq, Ord, Generic) - -instance NFData a => NFData (Bitmap a) - -instance NoThunks a => NoThunks (Bitmap a) +-- | 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 -instance Show a => Show (Bitmap a) where - show (Bitmap maxIx bs) = - "Bitmap{maxIx=" - <> show maxIx - <> ",bytes=" - <> show (ByteString.length bs) - <> ",set=" - <> show (countSetBits bs) - <> "}" - -countSetBits :: ByteString -> Int -countSetBits arr = +-- | 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] ] -expectedBytes :: Integral a => a -> Int -expectedBytes maxIx = (fromIntegral maxIx `quot` 8) + 1 +-- | The number of bytes of a bitmap over the given number of indexes. +numBytes :: Int -> Int +numBytes n = (n + 7) `quot` 8 -lastByteMask :: Integral a => a -> Word8 -lastByteMask maxIx = - complement (fromIntegral ((1 :: Int) `unsafeShiftL` (7 - fromIntegral maxIx `rem` 8)) - 1) +lastByteMask :: Int -> Word8 +lastByteMask n = + complement (fromIntegral ((1 :: Int) `unsafeShiftL` (7 - (n - 1) `rem` 8)) - 1) --- | Construct a 'Bitmap' from a list of indexes that should be set (flipped to --- 1) and a maximum index (inclusive logical upper bound). -fromIndices :: Integral a => a -> [a] -> Bitmap a -fromIndices maxIx flipped = - Bitmap maxIx $ +-- | 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 $ \ix -> do - let !i = fromIntegral ix :: Int + forM_ flipped $ \i -> do when (i >= 0 && i <= maxI) $ do let !byteIx = i `quot` 8 let !bitIx = 7 - i `rem` 8 @@ -95,18 +78,18 @@ fromIndices maxIx flipped = w <- peekByteOff ptr byteIx :: IO Word8 pokeByteOff ptr byteIx (w .|. mask) where - !maxI = fromIntegral maxIx :: Int - !nBytes = expectedBytes maxIx + !maxI = n - 1 + !nBytes = numBytes n bitMask k = fromIntegral ((1 :: Int) `unsafeShiftL` k) --- | Retrieve all indexes that are set (flipped to 1) in the bitmap, in --- ascending order. -toIndices :: Integral a => Bitmap a -> [a] -toIndices (Bitmap maxIx bitmap) = +-- | 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 = fromIntegral maxIx :: Int + !maxI = n - 1 !nBytes = ByteString.length bitmap goBytes !byteIx @@ -121,29 +104,14 @@ toIndices (Bitmap maxIx bitmap) = !i = base + bitIx !w' = clearBit w (7 - bitIx) in if i <= maxI - then fromIntegral i : goBits base w' + then i : goBits base w' else [] --- | The number of indexes set (flipped to 1) in the bitmap. -numSetBits :: Bitmap a -> Int -numSetBits (Bitmap _ bs) = countSetBits bs - --- | Get the logical upper bound of a bitmap -logicalUpperBound :: Bitmap a -> a -logicalUpperBound (Bitmap a _) = a - --- | Raw serialisation of the bitmap (just the underlying bytes, without the --- logical upper bound). -rawSerialise :: Bitmap a -> ByteString -rawSerialise (Bitmap _ bs) = bs - --- | Raw deserialisation of a bitmap from a logical upper bound and a ByteString --- --- Returns 'Nothing' if the byte string length does not match the expected size --- for the given upper bound. -rawDeserialise :: Integral a => a -> ByteString -> Maybe (Bitmap a) -rawDeserialise maxIx bs - | maxIx < 0 = Nothing - | ByteString.length bs /= expectedBytes maxIx = Nothing - | ByteString.last bs .&. complement (lastByteMask maxIx) /= 0 = Nothing - | otherwise = Just (Bitmap maxIx bs) +-- | 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/Test/Data/Bitmap.hs b/cardano-strict-containers/test/Test/Data/Bitmap.hs index 7d4e52629..1f09c3873 100644 --- a/cardano-strict-containers/test/Test/Data/Bitmap.hs +++ b/cardano-strict-containers/test/Test/Data/Bitmap.hs @@ -1,22 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} --- | Property-based tests for 'Bitmap' +-- | Property-based tests for 'Data.Bitmap' module Test.Data.Bitmap (spec) where -import Data.Bitmap (Bitmap) +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 Data.Word (Word16) -import Test.Cardano.StrictContainers.Instances (genBitmap) import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck ( Gen, Property, - arbitrary, choose, forAll, vectorOf, @@ -29,72 +26,72 @@ spec = describe "Bitmap" $ modifyMaxSuccess (* 100) $ do prop "prop_roundtrip_toIndices" prop_roundtrip_toIndices - prop "prop_roundtrip_serialisation" prop_roundtrip_serialisation + prop "prop_fromIndicesIsWellFormed" prop_fromIndicesIsWellFormed prop "prop_numSetBitsAgreesWithToIndices" prop_numSetBitsAgreesWithToIndices - prop "prop_rawDeserialiseRejectsStrayBit" prop_rawDeserialiseRejectsStrayBit - it "rawDeserialise rejects a negative upper bound" $ do - Bitmap.rawDeserialise (-8 :: Int) "" `shouldBe` Nothing - Bitmap.rawDeserialise (-3 :: Int) "\x00" `shouldBe` Nothing - it "serialises MSB-first: seat i is bit 7 - (i mod 8) of byte (i div 8)" $ do - Bitmap.rawSerialise (Bitmap.fromIndices (9 :: Int) [0, 2, 9]) `shouldBe` "\xA0\x40" - Bitmap.rawSerialise (Bitmap.fromIndices (0 :: Int) [0]) `shouldBe` "\x80" - fmap Bitmap.toIndices (Bitmap.rawDeserialise (9 :: Int) "\xA0\x40") `shouldBe` Just [0, 2, 9] + 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 genMaxIndex $ \maxIndex -> - forAll genNumIndices $ \numIndices -> do - forAll (genIndices numIndices maxIndex) $ \indices -> do - let bitmap = Bitmap.fromIndices maxIndex indices - let indices' = Bitmap.toIndices bitmap - Set.fromList indices === Set.fromList indices' + forAll genNumIndexes $ \n -> + forAll (genIndices n) $ \indices -> + Set.fromList indices === Set.fromList (Bitmap.toIndices n (Bitmap.fromIndices n indices)) --- | Raw serialisation roundtrip preserves the bitmap. -prop_roundtrip_serialisation :: Property -prop_roundtrip_serialisation = - forAll genMaxIndex $ \maxIndex -> - forAll genNumIndices $ \numIndices -> do - forAll (genIndices numIndices maxIndex) $ \indices -> do - let bitmap = Bitmap.fromIndices maxIndex indices - Bitmap.rawDeserialise maxIndex (Bitmap.rawSerialise bitmap) === Just bitmap +-- | '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 genWord16Bitmap $ \bm -> - Bitmap.numSetBits bm === length (Bitmap.toIndices bm) + forAll genNumIndexes $ \n -> + forAll (genIndices n) $ \indices -> + let bitmap = Bitmap.fromIndices n indices + in Bitmap.numSetBits bitmap === length (Bitmap.toIndices n bitmap) --- | 'Bitmap.rawDeserialise' rejects a bit set above the logical upper bound. -prop_rawDeserialiseRejectsStrayBit :: Property -prop_rawDeserialiseRejectsStrayBit = - forAll genWord16Bitmap $ \bm -> - let maxIx = Bitmap.logicalUpperBound bm - strayBit = 6 - fromIntegral (maxIx `rem` 8) - in (strayBit >= 0) ==> - Bitmap.rawDeserialise maxIx (withLastBitSet strayBit (Bitmap.rawSerialise bm)) - === Nothing +-- | '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 --- * Generators - -genMaxIndex :: Gen Int -genMaxIndex = - choose (0, 10000) +-- | '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) -genNumIndices :: Gen Int -genNumIndices = - choose (0, 100) +-- * Generators -genIndices :: Int -> Int -> Gen [Int] -genIndices numIndices maxIndex = - vectorOf numIndices (choose (0, maxIndex)) +genNumIndexes :: Gen Int +genNumIndexes = + choose (1, 10000) -genWord16Bitmap :: Gen (Bitmap Word16) -genWord16Bitmap = genBitmap arbitrary +genIndices :: Int -> Gen [Int] +genIndices n = do + numIndices <- choose (0, 100) + vectorOf numIndices (choose (0, n - 1)) -withLastBitSet :: Int -> BS.ByteString -> BS.ByteString -withLastBitSet bit bs - | BS.null bs = bs - | otherwise = BS.init bs <> BS.singleton (BS.last bs `setBit` bit) +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)) diff --git a/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs b/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs index ddef9537e..d0c4a3ad8 100644 --- a/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs +++ b/cardano-strict-containers/testlib/Test/Cardano/StrictContainers/Instances.hs @@ -2,10 +2,8 @@ module Test.Cardano.StrictContainers.Instances where -import Test.QuickCheck (Arbitrary (..), Gen, chooseInt, frequency, listOf) +import Test.QuickCheck (Arbitrary (..)) -import Data.Bitmap (Bitmap) -import qualified Data.Bitmap as Bitmap import Data.Foldable (toList) import Data.Maybe.Strict import Data.Sequence.Strict (StrictSeq (..)) @@ -18,9 +16,3 @@ instance Arbitrary e => Arbitrary (StrictSeq e) where instance Arbitrary e => Arbitrary (StrictMaybe e) where arbitrary = maybeToStrictMaybe <$> arbitrary shrink = fmap maybeToStrictMaybe . shrink . strictMaybeToMaybe - -genBitmap :: Integral a => Gen a -> Gen (Bitmap a) -genBitmap genIx = do - maxIx <- frequency [(9, fromIntegral <$> chooseInt (0, 2000)), (1, genIx)] - indices <- listOf (fromIntegral <$> chooseInt (0, fromIntegral maxIx)) - pure $ Bitmap.fromIndices maxIx indices From e4bb2dd2415a7305ee343d6498f66e8cfe888b65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 12 Oct 2026 11:25:45 +0200 Subject: [PATCH 05/15] cardano-strict-containers: sort build-depends --- cardano-strict-containers/cardano-strict-containers.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-strict-containers/cardano-strict-containers.cabal b/cardano-strict-containers/cardano-strict-containers.cabal index ca1e3e4fa..9c53a93b1 100644 --- a/cardano-strict-containers/cardano-strict-containers.cabal +++ b/cardano-strict-containers/cardano-strict-containers.cabal @@ -56,9 +56,9 @@ library testlib Test.Cardano.StrictContainers.Instances build-depends: + QuickCheck, base, cardano-strict-containers, - QuickCheck, test-suite tests import: language, warnings @@ -69,12 +69,12 @@ test-suite tests Test.Data.Bitmap build-depends: + QuickCheck, base, bytestring, cardano-strict-containers, containers, hspec, - QuickCheck, ghc-options: -threaded From 6131530de34d346febbb18c8a2f5b6abc854066c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 7 Oct 2026 10:38:55 +0200 Subject: [PATCH 06/15] cardano-crypto-peras: add the Peras base types --- .../cardano-crypto-peras.cabal | 12 +- .../src/Cardano/Crypto/Peras.hs | 118 +++++++++++++++++- 2 files changed, 123 insertions(+), 7 deletions(-) diff --git a/cardano-crypto-peras/cardano-crypto-peras.cabal b/cardano-crypto-peras/cardano-crypto-peras.cabal index 3ef6281e1..9bf6c795f 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 @@ -39,6 +42,11 @@ library Cardano.Crypto.Peras.Cert build-depends: - base, + bytestring, + cardano-binary >=1.9.1, + cardano-crypto-class >=2.6, + cardano-slotting, + deepseq, nothunks, quiet, + serialise, 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 From d633cbaa51bd84b31adbc376d74b2c72eabc3af6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 7 Oct 2026 10:38:56 +0200 Subject: [PATCH 07/15] cardano-crypto-peras: add PerasVotersBitmap, PerasCertVoters and PerasCert --- .../cardano-crypto-peras.cabal | 1 + .../src/Cardano/Crypto/Peras/Cert.hs | 188 ++++++++++++++++-- 2 files changed, 175 insertions(+), 14 deletions(-) diff --git a/cardano-crypto-peras/cardano-crypto-peras.cabal b/cardano-crypto-peras/cardano-crypto-peras.cabal index 9bf6c795f..63e1338d6 100644 --- a/cardano-crypto-peras/cardano-crypto-peras.cabal +++ b/cardano-crypto-peras/cardano-crypto-peras.cabal @@ -46,6 +46,7 @@ library cardano-binary >=1.9.1, cardano-crypto-class >=2.6, cardano-slotting, + cardano-strict-containers >=0.1.7, deepseq, nothunks, quiet, diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs index 022517efd..a95b04018 100644 --- a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs @@ -1,32 +1,192 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} module Cardano.Crypto.Peras.Cert ( - -- * Peras certificates + PerasVotersBitmap (UnsafePerasVotersBitmap, perasVotersMaxIndex, perasVotersBits), + mkPerasVotersBitmap, + perasVotersBitmapFromSeats, + perasVotersBitmapSeats, + perasVotersBitmapSize, + PerasCertVoters (UnsafePerasCertVoters, perasCertVotersBitmap, perasCertNonPersistentVRFOutputs), + mkPerasCertVoters, + perasCertVotersFromSeats, + perasCertVoterSeats, + perasCertNumberOfVoters, + perasCertNumberOfNonPersistentVoters, 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) + +perasVotersBitmapSeats :: PerasVotersBitmap -> [PerasSeatIndex] +perasVotersBitmapSeats (UnsafePerasVotersBitmap maxIx bs) = + PerasSeatIndex . fromIntegral <$> Bitmap.toIndices (fromIntegral maxIx + 1) bs + +perasVotersBitmapSize :: PerasVotersBitmap -> Int +perasVotersBitmapSize = Bitmap.numSetBits . perasVotersBits --- | A Peras certificate indicating that a node has received a weight boost. +{------------------------------------------------------------------------------- + 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) + +perasCertVoterSeats :: PerasCertVoters -> NonEmpty (PerasSeatIndex, Maybe PerasVRFOutput) +perasCertVoterSeats UnsafePerasCertVoters {perasCertVotersBitmap, perasCertNonPersistentVRFOutputs} = + case zip seats proofs of + [] -> error "perasCertVoterSeats: empty voters bitmap (invariant violated via UnsafePerasCertVoters)" + x : xs -> x :| xs + where + seats = perasVotersBitmapSeats perasCertVotersBitmap + numPersistent = length seats - length perasCertNonPersistentVRFOutputs + 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 + +{------------------------------------------------------------------------------- + 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) + +-- | 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 From ac42d767d55c55d8ec66e32e4ec9c2def84c9bac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 7 Oct 2026 10:38:56 +0200 Subject: [PATCH 08/15] cardano-crypto-peras: add PerasVote and PerasVoteEligibilityProof --- .../cardano-crypto-peras.cabal | 1 + .../src/Cardano/Crypto/Peras/Vote.hs | 52 +++++++++++++++++++ 2 files changed, 53 insertions(+) create mode 100644 cardano-crypto-peras/src/Cardano/Crypto/Peras/Vote.hs diff --git a/cardano-crypto-peras/cardano-crypto-peras.cabal b/cardano-crypto-peras/cardano-crypto-peras.cabal index 63e1338d6..0c358ae61 100644 --- a/cardano-crypto-peras/cardano-crypto-peras.cabal +++ b/cardano-crypto-peras/cardano-crypto-peras.cabal @@ -40,6 +40,7 @@ library exposed-modules: Cardano.Crypto.Peras Cardano.Crypto.Peras.Cert + Cardano.Crypto.Peras.Vote build-depends: bytestring, 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) From 6241ddf28f5567c57789df9a06fe24813bfb5ca3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 7 Oct 2026 10:38:57 +0200 Subject: [PATCH 09/15] cardano-crypto-peras: add testlib generators and test-suite --- .../cardano-crypto-peras.cabal | 35 +++++ cardano-crypto-peras/test/Main.hs | 8 + .../test/Test/Cardano/Crypto/Peras.hs | 125 +++++++++++++++ .../testlib/Test/Cardano/Crypto/Peras/Gen.hs | 145 ++++++++++++++++++ 4 files changed, 313 insertions(+) create mode 100644 cardano-crypto-peras/test/Main.hs create mode 100644 cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs create mode 100644 cardano-crypto-peras/testlib/Test/Cardano/Crypto/Peras/Gen.hs diff --git a/cardano-crypto-peras/cardano-crypto-peras.cabal b/cardano-crypto-peras/cardano-crypto-peras.cabal index 0c358ae61..fb4e142b0 100644 --- a/cardano-crypto-peras/cardano-crypto-peras.cabal +++ b/cardano-crypto-peras/cardano-crypto-peras.cabal @@ -52,3 +52,38 @@ library nothunks, quiet, serialise, + +library testlib + import: base, project-config + visibility: public + hs-source-dirs: testlib + exposed-modules: + Test.Cardano.Crypto.Peras.Gen + + build-depends: + bytestring, + cardano-base:testlib, + cardano-crypto-class:{cardano-crypto-class, testlib}, + cardano-crypto-peras, + cardano-slotting, + QuickCheck, + +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: + bytestring, + cardano-crypto-class, + cardano-crypto-peras:{cardano-crypto-peras, testlib}, + cardano-slotting, + hspec, + QuickCheck, + + ghc-options: + -threaded + -rtsopts 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..27e335708 --- /dev/null +++ b/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs @@ -0,0 +1,125 @@ +{-# 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, + perasCertNumberOfVoters, + perasCertSizeUpperBound, + perasCertVoterSeats, + perasCertVotersFromSeats, + 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 . perasCertVoterSeats" $ + forAll (genPerasCertVoters True) $ \v -> + perasCertVotersFromSeats (perasCertVoterSeats v) === Right v + prop "counts voters" $ + forAll (genPerasCertVoters True) $ \v -> + let seats = perasCertVoterSeats v + in (perasCertNumberOfVoters v, perasCertNumberOfNonPersistentVoters v) + === (length 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 From 69b8f35a3c15bf67cc897cd035da200b420d1cdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 7 Oct 2026 10:38:57 +0200 Subject: [PATCH 10/15] cardano-crypto-peras: changelog and README for 0.2.0.0 --- cardano-crypto-peras/CHANGELOG.md | 17 +++++++++++++++-- cardano-crypto-peras/README.md | 8 ++++++++ 2 files changed, 23 insertions(+), 2 deletions(-) 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. From 6a8c3adafd6f6231a785e52459a30156ee1423ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Wed, 7 Oct 2026 11:48:28 +0200 Subject: [PATCH 11/15] cardano-crypto-peras: add the missing Enum, Real, Integral and Num instances to PerasCertSize --- cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs index a95b04018..9d75c02e9 100644 --- a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} @@ -163,6 +164,7 @@ data PerasCert = PerasCert 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'. From ab8ae3d6204b62bfa075eca47062c003c0291090 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 12 Oct 2026 11:26:04 +0200 Subject: [PATCH 12/15] cardano-crypto-peras: sort build-depends as cabal-gild 1.5.0.1 does --- cardano-crypto-peras/cardano-crypto-peras.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-crypto-peras/cardano-crypto-peras.cabal b/cardano-crypto-peras/cardano-crypto-peras.cabal index fb4e142b0..3bfdd3de1 100644 --- a/cardano-crypto-peras/cardano-crypto-peras.cabal +++ b/cardano-crypto-peras/cardano-crypto-peras.cabal @@ -61,12 +61,12 @@ library testlib Test.Cardano.Crypto.Peras.Gen build-depends: + QuickCheck, bytestring, cardano-base:testlib, cardano-crypto-class:{cardano-crypto-class, testlib}, cardano-crypto-peras, cardano-slotting, - QuickCheck, test-suite tests import: base, project-config @@ -77,12 +77,12 @@ test-suite tests Test.Cardano.Crypto.Peras build-depends: + QuickCheck, bytestring, cardano-crypto-class, cardano-crypto-peras:{cardano-crypto-peras, testlib}, cardano-slotting, hspec, - QuickCheck, ghc-options: -threaded From bced39070eb627cddf6b2ab777bef6dcd67b8272 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 12 Oct 2026 11:26:33 +0200 Subject: [PATCH 13/15] cardano-crypto-peras: rename perasCertVoterSeats to perasCertVotersToSeats --- cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs | 9 +++++---- cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs | 8 ++++---- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs index 9d75c02e9..7c29984bf 100644 --- a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs @@ -14,7 +14,7 @@ module Cardano.Crypto.Peras.Cert ( PerasCertVoters (UnsafePerasCertVoters, perasCertVotersBitmap, perasCertNonPersistentVRFOutputs), mkPerasCertVoters, perasCertVotersFromSeats, - perasCertVoterSeats, + perasCertVotersToSeats, perasCertNumberOfVoters, perasCertNumberOfNonPersistentVoters, PerasCert (..), @@ -111,10 +111,11 @@ mkPerasCertVoters bitmap vrfOutputs = do ] pure (UnsafePerasCertVoters bitmap vrfOutputs) -perasCertVoterSeats :: PerasCertVoters -> NonEmpty (PerasSeatIndex, Maybe PerasVRFOutput) -perasCertVoterSeats UnsafePerasCertVoters {perasCertVotersBitmap, perasCertNonPersistentVRFOutputs} = +perasCertVotersToSeats :: PerasCertVoters -> NonEmpty (PerasSeatIndex, Maybe PerasVRFOutput) +perasCertVotersToSeats UnsafePerasCertVoters {perasCertVotersBitmap, perasCertNonPersistentVRFOutputs} = case zip seats proofs of - [] -> error "perasCertVoterSeats: empty voters bitmap (invariant violated via UnsafePerasCertVoters)" + [] -> + error "perasCertVotersToSeats: empty voters bitmap (invariant violated via UnsafePerasCertVoters)" x : xs -> x :| xs where seats = perasVotersBitmapSeats perasCertVotersBitmap diff --git a/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs b/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs index 27e335708..0c5d03785 100644 --- a/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs +++ b/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs @@ -17,8 +17,8 @@ import Cardano.Crypto.Peras.Cert ( perasCertNumberOfNonPersistentVoters, perasCertNumberOfVoters, perasCertSizeUpperBound, - perasCertVoterSeats, perasCertVotersFromSeats, + perasCertVotersToSeats, perasVotersBitmapFromSeats, ) import Cardano.Crypto.Peras.Vote ( @@ -46,12 +46,12 @@ import Test.QuickCheck ( spec :: Spec spec = do describe "PerasCertVoters" $ do - prop "perasCertVotersFromSeats . perasCertVoterSeats" $ + prop "perasCertVotersFromSeats . perasCertVotersToSeats" $ forAll (genPerasCertVoters True) $ \v -> - perasCertVotersFromSeats (perasCertVoterSeats v) === Right v + perasCertVotersFromSeats (perasCertVotersToSeats v) === Right v prop "counts voters" $ forAll (genPerasCertVoters True) $ \v -> - let seats = perasCertVoterSeats v + let seats = perasCertVotersToSeats v in (perasCertNumberOfVoters v, perasCertNumberOfNonPersistentVoters v) === (length seats, length (NonEmpty.filter ((/= Nothing) . snd) seats)) prop "rejects a persistent voter after a non-persistent one" $ From 6fb484b68f432538ee618d729e097b5e6cb87f48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 12 Oct 2026 11:26:43 +0200 Subject: [PATCH 14/15] cardano-crypto-peras: export PerasVotersBitmap and PerasCertVoters with (..) --- cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs index 7c29984bf..32aaabed6 100644 --- a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs @@ -6,12 +6,12 @@ {-# LANGUAGE NamedFieldPuns #-} module Cardano.Crypto.Peras.Cert ( - PerasVotersBitmap (UnsafePerasVotersBitmap, perasVotersMaxIndex, perasVotersBits), + PerasVotersBitmap (..), mkPerasVotersBitmap, perasVotersBitmapFromSeats, perasVotersBitmapSeats, perasVotersBitmapSize, - PerasCertVoters (UnsafePerasCertVoters, perasCertVotersBitmap, perasCertNonPersistentVRFOutputs), + PerasCertVoters (..), mkPerasCertVoters, perasCertVotersFromSeats, perasCertVotersToSeats, From 15580ce9bf67dfbb71b122ae76110820a4c97e2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABl=20Deest?= Date: Mon, 12 Oct 2026 11:27:24 +0200 Subject: [PATCH 15/15] cardano-crypto-peras: add perasCertNumberOfPersistentVoters --- cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs | 9 +++++++-- .../test/Test/Cardano/Crypto/Peras.hs | 11 +++++++++-- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs index 32aaabed6..30b30561a 100644 --- a/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs +++ b/cardano-crypto-peras/src/Cardano/Crypto/Peras/Cert.hs @@ -17,6 +17,7 @@ module Cardano.Crypto.Peras.Cert ( perasCertVotersToSeats, perasCertNumberOfVoters, perasCertNumberOfNonPersistentVoters, + perasCertNumberOfPersistentVoters, PerasCert (..), PerasRoundNo (..), PerasBoostedBlock (..), @@ -112,14 +113,14 @@ mkPerasCertVoters bitmap vrfOutputs = do pure (UnsafePerasCertVoters bitmap vrfOutputs) perasCertVotersToSeats :: PerasCertVoters -> NonEmpty (PerasSeatIndex, Maybe PerasVRFOutput) -perasCertVotersToSeats UnsafePerasCertVoters {perasCertVotersBitmap, perasCertNonPersistentVRFOutputs} = +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 = length seats - length perasCertNonPersistentVRFOutputs + numPersistent = perasCertNumberOfPersistentVoters voters proofs = replicate numPersistent Nothing <> fmap Just perasCertNonPersistentVRFOutputs perasCertVotersFromSeats :: @@ -142,6 +143,10 @@ perasCertNumberOfVoters = perasVotersBitmapSize . perasCertVotersBitmap perasCertNumberOfNonPersistentVoters :: PerasCertVoters -> Int perasCertNumberOfNonPersistentVoters = length . perasCertNonPersistentVRFOutputs +perasCertNumberOfPersistentVoters :: PerasCertVoters -> Int +perasCertNumberOfPersistentVoters voters = + perasCertNumberOfVoters voters - perasCertNumberOfNonPersistentVoters voters + {------------------------------------------------------------------------------- Certificates -------------------------------------------------------------------------------} diff --git a/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs b/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs index 0c5d03785..4985df634 100644 --- a/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs +++ b/cardano-crypto-peras/test/Test/Cardano/Crypto/Peras.hs @@ -15,6 +15,7 @@ import Cardano.Crypto.Peras.Cert ( PerasCertSize (..), mkPerasCertVoters, perasCertNumberOfNonPersistentVoters, + perasCertNumberOfPersistentVoters, perasCertNumberOfVoters, perasCertSizeUpperBound, perasCertVotersFromSeats, @@ -52,8 +53,14 @@ spec = do prop "counts voters" $ forAll (genPerasCertVoters True) $ \v -> let seats = perasCertVotersToSeats v - in (perasCertNumberOfVoters v, perasCertNumberOfNonPersistentVoters v) - === (length seats, length (NonEmpty.filter ((/= Nothing) . snd) seats)) + 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