From 67ce16ea4e33b3399442f177279939f60f5f3d96 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 9 Jun 2026 19:26:55 +0200 Subject: [PATCH 01/28] Scaffold an initial cardano-crypto-leios package --- cabal.project | 1 + cardano-crypto-leios/CHANGELOG.md | 6 + cardano-crypto-leios/LICENSE | 72 +++++++++++ cardano-crypto-leios/README.md | 11 ++ .../cardano-crypto-leios.cabal | 48 +++++++ .../src/Cardano/Crypto/Leios.hs | 120 ++++++++++++++++++ 6 files changed, 258 insertions(+) create mode 100644 cardano-crypto-leios/CHANGELOG.md create mode 100644 cardano-crypto-leios/LICENSE create mode 100644 cardano-crypto-leios/README.md create mode 100644 cardano-crypto-leios/cardano-crypto-leios.cabal create mode 100644 cardano-crypto-leios/src/Cardano/Crypto/Leios.hs diff --git a/cabal.project b/cabal.project index fe7cb9024..b131cee32 100644 --- a/cabal.project +++ b/cabal.project @@ -19,6 +19,7 @@ packages: cardano-base cardano-binary cardano-crypto-class + cardano-crypto-leios cardano-crypto-peras cardano-crypto-praos cardano-crypto-wallet diff --git a/cardano-crypto-leios/CHANGELOG.md b/cardano-crypto-leios/CHANGELOG.md new file mode 100644 index 000000000..96e4d7f3d --- /dev/null +++ b/cardano-crypto-leios/CHANGELOG.md @@ -0,0 +1,6 @@ +# Changelog for `cardano-crypto-leios` + +## 0.1.0.0 + +* Initial version: `EbHash` and `LeiosCert` extracted from + `ouroboros-consensus` and `cardano-ledger-core` per CIP-0164. diff --git a/cardano-crypto-leios/LICENSE b/cardano-crypto-leios/LICENSE new file mode 100644 index 000000000..ec6d17953 --- /dev/null +++ b/cardano-crypto-leios/LICENSE @@ -0,0 +1,72 @@ +Apache License + +Version 2.0, January 2004 + +http://www.apache.org/licenses/ + +TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + +1. Definitions. + +"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. + +"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. + +"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. + +"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. + +"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. + +"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. + +"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). + +"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. + +"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." + +"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. + +2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. + +3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. + +4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: + +You must give any other recipients of the Work or Derivative Works a copy of this License; and +You must cause any modified files to carry prominent notices stating that You changed the files; and +You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and +If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. + +You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. +5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. + +6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. + +7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. + +8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. + +9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. + +END OF TERMS AND CONDITIONS + +APPENDIX: How to apply the Apache License to your work. + +To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. + +Copyright 2026 Input Output Global, Inc. + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + diff --git a/cardano-crypto-leios/README.md b/cardano-crypto-leios/README.md new file mode 100644 index 000000000..2555c4f8d --- /dev/null +++ b/cardano-crypto-leios/README.md @@ -0,0 +1,11 @@ +# cardano-crypto-leios + +Data types for Leios protocol artifacts as specified in +[CIP-0164](https://github.com/cardano-scaling/CIPs/blob/leios/CIP-0164/README.md): + +- `EbHash` — hash of the RB header that announced an endorser block (`hash32`). +- `LeiosCert` — an aggregated BLS certificate over committee votes for an EB. + +Both `cardano-ledger` (which embeds `LeiosCert` in the Dijkstra-era block body) +and `ouroboros-consensus` (which validates and resolves CertRBs) depend on this +package so they agree on the type. diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal new file mode 100644 index 000000000..28d5c56c5 --- /dev/null +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -0,0 +1,48 @@ +cabal-version: 3.0 +name: cardano-crypto-leios +version: 0.1.0.0 +synopsis: Crypto primitives for Leios +description: + Data types for the Leios cryptographic artifacts as specified in CIP-0164. + +license: Apache-2.0 +license-files: LICENSE +author: IOHK +maintainer: operations@iohk.io +copyright: 2026 Input Output Global, Inc. +category: Currency +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +common base + build-depends: base >=4.18 && <5 + +common project-config + default-language: Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + +library + import: base, project-config + hs-source-dirs: src + exposed-modules: + Cardano.Crypto.Leios + + build-depends: + base16-bytestring, + bytestring, + cardano-binary, + cardano-crypto-class, + cardano-slotting, + cborg, + deepseq, + nothunks, + serialise, diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs new file mode 100644 index 000000000..762ed75e8 --- /dev/null +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Cardano.Crypto.Leios ( + -- * Endorser block hashes + EbHash (..), + encodeEbHash, + decodeEbHash, + prettyEbHash, + + -- * Leios certificates + LeiosCert (..), + encodeLeiosCert, + decodeLeiosCert, + + -- * BLS signing primitives + LeiosDSIGN, + LeiosSigningKey, + LeiosVerificationKey, + LeiosSignature, +) where + +import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), enforceSize) +import Cardano.Crypto.DSIGN ( + SigDSIGN, + SignKeyDSIGN, + VerKeyDSIGN, + decodeSigDSIGN, + encodeSigDSIGN, + ) +import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN) +import Cardano.Slotting.Slot (SlotNo) +import Codec.CBOR.Decoding (Decoder, decodeBytes) +import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) +import Codec.Serialise (Serialise) +import Control.DeepSeq (NFData) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS8 +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +-- | Hash of the RB header that announced the endorser block. +-- +-- Per CIP-0164 this is a @hash32@ (Blake2b-256, 32 bytes); the underlying +-- bytes are stored unwrapped to stay representation-compatible with the +-- previous definition in @ouroboros-consensus@. +newtype EbHash = MkEbHash {ebHashBytes :: ByteString} + deriving stock (Eq, Ord, Generic) + deriving newtype (NFData, NoThunks, Serialise, ToCBOR, FromCBOR) + +instance Show EbHash where + show = prettyEbHash + +encodeEbHash :: EbHash -> Encoding +encodeEbHash (MkEbHash bytes) = encodeBytes bytes + +decodeEbHash :: Decoder s EbHash +decodeEbHash = MkEbHash <$> decodeBytes + +prettyEbHash :: EbHash -> String +prettyEbHash (MkEbHash bytes) = BS8.unpack (Base16.encode bytes) + +-- | Leios uses BLS12-381 MinSig as its signature scheme; see CIP-0164. +type LeiosDSIGN = BLS12381MinSigDSIGN + +type LeiosSigningKey = SignKeyDSIGN LeiosDSIGN + +type LeiosVerificationKey = VerKeyDSIGN LeiosDSIGN + +type LeiosSignature = SigDSIGN LeiosDSIGN + +-- | A Leios certificate over an endorser block, as specified in CIP-0164: +-- +-- @ +-- leios_certificate = +-- [ slot_no +-- , endorser_block_hash +-- , signers : bytes ; bitfield over the epoch's committee, MSB-first +-- , aggregated_signature : leios_bls_signature +-- ] +-- @ +-- +-- The committee is derived deterministically from the active stake +-- distribution for the epoch of the announcing RB, so individual voter +-- identities and eligibility proofs are not carried in the certificate; +-- 'signers' is a @⌈N\/8⌉@-byte bitfield over the committee where bit @i@ +-- is set iff voter index @i@ signed. +data LeiosCert = LeiosCert + { slotNo :: !SlotNo + , endorserBlockHash :: !EbHash + , signers :: !ByteString + , aggregatedSignature :: !LeiosSignature + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +-- | Plain CBOR encoder for 'LeiosCert', matching the CDDL above. Use this +-- (rather than a 'ToCBOR'/'EncCBOR' class instance) at call sites so we +-- don't need orphan CBOR instances for the underlying BLS 'SigDSIGN'. +encodeLeiosCert :: LeiosCert -> Encoding +encodeLeiosCert cert = + encodeListLen 4 + <> toCBOR (slotNo cert) + <> encodeEbHash (endorserBlockHash cert) + <> encodeBytes (signers cert) + <> encodeSigDSIGN (aggregatedSignature cert) + +decodeLeiosCert :: Decoder s LeiosCert +decodeLeiosCert = do + enforceSize "LeiosCert" 4 + LeiosCert + <$> fromCBOR + <*> decodeEbHash + <*> decodeBytes + <*> decodeSigDSIGN From 75ea6ce53f13cb81e297af71a9292b574cd0aa56 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 10:31:11 +0200 Subject: [PATCH 02/28] Not include slot/eb hash in leios certificate --- .../cardano-crypto-leios.cabal | 3 - .../src/Cardano/Crypto/Leios.hs | 89 +++++-------------- 2 files changed, 22 insertions(+), 70 deletions(-) diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 28d5c56c5..c1a8907c9 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -37,12 +37,9 @@ library Cardano.Crypto.Leios build-depends: - base16-bytestring, bytestring, cardano-binary, cardano-crypto-class, - cardano-slotting, cborg, deepseq, nothunks, - serialise, diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 762ed75e8..1fbfbc89d 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -2,29 +2,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -module Cardano.Crypto.Leios ( - -- * Endorser block hashes - EbHash (..), - encodeEbHash, - decodeEbHash, - prettyEbHash, +-- | Cryptographic data types and operations used in Leios per CIP-164. Leios +-- uses BLS12-381 MinSig as its signature scheme and definees a 'LeiosCert' that +-- can be included into blocks. +module Cardano.Crypto.Leios where - -- * Leios certificates - LeiosCert (..), - encodeLeiosCert, - decodeLeiosCert, - - -- * BLS signing primitives - LeiosDSIGN, - LeiosSigningKey, - LeiosVerificationKey, - LeiosSignature, -) where - -import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR), enforceSize) +import Cardano.Binary (enforceSize) import Cardano.Crypto.DSIGN ( SigDSIGN, SignKeyDSIGN, @@ -33,39 +19,15 @@ import Cardano.Crypto.DSIGN ( encodeSigDSIGN, ) import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN) -import Cardano.Slotting.Slot (SlotNo) import Codec.CBOR.Decoding (Decoder, decodeBytes) import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) -import Codec.Serialise (Serialise) import Control.DeepSeq (NFData) import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS8 import GHC.Generics (Generic) import NoThunks.Class (NoThunks) --- | Hash of the RB header that announced the endorser block. --- --- Per CIP-0164 this is a @hash32@ (Blake2b-256, 32 bytes); the underlying --- bytes are stored unwrapped to stay representation-compatible with the --- previous definition in @ouroboros-consensus@. -newtype EbHash = MkEbHash {ebHashBytes :: ByteString} - deriving stock (Eq, Ord, Generic) - deriving newtype (NFData, NoThunks, Serialise, ToCBOR, FromCBOR) - -instance Show EbHash where - show = prettyEbHash +-- * Cryptographic primitives -encodeEbHash :: EbHash -> Encoding -encodeEbHash (MkEbHash bytes) = encodeBytes bytes - -decodeEbHash :: Decoder s EbHash -decodeEbHash = MkEbHash <$> decodeBytes - -prettyEbHash :: EbHash -> String -prettyEbHash (MkEbHash bytes) = BS8.unpack (Base16.encode bytes) - --- | Leios uses BLS12-381 MinSig as its signature scheme; see CIP-0164. type LeiosDSIGN = BLS12381MinSigDSIGN type LeiosSigningKey = SignKeyDSIGN LeiosDSIGN @@ -74,47 +36,40 @@ type LeiosVerificationKey = VerKeyDSIGN LeiosDSIGN type LeiosSignature = SigDSIGN LeiosDSIGN --- | A Leios certificate over an endorser block, as specified in CIP-0164: +-- * Leios certificates + +-- | A Leios certificate over an endorser block, as specified in CIP-164: -- -- @ -- leios_certificate = --- [ slot_no --- , endorser_block_hash --- , signers : bytes ; bitfield over the epoch's committee, MSB-first +-- [ signers : bytes ; bitfield over the epoch's committee, MSB-first -- , aggregated_signature : leios_bls_signature -- ] -- @ -- --- The committee is derived deterministically from the active stake --- distribution for the epoch of the announcing RB, so individual voter --- identities and eligibility proofs are not carried in the certificate; --- 'signers' is a @⌈N\/8⌉@-byte bitfield over the committee where bit @i@ --- is set iff voter index @i@ signed. +-- The committee is derived deterministically from the active stake distribution +-- for the epoch of the announcing RB, so individual voter identities and +-- eligibility proofs are not carried in the certificate; 'signers' is a +-- @⌈N\/8⌉@-byte bitfield over the committee where bit @i@ is set iff voter +-- index @i@ signed. data LeiosCert = LeiosCert - { slotNo :: !SlotNo - , endorserBlockHash :: !EbHash - , signers :: !ByteString + { signers :: !ByteString , aggregatedSignature :: !LeiosSignature } deriving stock (Show, Eq, Generic) deriving anyclass (NFData, NoThunks) --- | Plain CBOR encoder for 'LeiosCert', matching the CDDL above. Use this --- (rather than a 'ToCBOR'/'EncCBOR' class instance) at call sites so we --- don't need orphan CBOR instances for the underlying BLS 'SigDSIGN'. +-- | Plain CBOR encoder for 'LeiosCert', matching the CDDL in 'LeiosCert'. encodeLeiosCert :: LeiosCert -> Encoding encodeLeiosCert cert = encodeListLen 4 - <> toCBOR (slotNo cert) - <> encodeEbHash (endorserBlockHash cert) - <> encodeBytes (signers cert) - <> encodeSigDSIGN (aggregatedSignature cert) + <> encodeBytes cert.signers + <> encodeSigDSIGN cert.aggregatedSignature +-- | Plain CBOR decoder for 'LeiosCert', matching the CDDL in 'LeiosCert'. decodeLeiosCert :: Decoder s LeiosCert decodeLeiosCert = do enforceSize "LeiosCert" 4 LeiosCert - <$> fromCBOR - <*> decodeEbHash - <*> decodeBytes + <$> decodeBytes <*> decodeSigDSIGN From d69874c1b3f7b055347ef0b5afe31566d3c240e3 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 10:47:19 +0200 Subject: [PATCH 03/28] Add cardano-crypto-leios test suite Roundtrip and golden tests for LeiosCert --- .../cardano-crypto-leios.cabal | 20 +++++ .../src/Cardano/Crypto/Leios.hs | 4 +- cardano-crypto-leios/test/Main.hs | 11 +++ .../test/Test/Cardano/Crypto/Leios.hs | 76 +++++++++++++++++++ cardano-crypto-leios/test/golden/LeiosCert | 4 + 5 files changed, 113 insertions(+), 2 deletions(-) create mode 100644 cardano-crypto-leios/test/Main.hs create mode 100644 cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs create mode 100644 cardano-crypto-leios/test/golden/LeiosCert diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index c1a8907c9..6b033c930 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -43,3 +43,23 @@ library cborg, deepseq, nothunks, + +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.Leios + + build-depends: + bytestring, + cardano-binary:{cardano-binary, testlib}, + cardano-crypto-class, + cardano-crypto-leios, + cardano-prelude-test, + hedgehog, + + ghc-options: + -threaded + -rtsopts diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 1fbfbc89d..2479d6d81 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -62,14 +62,14 @@ data LeiosCert = LeiosCert -- | Plain CBOR encoder for 'LeiosCert', matching the CDDL in 'LeiosCert'. encodeLeiosCert :: LeiosCert -> Encoding encodeLeiosCert cert = - encodeListLen 4 + encodeListLen 2 <> encodeBytes cert.signers <> encodeSigDSIGN cert.aggregatedSignature -- | Plain CBOR decoder for 'LeiosCert', matching the CDDL in 'LeiosCert'. decodeLeiosCert :: Decoder s LeiosCert decodeLeiosCert = do - enforceSize "LeiosCert" 4 + enforceSize "LeiosCert" 2 LeiosCert <$> decodeBytes <*> decodeSigDSIGN diff --git a/cardano-crypto-leios/test/Main.hs b/cardano-crypto-leios/test/Main.hs new file mode 100644 index 000000000..9708d1bb6 --- /dev/null +++ b/cardano-crypto-leios/test/Main.hs @@ -0,0 +1,11 @@ +module Main (main) where + +import qualified Test.Cardano.Crypto.Leios +import Test.Cardano.Prelude (runTests) +import Prelude + +main :: IO () +main = + runTests + [ Test.Cardano.Crypto.Leios.tests + ] diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs new file mode 100644 index 000000000..4c16673a5 --- /dev/null +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Crypto.Leios (tests, exampleCert) where + +import qualified Cardano.Binary as CBOR +import Cardano.Crypto.DSIGN (genKeyDSIGN, seedSizeDSIGN, signDSIGN) +import Cardano.Crypto.DSIGN.BLS12381 (minSigPoPDST) +import Cardano.Crypto.Leios ( + LeiosCert (..), + LeiosDSIGN, + decodeLeiosCert, + encodeLeiosCert, + ) +import Cardano.Crypto.Seed (mkSeedFromBytes) +import qualified Data.ByteString as BS +import Data.Proxy (Proxy (Proxy)) +import Hedgehog (Gen, Group (..), Property, checkParallel, forAll, property, tripping) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Cardano.Binary.Helpers.GoldenRoundTrip (goldenTestCBORExplicit) + +tests :: IO Bool +tests = + checkParallel $ + Group + "Test.Cardano.Crypto.Leios" + [ ("prop_roundtrip_LeiosCert", prop_roundtrip_LeiosCert) + , ("prop_golden_LeiosCert", prop_golden_LeiosCert) + ] + +-- | A 'LeiosCert' with a real (deterministically-derived) BLS aggregated +-- signature and a 'signers' bitfield whose length walks the CBOR uint +-- width boundaries (1 / 2 / 3-byte length headers). +genLeiosCert :: Gen LeiosCert +genLeiosCert = do + let seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) + seedBytes <- Gen.bytes (Range.singleton seedLen) + msg <- Gen.bytes (Range.linear 0 256) + signersLen <- Gen.element [0, 1, 23, 24, 255, 256] + signersBytes <- Gen.bytes (Range.singleton signersLen) + let sk = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes seedBytes) + pure + LeiosCert + { signers = signersBytes + , aggregatedSignature = signDSIGN minSigPoPDST msg sk + } + +prop_roundtrip_LeiosCert :: Property +prop_roundtrip_LeiosCert = property $ do + cert <- forAll genLeiosCert + tripping + cert + (CBOR.serialize . encodeLeiosCert) + (CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert) + +-- | Locks the on-wire encoding of 'LeiosCert' against accidental drift. +-- Inputs are fixed (constant seed, fixed message, fixed bitfield) so the +-- byte-for-byte golden is reproducible. +prop_golden_LeiosCert :: Property +prop_golden_LeiosCert = + goldenTestCBORExplicit "LeiosCert" encodeLeiosCert decodeLeiosCert exampleCert path + where + path = "test/golden/LeiosCert" + +exampleCert :: LeiosCert +exampleCert = + LeiosCert + { signers = BS.pack [0xF0] + , aggregatedSignature = signDSIGN minSigPoPDST exampleMessage exampleSigningKey + } + where + seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) + exampleSigningKey = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen 0x01)) + exampleMessage = "leios-golden-message" :: BS.ByteString diff --git a/cardano-crypto-leios/test/golden/LeiosCert b/cardano-crypto-leios/test/golden/LeiosCert new file mode 100644 index 000000000..d3b135580 --- /dev/null +++ b/cardano-crypto-leios/test/golden/LeiosCert @@ -0,0 +1,4 @@ +00: 8241f05830b40d05252e372ab554776a +10: 5b713d618d4d8563349f24e2d37a3ce2 +20: 3de395a205f610db5d503bacf6e5d1f8 +30: 4b15506216 From 0268dc396deef37ce722163be6a82485e3190125 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 11:15:16 +0200 Subject: [PATCH 04/28] Add functions to aggregateLeiosCert and verifyLeiosCert These are the only means to create and verify leios certificates about a certain message (a leios vote). Committee selection was deliberately kept out of scope --- .../cardano-crypto-leios.cabal | 4 + .../src/Cardano/Crypto/Leios.hs | 261 +++++++++++++++++- .../test/Test/Cardano/Crypto/Leios.hs | 114 +++++++- 3 files changed, 365 insertions(+), 14 deletions(-) diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 6b033c930..0b65ec1d8 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -41,8 +41,10 @@ library cardano-binary, cardano-crypto-class, cborg, + containers, deepseq, nothunks, + vector, test-suite tests import: base, project-config @@ -58,7 +60,9 @@ test-suite tests cardano-crypto-class, cardano-crypto-leios, cardano-prelude-test, + containers, hedgehog, + vector, ghc-options: -threaded diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 2479d6d81..be8c27935 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -2,27 +2,73 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +-- Named fields on the 'InsufficientWeight' variant of 'VerificationError' +-- are wanted at the call site; the project-wide @-Wpartial-fields@ would +-- otherwise reject record syntax on a single sum-type alternative. +{-# OPTIONS_GHC -Wno-partial-fields #-} -- | Cryptographic data types and operations used in Leios per CIP-164. Leios --- uses BLS12-381 MinSig as its signature scheme and definees a 'LeiosCert' that --- can be included into blocks. -module Cardano.Crypto.Leios where +-- uses BLS12-381 MinSig as its signature scheme and defines a 'LeiosCert' that +-- can be included into blocks. This module deliberately not includes a +-- 'LeiosVote' because the vote itself is not an artifact that is on-chain. +module Cardano.Crypto.Leios ( + -- * Cryptographic primitives + LeiosDSIGN, + LeiosSigningKey, + LeiosVerificationKey, + LeiosSignature, + leiosSignContext, + + -- * Voting committee + Committee (..), + Weight, + committeeSize, + VoterId (..), + + -- * Certificates + LeiosCert (..), + encodeLeiosCert, + decodeLeiosCert, + + -- ** Construction + aggregateLeiosCert, + AggregationError (..), + + -- ** Verification + verifyLeiosCert, + VerificationError (..), +) where import Cardano.Binary (enforceSize) import Cardano.Crypto.DSIGN ( + DSIGNAggregatable (aggregateSigsDSIGN, uncheckedAggregateVerKeysDSIGN), SigDSIGN, SignKeyDSIGN, VerKeyDSIGN, decodeSigDSIGN, encodeSigDSIGN, + verifyDSIGN, ) -import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN) +import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN, BLS12381SignContext, minSigPoPDST) +import Cardano.Crypto.Util (SignableRepresentation) import Codec.CBOR.Decoding (Decoder, decodeBytes) import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) import Control.DeepSeq (NFData) +import Control.Monad (when) +import Data.Bits (setBit, testBit) import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Foldable (foldlM) +import Data.List (foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word (Word16, Word8) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -36,6 +82,49 @@ type LeiosVerificationKey = VerKeyDSIGN LeiosDSIGN type LeiosSignature = SigDSIGN LeiosDSIGN +-- | The BLS12-381 MinSig proof-of-possession ciphersuite DST used by Leios, +-- per CIP-164. Pass this as the 'ContextDSIGN' to 'signDSIGN' / 'verifyDSIGN'. +leiosSignContext :: BLS12381SignContext +leiosSignContext = minSigPoPDST + +-- * Voting committee + +-- | A weight assigned to a committee voter, normalised so the total over a +-- committee sums to @1@. Threshold checks in 'verifyLeiosCert' are against +-- this same scale. +type Weight = Rational + +-- | A committee member's seat index. The index is the voter's position in +-- 'committeeVoters' and determines its bit in the 'LeiosCert' @signers@ +-- bitfield (MSB-first within each byte, so voter @i@ ↔ bit @7-(i mod 8)@ of +-- byte @i \`div\` 8@). +newtype VoterId = VoterId {voterIndex :: Word16} + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData, NoThunks) + +-- | The voting committee for a Leios epoch: an ordered vector of +-- @(weight, verification-key)@ pairs. +-- +-- Position determines the voter's 'VoterId' and its bit in the certificate's +-- bitfield, so callers must keep the order stable between construction and +-- verification of any cert. +-- +-- This package intentionally does not provide committee selection — sampling +-- voters from the active stake distribution lives in consensus/ledger. +-- However, callers are responsible for ensuring that every voter's BLS +-- proof-of-possession has been verified before a 'Committee' value is built; +-- 'verifyLeiosCert' and 'aggregateLeiosCert' both rely on this invariant to +-- skip per-key PoP checks (they use 'uncheckedAggregateVerKeysDSIGN' / +-- 'aggregateSigsDSIGN' under the hood). Passing in unchecked keys defeats +-- the security of the aggregate signature. +newtype Committee = Committee {committeeVoters :: Vector (Weight, LeiosVerificationKey)} + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + +-- | Number of seats in the committee. +committeeSize :: Committee -> Int +committeeSize = V.length . committeeVoters + -- * Leios certificates -- | A Leios certificate over an endorser block, as specified in CIP-164: @@ -47,11 +136,15 @@ type LeiosSignature = SigDSIGN LeiosDSIGN -- ] -- @ -- --- The committee is derived deterministically from the active stake distribution --- for the epoch of the announcing RB, so individual voter identities and --- eligibility proofs are not carried in the certificate; 'signers' is a --- @⌈N\/8⌉@-byte bitfield over the committee where bit @i@ is set iff voter --- index @i@ signed. +-- The committee is derived deterministically from the active stake +-- distribution for the epoch of the announcing RB, so individual voter +-- identities and eligibility proofs are not carried in the certificate; +-- 'signers' is a @⌈N\/8⌉@-byte bitfield over the committee where bit @i@ is +-- set iff voter index @i@ signed. +-- +-- Producers should build 'LeiosCert' values via 'aggregateLeiosCert' and +-- consumers verify them via 'verifyLeiosCert'; the bitfield layout is an +-- implementation detail of the wire format. data LeiosCert = LeiosCert { signers :: !ByteString , aggregatedSignature :: !LeiosSignature @@ -73,3 +166,153 @@ decodeLeiosCert = do LeiosCert <$> decodeBytes <*> decodeSigDSIGN + +-- ** Construction + +data AggregationError + = -- | A voter index in the contributions is past the committee bound. + VoterIdOutOfBounds !VoterId + | -- | BLS signature aggregation failed (e.g. malformed input signature). + BLSAggregationFailed !String + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Build a 'LeiosCert' from the contributions of committee members. +-- +-- == Caller obligations +-- +-- All signatures must be over the same message. Individual 'LeiosSignature' +-- values are not verified here, and once aggregated they cannot be told apart. +-- Feeding signatures cast over different messages produces a 'LeiosCert' that +-- will silently fail 'verifyLeiosCert' with no indication of which contribution +-- was wrong. +-- +-- == What this function does +-- +-- * Range-checks each 'VoterId' against the committee. +-- * Encodes the bitfield over the committee and aggregates the input +-- signatures. +-- +-- This is the only way to construct a 'LeiosCert' from outside the package; +-- the bitfield layout is an internal wire-format detail. +aggregateLeiosCert :: + Committee -> + Map VoterId LeiosSignature -> + Either AggregationError LeiosCert +aggregateLeiosCert committee contributions = do + let n = committeeSize committee + entries = Map.toAscList contributions + case [v | (v, _) <- entries, fromIntegral (voterIndex v) >= n] of + v : _ -> Left (VoterIdOutOfBounds v) + [] -> pure () + aggSig <- + case aggregateSigsDSIGN (map snd entries) of + Left e -> Left (BLSAggregationFailed e) + Right s -> Right s + pure + LeiosCert + { signers = encodeSignersBitfield n [fromIntegral (voterIndex v) | (v, _) <- entries] + , aggregatedSignature = aggSig + } + +-- ** Verification + +data VerificationError + = -- | 'signers' bitfield is longer than @⌈committeeSize/8⌉@ bytes. + MalformedSigners + | -- | The aggregate-BLS verification failed (wrong message, tampered + -- signature, or a bitfield/aggregate mismatch). + InvalidSignature + | -- | Sum of signers' weights is below the required threshold. + InsufficientWeight {got :: !Weight, required :: !Weight} + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Verify a 'LeiosCert' against a 'Committee', a weight threshold, and the +-- message the signers were supposed to have signed. +-- +-- == Caller obligations +-- +-- Every voter in the 'Committee' must have had its BLS proof-of-possession +-- verified beforehand (when the committee was selected). 'verifyLeiosCert' +-- uses 'uncheckedAggregateVerKeysDSIGN' and does not re-check PoPs; passing +-- in an unchecked committee breaks the security of the aggregate signature. +-- +-- == What this function does +-- +-- 1. Decodes the 'signers' bitfield to the list of contributing voter +-- indices, rejecting an oversized bitfield with +-- 'MalformedSigners'. +-- 2. Sums those voters' weights from the committee; short-circuits with +-- 'InsufficientWeight' if the sum is below the threshold, +-- which avoids the BLS pairing when the bitfield can't reach quorum on +-- its own. +-- 3. Aggregates the contributing verification keys and verifies the +-- certificate's 'aggregatedSignature' against that aggregate key over +-- @msg@. +verifyLeiosCert :: + SignableRepresentation msg => + Committee -> + -- | Minimum signer weight required to accept the cert. + Weight -> + -- | The message the signers signed. + msg -> + LeiosCert -> + -- | Total weight of the contributing signers on success. + Either VerificationError Weight +verifyLeiosCert committee required msg cert = do + let voters = committeeVoters committee + n = V.length voters + idxs <- + maybe (Left MalformedSigners) Right $ + decodeSignersBitfield n cert.signers + (got, vks) <- foldlM (accumSigner voters) (0, []) idxs + when (got < required) $ + Left InsufficientWeight {got, required} + aggVk <- + case uncheckedAggregateVerKeysDSIGN (reverse vks) of + Left _ -> Left InvalidSignature + Right k -> Right k + case verifyDSIGN leiosSignContext aggVk msg cert.aggregatedSignature of + Left _ -> Left InvalidSignature + Right () -> Right got + where + -- The bitfield decoder already enforced @i < n@; if the committee is + -- shorter than the decoder's idea of @n@ we treat it as a malformed cert. + accumSigner voters (w, ks) i = case voters V.!? i of + Nothing -> Left MalformedSigners + Just (w', vk) -> Right (w + w', vk : ks) + +-- * Internal bitfield codec + +-- +-- Not exported: producers go through 'aggregateLeiosCert' and consumers +-- through 'verifyLeiosCert'. + +-- | Encode the @⌈N\/8⌉@-byte MSB-first bitfield over a committee of size @N@. +-- Indices outside the committee bound are silently dropped. +encodeSignersBitfield :: Int -> [Int] -> ByteString +encodeSignersBitfield n idxs = BS.pack [byteFor b | b <- [0 .. expectedBytes - 1]] + where + expectedBytes = (n + 7) `div` 8 + marked = Set.fromList [i | i <- idxs, i >= 0, i < n] + byteFor b = + foldl' + (\acc bitIx -> if Set.member (b * 8 + bitIx) marked then setBit acc (7 - bitIx) else acc) + (0 :: Word8) + [0 .. 7] + +-- | Decode an MSB-first bitfield to its set-bit indices in ascending order. +-- Returns 'Nothing' if the bitfield is longer than @⌈N\/8⌉@ bytes (malformed +-- certificate); a shorter bitfield is accepted as if it were right-padded +-- with zero bytes. +decodeSignersBitfield :: Int -> ByteString -> Maybe [Int] +decodeSignersBitfield n bs + | BS.length bs > expectedBytes = Nothing + | otherwise = Just $ do + (byteIx, byte) <- zip [0 ..] (BS.unpack bs) + bitIx <- [0 .. 7] + let globalIx = byteIx * 8 + bitIx + [globalIx | globalIx < n, testBit byte (7 - bitIx)] + where + expectedBytes = (n + 7) `div` 8 diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 4c16673a5..19ee310b8 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -5,18 +5,43 @@ module Test.Cardano.Crypto.Leios (tests, exampleCert) where import qualified Cardano.Binary as CBOR -import Cardano.Crypto.DSIGN (genKeyDSIGN, seedSizeDSIGN, signDSIGN) -import Cardano.Crypto.DSIGN.BLS12381 (minSigPoPDST) +import Cardano.Crypto.DSIGN ( + DSIGNAlgorithm (deriveVerKeyDSIGN), + genKeyDSIGN, + seedSizeDSIGN, + signDSIGN, + ) import Cardano.Crypto.Leios ( + AggregationError (..), + Committee (..), LeiosCert (..), LeiosDSIGN, + LeiosSigningKey, + VerificationError (..), + VoterId (..), + aggregateLeiosCert, decodeLeiosCert, encodeLeiosCert, + leiosSignContext, + verifyLeiosCert, ) import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) -import Hedgehog (Gen, Group (..), Property, checkParallel, forAll, property, tripping) +import qualified Data.Vector as V +import Hedgehog ( + Gen, + Group (..), + Property, + annotateShow, + checkParallel, + forAll, + property, + tripping, + withTests, + (===), + ) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Cardano.Binary.Helpers.GoldenRoundTrip (goldenTestCBORExplicit) @@ -28,8 +53,14 @@ tests = "Test.Cardano.Crypto.Leios" [ ("prop_roundtrip_LeiosCert", prop_roundtrip_LeiosCert) , ("prop_golden_LeiosCert", prop_golden_LeiosCert) + , ("prop_verifyLeiosCert_accepts_aggregated", prop_verifyLeiosCert_accepts_aggregated) + , ("prop_verifyLeiosCert_rejects_wrong_message", prop_verifyLeiosCert_rejects_wrong_message) + , ("prop_verifyLeiosCert_rejects_below_threshold", prop_verifyLeiosCert_rejects_below_threshold) + , ("prop_aggregateLeiosCert_rejects_out_of_range", prop_aggregateLeiosCert_rejects_out_of_range) ] +-- * CBOR roundtrip / golden + -- | A 'LeiosCert' with a real (deterministically-derived) BLS aggregated -- signature and a 'signers' bitfield whose length walks the CBOR uint -- width boundaries (1 / 2 / 3-byte length headers). @@ -44,7 +75,7 @@ genLeiosCert = do pure LeiosCert { signers = signersBytes - , aggregatedSignature = signDSIGN minSigPoPDST msg sk + , aggregatedSignature = signDSIGN leiosSignContext msg sk } prop_roundtrip_LeiosCert :: Property @@ -68,9 +99,82 @@ exampleCert :: LeiosCert exampleCert = LeiosCert { signers = BS.pack [0xF0] - , aggregatedSignature = signDSIGN minSigPoPDST exampleMessage exampleSigningKey + , aggregatedSignature = signDSIGN leiosSignContext exampleMessage exampleSigningKey } where seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) exampleSigningKey = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen 0x01)) exampleMessage = "leios-golden-message" :: BS.ByteString + +-- * aggregate / verify + +-- | Equal-weighted committee of @n@ voters derived from a fixed seed pattern. +-- Returns the signing keys alongside the committee so tests can produce +-- contributions. +fixedCommittee :: Int -> ([LeiosSigningKey], Committee) +fixedCommittee n = + ( sks + , Committee (V.fromList [(1 / fromIntegral n, deriveVerKeyDSIGN sk) | sk <- sks]) + ) + where + seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) + sks = + [ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen (fromIntegral i))) + | i <- [1 .. n] + ] + +-- | All committee members sign the same message; the resulting cert verifies +-- against that committee, threshold and message, and reports full weight. +prop_verifyLeiosCert_accepts_aggregated :: Property +prop_verifyLeiosCert_accepts_aggregated = withTests 20 $ property $ do + n <- forAll (Gen.int (Range.linear 1 16)) + msg <- forAll (Gen.bytes (Range.linear 0 64)) + let (sks, committee) = fixedCommittee n + contributions = + Map.fromList + [ (VoterId (fromIntegral i), signDSIGN leiosSignContext msg sk) + | (i, sk) <- zip [0 :: Int ..] sks + ] + cert <- case aggregateLeiosCert committee contributions of + Right c -> pure c + Left e -> do annotateShow e; fail "aggregateLeiosCert failed" + verifyLeiosCert committee 1 msg cert === Right 1 + +-- | A cert built over message @m1@ must not verify against message @m2@. +prop_verifyLeiosCert_rejects_wrong_message :: Property +prop_verifyLeiosCert_rejects_wrong_message = withTests 20 $ property $ do + let n = 4 + (sks, committee) = fixedCommittee n + m1 = "leios-message-one" :: BS.ByteString + m2 = "leios-message-two" :: BS.ByteString + contributions = + Map.fromList + [ (VoterId (fromIntegral i), signDSIGN leiosSignContext m1 sk) + | (i, sk) <- zip [0 :: Int ..] sks + ] + cert <- case aggregateLeiosCert committee contributions of + Right c -> pure c + Left e -> do annotateShow e; fail "aggregateLeiosCert failed" + verifyLeiosCert committee 1 m2 cert === Left InvalidSignature + +-- | A cert whose signers' summed weight is below the threshold must be +-- rejected with 'InsufficientWeight', without ever performing the BLS +-- pairing. +prop_verifyLeiosCert_rejects_below_threshold :: Property +prop_verifyLeiosCert_rejects_below_threshold = withTests 1 $ property $ do + let n = 4 -- four equal-weight voters; one signer ⇒ weight = 1/4 + (sks, committee) = fixedCommittee n + msg = "leios-quorum-test" :: BS.ByteString + contributions = Map.singleton (VoterId 0) (signDSIGN leiosSignContext msg (head sks)) + cert <- case aggregateLeiosCert committee contributions of + Right c -> pure c + Left e -> do annotateShow e; fail "aggregateLeiosCert failed" + verifyLeiosCert committee (3 / 4) msg cert + === Left InsufficientWeight {got = 1 / 4, required = 3 / 4} + +prop_aggregateLeiosCert_rejects_out_of_range :: Property +prop_aggregateLeiosCert_rejects_out_of_range = withTests 1 $ property $ do + let (sks, committee) = fixedCommittee 4 + msg = "x" :: BS.ByteString + contributions = Map.singleton (VoterId 7) (signDSIGN leiosSignContext msg (head sks)) + aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds (VoterId 7)) From 2f75a46d13cac2d022492109af34e1d7f486d703 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 11:24:36 +0200 Subject: [PATCH 05/28] Add more properties and range over commitee size --- .../test/Test/Cardano/Crypto/Leios.hs | 160 +++++++++++++----- 1 file changed, 120 insertions(+), 40 deletions(-) diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 19ee310b8..ebc285203 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -16,6 +16,7 @@ import Cardano.Crypto.Leios ( Committee (..), LeiosCert (..), LeiosDSIGN, + LeiosSignature, LeiosSigningKey, VerificationError (..), VoterId (..), @@ -26,20 +27,24 @@ import Cardano.Crypto.Leios ( verifyLeiosCert, ) import Cardano.Crypto.Seed (mkSeedFromBytes) +import qualified Data.Bits as Bits +import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) import qualified Data.Vector as V import Hedgehog ( Gen, Group (..), + MonadTest, Property, annotateShow, checkParallel, + failure, forAll, property, tripping, - withTests, (===), ) import qualified Hedgehog.Gen as Gen @@ -54,9 +59,13 @@ tests = [ ("prop_roundtrip_LeiosCert", prop_roundtrip_LeiosCert) , ("prop_golden_LeiosCert", prop_golden_LeiosCert) , ("prop_verifyLeiosCert_accepts_aggregated", prop_verifyLeiosCert_accepts_aggregated) + , ("prop_verifyLeiosCert_accepts_subset", prop_verifyLeiosCert_accepts_subset) , ("prop_verifyLeiosCert_rejects_wrong_message", prop_verifyLeiosCert_rejects_wrong_message) , ("prop_verifyLeiosCert_rejects_below_threshold", prop_verifyLeiosCert_rejects_below_threshold) + , ("prop_verifyLeiosCert_rejects_oversized_signers", prop_verifyLeiosCert_rejects_oversized_signers) + , ("prop_verifyLeiosCert_rejects_tampered_bitfield", prop_verifyLeiosCert_rejects_tampered_bitfield) , ("prop_aggregateLeiosCert_rejects_out_of_range", prop_aggregateLeiosCert_rejects_out_of_range) + , ("prop_aggregateLeiosCert_rejects_empty", prop_aggregateLeiosCert_rejects_empty) ] -- * CBOR roundtrip / golden @@ -123,58 +132,129 @@ fixedCommittee n = | i <- [1 .. n] ] +-- | Default committee size range exercised by the verify/aggregate properties. +-- 1 ≤ n ≤ 16 covers single-voter (n=1), single-byte bitfield (n ≤ 8) and the +-- two-byte boundary (n=9..16). +genN :: Gen Int +genN = Gen.int (Range.linear 1 16) + +-- | Sign @msg@ with each of the given keys and pack them into a 'Map' keyed +-- by 'VoterId', matching the input shape of 'aggregateLeiosCert'. +signContribs :: ByteString -> [(Int, LeiosSigningKey)] -> Map VoterId LeiosSignature +signContribs msg pairs = + Map.fromList + [(VoterId (fromIntegral i), signDSIGN leiosSignContext msg sk) | (i, sk) <- pairs] + +-- | Aggregate or fail the test with the error. +aggregateOrFail :: + MonadTest m => Committee -> Map VoterId LeiosSignature -> m LeiosCert +aggregateOrFail committee contributions = case aggregateLeiosCert committee contributions of + Right c -> pure c + Left e -> do annotateShow e; failure + -- | All committee members sign the same message; the resulting cert verifies -- against that committee, threshold and message, and reports full weight. prop_verifyLeiosCert_accepts_aggregated :: Property -prop_verifyLeiosCert_accepts_aggregated = withTests 20 $ property $ do - n <- forAll (Gen.int (Range.linear 1 16)) +prop_verifyLeiosCert_accepts_aggregated = property $ do + n <- forAll genN msg <- forAll (Gen.bytes (Range.linear 0 64)) let (sks, committee) = fixedCommittee n - contributions = - Map.fromList - [ (VoterId (fromIntegral i), signDSIGN leiosSignContext msg sk) - | (i, sk) <- zip [0 :: Int ..] sks - ] - cert <- case aggregateLeiosCert committee contributions of - Right c -> pure c - Left e -> do annotateShow e; fail "aggregateLeiosCert failed" + contributions = signContribs msg (zip [0 :: Int ..] sks) + cert <- aggregateOrFail committee contributions verifyLeiosCert committee 1 msg cert === Right 1 +-- | An arbitrary subset of @k@ committee members signs the same message. +-- The cert must verify against any threshold @≤ k/n@ and report weight +-- @k/n@. Catches bugs where the verifier doesn't actually sum the correct +-- subset of weights. +prop_verifyLeiosCert_accepts_subset :: Property +prop_verifyLeiosCert_accepts_subset = property $ do + n <- forAll genN + k <- forAll (Gen.int (Range.linear 1 n)) + msg <- forAll (Gen.bytes (Range.linear 0 64)) + let (sks, committee) = fixedCommittee n + contributions = signContribs msg (take k (zip [0 :: Int ..] sks)) + expectedWeight = fromIntegral k / fromIntegral n + cert <- aggregateOrFail committee contributions + verifyLeiosCert committee expectedWeight msg cert === Right expectedWeight + -- | A cert built over message @m1@ must not verify against message @m2@. prop_verifyLeiosCert_rejects_wrong_message :: Property -prop_verifyLeiosCert_rejects_wrong_message = withTests 20 $ property $ do - let n = 4 - (sks, committee) = fixedCommittee n - m1 = "leios-message-one" :: BS.ByteString - m2 = "leios-message-two" :: BS.ByteString - contributions = - Map.fromList - [ (VoterId (fromIntegral i), signDSIGN leiosSignContext m1 sk) - | (i, sk) <- zip [0 :: Int ..] sks - ] - cert <- case aggregateLeiosCert committee contributions of - Right c -> pure c - Left e -> do annotateShow e; fail "aggregateLeiosCert failed" +prop_verifyLeiosCert_rejects_wrong_message = property $ do + n <- forAll genN + let (sks, committee) = fixedCommittee n + m1 = "leios-message-one" :: ByteString + m2 = "leios-message-two" :: ByteString + contributions = signContribs m1 (zip [0 :: Int ..] sks) + cert <- aggregateOrFail committee contributions verifyLeiosCert committee 1 m2 cert === Left InvalidSignature -- | A cert whose signers' summed weight is below the threshold must be -- rejected with 'InsufficientWeight', without ever performing the BLS --- pairing. +-- pairing. Uses n ≥ 2 so a single signer's weight @1/n@ is strictly less +-- than the full-weight threshold. prop_verifyLeiosCert_rejects_below_threshold :: Property -prop_verifyLeiosCert_rejects_below_threshold = withTests 1 $ property $ do - let n = 4 -- four equal-weight voters; one signer ⇒ weight = 1/4 - (sks, committee) = fixedCommittee n - msg = "leios-quorum-test" :: BS.ByteString - contributions = Map.singleton (VoterId 0) (signDSIGN leiosSignContext msg (head sks)) - cert <- case aggregateLeiosCert committee contributions of - Right c -> pure c - Left e -> do annotateShow e; fail "aggregateLeiosCert failed" - verifyLeiosCert committee (3 / 4) msg cert - === Left InsufficientWeight {got = 1 / 4, required = 3 / 4} +prop_verifyLeiosCert_rejects_below_threshold = property $ do + n <- forAll (Gen.int (Range.linear 2 16)) + let (sks, committee) = fixedCommittee n + msg = "leios-quorum-test" :: ByteString + contributions = signContribs msg [(0, head sks)] + cert <- aggregateOrFail committee contributions + verifyLeiosCert committee 1 msg cert + === Left InsufficientWeight {got = 1 / fromIntegral n, required = 1} + +-- | A 'signers' bitfield strictly longer than @⌈n/8⌉@ bytes must be +-- rejected as 'MalformedSigners' before any signature work is done. +prop_verifyLeiosCert_rejects_oversized_signers :: Property +prop_verifyLeiosCert_rejects_oversized_signers = property $ do + n <- forAll genN + let (sks, committee) = fixedCommittee n + msg = "leios-malformed-test" :: ByteString + contributions = signContribs msg (zip [0 :: Int ..] sks) + cert <- aggregateOrFail committee contributions + let oversized = cert {signers = BS.snoc (signers cert) 0x00} + verifyLeiosCert committee 1 msg oversized === Left MalformedSigners +-- | Flipping on a non-signer's bit in the bitfield must be rejected with +-- 'InvalidSignature': the aggregate verification key recomputed by the +-- verifier no longer matches the aggregate signature the producer built. +-- +-- Uses n ≥ 2 so there's at least one non-signer to tamper with. The signer +-- is voter 0; the tampered bit is voter 1's, which lives in bit 6 of byte 0 +-- of the MSB-first bitfield. +prop_verifyLeiosCert_rejects_tampered_bitfield :: Property +prop_verifyLeiosCert_rejects_tampered_bitfield = property $ do + n <- forAll (Gen.int (Range.linear 2 16)) + let (sks, committee) = fixedCommittee n + msg = "leios-tamper-test" :: ByteString + contributions = signContribs msg [(0, head sks)] + cert <- aggregateOrFail committee contributions + let raw = signers cert + tamperedByte0 = BS.head raw `Bits.setBit` 6 + tamperedSigners = BS.cons tamperedByte0 (BS.tail raw) + tampered = cert {signers = tamperedSigners} + -- Threshold is below the tampered weight 2/n so we exercise the BLS + -- pairing failure, not the short-circuit. + verifyLeiosCert committee (1 / fromIntegral n) msg tampered === Left InvalidSignature + +-- | A 'VoterId' past the committee bound is rejected at aggregation time. prop_aggregateLeiosCert_rejects_out_of_range :: Property -prop_aggregateLeiosCert_rejects_out_of_range = withTests 1 $ property $ do - let (sks, committee) = fixedCommittee 4 - msg = "x" :: BS.ByteString - contributions = Map.singleton (VoterId 7) (signDSIGN leiosSignContext msg (head sks)) - aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds (VoterId 7)) +prop_aggregateLeiosCert_rejects_out_of_range = property $ do + n <- forAll genN + badIdx <- forAll (Gen.int (Range.linear n (n + 100))) + let (sks, committee) = fixedCommittee n + msg = "x" :: ByteString + bad = VoterId (fromIntegral badIdx) + contributions = Map.singleton bad (signDSIGN leiosSignContext msg (head sks)) + aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds bad) + +-- | Aggregating an empty contribution set must fail: the underlying BLS +-- 'aggregateSigsDSIGN' rejects the empty input, which surfaces as +-- 'BLSAggregationFailed'. We don't pin the exact message string. +prop_aggregateLeiosCert_rejects_empty :: Property +prop_aggregateLeiosCert_rejects_empty = property $ do + n <- forAll genN + let (_, committee) = fixedCommittee n + case aggregateLeiosCert committee Map.empty of + Left BLSAggregationFailed {} -> pure () + other -> do annotateShow other; failure From 10c5b306846a4eda0960310159354372c84ecd59 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 12:13:16 +0200 Subject: [PATCH 06/28] Refactor BitField in LeiosCert --- .../src/Cardano/Crypto/Leios.hs | 108 +++++++++++++----- .../test/Test/Cardano/Crypto/Leios.hs | 18 ++- 2 files changed, 93 insertions(+), 33 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index be8c27935..46b6c06ab 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} @@ -40,6 +44,13 @@ module Cardano.Crypto.Leios ( -- ** Verification verifyLeiosCert, VerificationError (..), + + -- * Internal + -- + -- $internal + BitField (..), + bitFieldFromBytes, + bitFieldToBytes, ) where import Cardano.Binary (enforceSize) @@ -58,19 +69,22 @@ import Codec.CBOR.Decoding (Decoder, decodeBytes) import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) import Control.DeepSeq (NFData) import Control.Monad (when) +import Data.Array.Byte (ByteArray (ByteArray)) import Data.Bits (setBit, testBit) -import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.ByteString.Short (ShortByteString (SBS)) +import qualified Data.ByteString.Short as SBS import Data.Foldable (foldlM) import Data.List (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Set (Set) import qualified Data.Set as Set import Data.Vector (Vector) import qualified Data.Vector as V import Data.Word (Word16, Word8) import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) +import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) -- * Cryptographic primitives @@ -146,7 +160,7 @@ committeeSize = V.length . committeeVoters -- consumers verify them via 'verifyLeiosCert'; the bitfield layout is an -- implementation detail of the wire format. data LeiosCert = LeiosCert - { signers :: !ByteString + { signers :: !BitField , aggregatedSignature :: !LeiosSignature } deriving stock (Show, Eq, Generic) @@ -156,7 +170,7 @@ data LeiosCert = LeiosCert encodeLeiosCert :: LeiosCert -> Encoding encodeLeiosCert cert = encodeListLen 2 - <> encodeBytes cert.signers + <> encodeBytes (bitFieldToBytes cert.signers) <> encodeSigDSIGN cert.aggregatedSignature -- | Plain CBOR decoder for 'LeiosCert', matching the CDDL in 'LeiosCert'. @@ -164,7 +178,7 @@ decodeLeiosCert :: Decoder s LeiosCert decodeLeiosCert = do enforceSize "LeiosCert" 2 LeiosCert - <$> decodeBytes + <$> (bitFieldFromBytes <$> decodeBytes) <*> decodeSigDSIGN -- ** Construction @@ -211,7 +225,7 @@ aggregateLeiosCert committee contributions = do Right s -> Right s pure LeiosCert - { signers = encodeSignersBitfield n [fromIntegral (voterIndex v) | (v, _) <- entries] + { signers = mkBitField n (Map.keysSet contributions) , aggregatedSignature = aggSig } @@ -263,9 +277,10 @@ verifyLeiosCert :: verifyLeiosCert committee required msg cert = do let voters = committeeVoters committee n = V.length voters - idxs <- + signers <- maybe (Left MalformedSigners) Right $ - decodeSignersBitfield n cert.signers + bitFieldMembers n cert.signers + let idxs = [fromIntegral (voterIndex v) | v <- Set.toAscList signers] (got, vks) <- foldlM (accumSigner voters) (0, []) idxs when (got < required) $ Left InsufficientWeight {got, required} @@ -283,36 +298,73 @@ verifyLeiosCert committee required msg cert = do Nothing -> Left MalformedSigners Just (w', vk) -> Right (w + w', vk : ks) --- * Internal bitfield codec +-- * Internal + +-- $internal +-- +-- These definitions back the wire-format @signers@ field of 'LeiosCert' and +-- are exported only as an escape hatch for debugging, tooling, and +-- adversarial testing. Production code should not need to touch them +-- directly: producers go through 'aggregateLeiosCert' and consumers through +-- 'verifyLeiosCert', and the CBOR codecs handle on-wire transport. +-- | The @signers@ bitfield of a 'LeiosCert': a @⌈committeeSize\/8⌉@-byte +-- MSB-first packed-bits representation of which committee voters contributed +-- to the aggregate signature. -- --- Not exported: producers go through 'aggregateLeiosCert' and consumers --- through 'verifyLeiosCert'. +-- A 'newtype' wrapper around 'ByteArray' so type signatures throughout the +-- aggregate / verify path say what they're working on, and so the on-wire +-- form cannot be accidentally confused with arbitrary @bytes@. +newtype BitField = BitField {bitFieldBytes :: ByteArray} + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + deriving (NoThunks) via OnlyCheckWhnfNamed "BitField" BitField + +-- | Project the raw byte payload of a 'BitField' as a strict 'BS.ByteString'. +-- O(1) — the underlying 'ByteArray' is reinterpreted via 'ShortByteString'. +bitFieldToBytes :: BitField -> BS.ByteString +bitFieldToBytes (BitField (ByteArray ba#)) = SBS.fromShort (SBS ba#) + +-- | Wrap a strict 'BS.ByteString' as a 'BitField'. O(1) on the wire-level +-- byte payload (no copy beyond 'ShortByteString' construction). +bitFieldFromBytes :: BS.ByteString -> BitField +bitFieldFromBytes bs = case SBS.toShort bs of + SBS ba# -> BitField (ByteArray ba#) --- | Encode the @⌈N\/8⌉@-byte MSB-first bitfield over a committee of size @N@. --- Indices outside the committee bound are silently dropped. -encodeSignersBitfield :: Int -> [Int] -> ByteString -encodeSignersBitfield n idxs = BS.pack [byteFor b | b <- [0 .. expectedBytes - 1]] +-- | Build the @⌈n\/8⌉@-byte MSB-first 'BitField' for a committee of size @n@. +-- Members at or past the committee bound are silently dropped (the producer +-- should never pass any; 'aggregateLeiosCert' range-checks separately and +-- raises 'VoterIdOutOfBounds'). +mkBitField :: Int -> Set VoterId -> BitField +mkBitField n members = + bitFieldFromBytes $ BS.pack [byteFor b | b <- [0 .. expectedBytes - 1]] where expectedBytes = (n + 7) `div` 8 - marked = Set.fromList [i | i <- idxs, i >= 0, i < n] + isSet b bitIx = + Set.member (VoterId (fromIntegral (b * 8 + bitIx))) members + && b * 8 + bitIx < n byteFor b = foldl' - (\acc bitIx -> if Set.member (b * 8 + bitIx) marked then setBit acc (7 - bitIx) else acc) + (\acc bitIx -> if isSet b bitIx then setBit acc (7 - bitIx) else acc) (0 :: Word8) [0 .. 7] --- | Decode an MSB-first bitfield to its set-bit indices in ascending order. --- Returns 'Nothing' if the bitfield is longer than @⌈N\/8⌉@ bytes (malformed --- certificate); a shorter bitfield is accepted as if it were right-padded --- with zero bytes. -decodeSignersBitfield :: Int -> ByteString -> Maybe [Int] -decodeSignersBitfield n bs +-- | The voter ids whose bit is set in the 'BitField', interpreting it against +-- a committee of size @n@. Returns 'Nothing' if the underlying byte payload +-- is strictly longer than @⌈n\/8⌉@ bytes (malformed certificate); a shorter +-- payload is accepted as if right-padded with zero bytes. +bitFieldMembers :: Int -> BitField -> Maybe (Set VoterId) +bitFieldMembers n bf | BS.length bs > expectedBytes = Nothing - | otherwise = Just $ do - (byteIx, byte) <- zip [0 ..] (BS.unpack bs) - bitIx <- [0 .. 7] - let globalIx = byteIx * 8 + bitIx - [globalIx | globalIx < n, testBit byte (7 - bitIx)] + | otherwise = Just $ Set.fromList members where + bs = bitFieldToBytes bf expectedBytes = (n + 7) `div` 8 + members = + [ VoterId (fromIntegral globalIx) + | (byteIx, byte) <- zip [0 ..] (BS.unpack bs) + , bitIx <- [0 .. 7] + , let globalIx = byteIx * 8 + bitIx + , globalIx < n + , testBit byte (7 - bitIx) + ] diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index ebc285203..89681343e 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -13,6 +13,7 @@ import Cardano.Crypto.DSIGN ( ) import Cardano.Crypto.Leios ( AggregationError (..), + BitField, Committee (..), LeiosCert (..), LeiosDSIGN, @@ -21,6 +22,8 @@ import Cardano.Crypto.Leios ( VerificationError (..), VoterId (..), aggregateLeiosCert, + bitFieldFromBytes, + bitFieldToBytes, decodeLeiosCert, encodeLeiosCert, leiosSignContext, @@ -83,7 +86,7 @@ genLeiosCert = do let sk = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes seedBytes) pure LeiosCert - { signers = signersBytes + { signers = bitFieldFromBytes signersBytes , aggregatedSignature = signDSIGN leiosSignContext msg sk } @@ -107,7 +110,7 @@ prop_golden_LeiosCert = exampleCert :: LeiosCert exampleCert = LeiosCert - { signers = BS.pack [0xF0] + { signers = bitFieldFromBytes (BS.pack [0xF0]) , aggregatedSignature = signDSIGN leiosSignContext exampleMessage exampleSigningKey } where @@ -152,6 +155,11 @@ aggregateOrFail committee contributions = case aggregateLeiosCert committee cont Right c -> pure c Left e -> do annotateShow e; failure +-- | Apply a byte-level transform to a 'BitField', for adversarial test cases +-- that need to mutate the wire form directly. +withSignerBytes :: (ByteString -> ByteString) -> BitField -> BitField +withSignerBytes f = bitFieldFromBytes . f . bitFieldToBytes + -- | All committee members sign the same message; the resulting cert verifies -- against that committee, threshold and message, and reports full weight. prop_verifyLeiosCert_accepts_aggregated :: Property @@ -212,7 +220,7 @@ prop_verifyLeiosCert_rejects_oversized_signers = property $ do msg = "leios-malformed-test" :: ByteString contributions = signContribs msg (zip [0 :: Int ..] sks) cert <- aggregateOrFail committee contributions - let oversized = cert {signers = BS.snoc (signers cert) 0x00} + let oversized = cert {signers = withSignerBytes (`BS.snoc` 0x00) (signers cert)} verifyLeiosCert committee 1 msg oversized === Left MalformedSigners -- | Flipping on a non-signer's bit in the bitfield must be rejected with @@ -229,9 +237,9 @@ prop_verifyLeiosCert_rejects_tampered_bitfield = property $ do msg = "leios-tamper-test" :: ByteString contributions = signContribs msg [(0, head sks)] cert <- aggregateOrFail committee contributions - let raw = signers cert + let raw = bitFieldToBytes (signers cert) tamperedByte0 = BS.head raw `Bits.setBit` 6 - tamperedSigners = BS.cons tamperedByte0 (BS.tail raw) + tamperedSigners = bitFieldFromBytes (BS.cons tamperedByte0 (BS.tail raw)) tampered = cert {signers = tamperedSigners} -- Threshold is below the tampered weight 2/n so we exercise the BLS -- pairing failure, not the short-circuit. From 52a8925bc42f2a2d71db065bf4a20dbf72cbfeaf Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 16:53:45 +0200 Subject: [PATCH 07/28] Drop explicit export list --- .../src/Cardano/Crypto/Leios.hs | 37 +------------------ 1 file changed, 1 insertion(+), 36 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 46b6c06ab..e1a7668f2 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -1,10 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} @@ -18,40 +16,7 @@ -- uses BLS12-381 MinSig as its signature scheme and defines a 'LeiosCert' that -- can be included into blocks. This module deliberately not includes a -- 'LeiosVote' because the vote itself is not an artifact that is on-chain. -module Cardano.Crypto.Leios ( - -- * Cryptographic primitives - LeiosDSIGN, - LeiosSigningKey, - LeiosVerificationKey, - LeiosSignature, - leiosSignContext, - - -- * Voting committee - Committee (..), - Weight, - committeeSize, - VoterId (..), - - -- * Certificates - LeiosCert (..), - encodeLeiosCert, - decodeLeiosCert, - - -- ** Construction - aggregateLeiosCert, - AggregationError (..), - - -- ** Verification - verifyLeiosCert, - VerificationError (..), - - -- * Internal - -- - -- $internal - BitField (..), - bitFieldFromBytes, - bitFieldToBytes, -) where +module Cardano.Crypto.Leios where import Cardano.Binary (enforceSize) import Cardano.Crypto.DSIGN ( From 7c9e07544a1d70337a3990ea311ed5609ef143c1 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 17:34:53 +0200 Subject: [PATCH 08/28] Avoid head and name shadowing in tests --- .../src/Cardano/Crypto/Leios.hs | 4 +-- .../test/Test/Cardano/Crypto/Leios.hs | 31 +++++++++++-------- 2 files changed, 20 insertions(+), 15 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index e1a7668f2..fda9ffea2 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -242,10 +242,10 @@ verifyLeiosCert :: verifyLeiosCert committee required msg cert = do let voters = committeeVoters committee n = V.length voters - signers <- + signerSet <- maybe (Left MalformedSigners) Right $ bitFieldMembers n cert.signers - let idxs = [fromIntegral (voterIndex v) | v <- Set.toAscList signers] + let idxs = [fromIntegral (voterIndex v) | v <- Set.toAscList signerSet] (got, vks) <- foldlM (accumSigner voters) (0, []) idxs when (got < required) $ Left InsufficientWeight {got, required} diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 89681343e..1c09988f1 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -33,6 +33,8 @@ import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Data.Bits as Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) @@ -122,18 +124,21 @@ exampleCert = -- | Equal-weighted committee of @n@ voters derived from a fixed seed pattern. -- Returns the signing keys alongside the committee so tests can produce --- contributions. -fixedCommittee :: Int -> ([LeiosSigningKey], Committee) +-- contributions. The 'NonEmpty' return reflects the @n ≥ 1@ precondition and +-- gives tests a total 'NE.head' for "any-one-signer" cases. +fixedCommittee :: Int -> (NonEmpty LeiosSigningKey, Committee) fixedCommittee n = ( sks - , Committee (V.fromList [(1 / fromIntegral n, deriveVerKeyDSIGN sk) | sk <- sks]) + , Committee + (V.fromList [(1 / fromIntegral n, deriveVerKeyDSIGN sk) | sk <- NE.toList sks]) ) where seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) sks = - [ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen (fromIntegral i))) - | i <- [1 .. n] - ] + NE.fromList + [ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen (fromIntegral i))) + | i <- [1 .. max 1 n] + ] -- | Default committee size range exercised by the verify/aggregate properties. -- 1 ≤ n ≤ 16 covers single-voter (n=1), single-byte bitfield (n ≤ 8) and the @@ -167,7 +172,7 @@ prop_verifyLeiosCert_accepts_aggregated = property $ do n <- forAll genN msg <- forAll (Gen.bytes (Range.linear 0 64)) let (sks, committee) = fixedCommittee n - contributions = signContribs msg (zip [0 :: Int ..] sks) + contributions = signContribs msg (zip [0 :: Int ..] (NE.toList sks)) cert <- aggregateOrFail committee contributions verifyLeiosCert committee 1 msg cert === Right 1 @@ -181,7 +186,7 @@ prop_verifyLeiosCert_accepts_subset = property $ do k <- forAll (Gen.int (Range.linear 1 n)) msg <- forAll (Gen.bytes (Range.linear 0 64)) let (sks, committee) = fixedCommittee n - contributions = signContribs msg (take k (zip [0 :: Int ..] sks)) + contributions = signContribs msg (take k (zip [0 :: Int ..] (NE.toList sks))) expectedWeight = fromIntegral k / fromIntegral n cert <- aggregateOrFail committee contributions verifyLeiosCert committee expectedWeight msg cert === Right expectedWeight @@ -193,7 +198,7 @@ prop_verifyLeiosCert_rejects_wrong_message = property $ do let (sks, committee) = fixedCommittee n m1 = "leios-message-one" :: ByteString m2 = "leios-message-two" :: ByteString - contributions = signContribs m1 (zip [0 :: Int ..] sks) + contributions = signContribs m1 (zip [0 :: Int ..] (NE.toList sks)) cert <- aggregateOrFail committee contributions verifyLeiosCert committee 1 m2 cert === Left InvalidSignature @@ -206,7 +211,7 @@ prop_verifyLeiosCert_rejects_below_threshold = property $ do n <- forAll (Gen.int (Range.linear 2 16)) let (sks, committee) = fixedCommittee n msg = "leios-quorum-test" :: ByteString - contributions = signContribs msg [(0, head sks)] + contributions = signContribs msg [(0, NE.head sks)] cert <- aggregateOrFail committee contributions verifyLeiosCert committee 1 msg cert === Left InsufficientWeight {got = 1 / fromIntegral n, required = 1} @@ -218,7 +223,7 @@ prop_verifyLeiosCert_rejects_oversized_signers = property $ do n <- forAll genN let (sks, committee) = fixedCommittee n msg = "leios-malformed-test" :: ByteString - contributions = signContribs msg (zip [0 :: Int ..] sks) + contributions = signContribs msg (zip [0 :: Int ..] (NE.toList sks)) cert <- aggregateOrFail committee contributions let oversized = cert {signers = withSignerBytes (`BS.snoc` 0x00) (signers cert)} verifyLeiosCert committee 1 msg oversized === Left MalformedSigners @@ -235,7 +240,7 @@ prop_verifyLeiosCert_rejects_tampered_bitfield = property $ do n <- forAll (Gen.int (Range.linear 2 16)) let (sks, committee) = fixedCommittee n msg = "leios-tamper-test" :: ByteString - contributions = signContribs msg [(0, head sks)] + contributions = signContribs msg [(0, NE.head sks)] cert <- aggregateOrFail committee contributions let raw = bitFieldToBytes (signers cert) tamperedByte0 = BS.head raw `Bits.setBit` 6 @@ -253,7 +258,7 @@ prop_aggregateLeiosCert_rejects_out_of_range = property $ do let (sks, committee) = fixedCommittee n msg = "x" :: ByteString bad = VoterId (fromIntegral badIdx) - contributions = Map.singleton bad (signDSIGN leiosSignContext msg (head sks)) + contributions = Map.singleton bad (signDSIGN leiosSignContext msg (NE.head sks)) aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds bad) -- | Aggregating an empty contribution set must fail: the underlying BLS From 2a2a82daa74993c91b7ecc9e2598d6516fbe755e Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 17:42:39 +0200 Subject: [PATCH 09/28] Pin golden test files to LF on Windows checkout The golden test compares 'cardano-crypto-leios/test/golden/LeiosCert' byte-for-byte against the hex-dump output of 'encodeWithIndex'. Without this attribute, the default Windows 'core.autocrlf=true' translates LF to CRLF on checkout and the comparison fails, even though the file is committed with LF endings. --- .gitattributes | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.gitattributes b/.gitattributes index 54176f73c..f279e0004 100644 --- a/.gitattributes +++ b/.gitattributes @@ -4,3 +4,8 @@ nix/.stack.nix/*.nix linguist-generated=true nix/sources.nix linguist-generated=true + +# Golden test files are byte-exact hex dumps compared verbatim against the +# encoder output. Without this, Windows checkouts translate LF -> CRLF and +# the comparison fails (see cardano-crypto-leios:test:tests on Windows CI). +cardano-crypto-leios/test/golden/** text eol=lf From 5555fc18ca043f5af1a814958c87fbca1ed93866 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 16 Jun 2026 18:53:40 +0200 Subject: [PATCH 10/28] Expose generators in cardano-crypto-leios:testlib --- .../cardano-crypto-leios.cabal | 14 ++++- .../test/Test/Cardano/Crypto/Leios.hs | 18 +----- .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 56 +++++++++++++++++++ 3 files changed, 70 insertions(+), 18 deletions(-) create mode 100644 cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 0b65ec1d8..3762de5e2 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -46,6 +46,18 @@ library nothunks, vector, +library testlib + import: base, project-config + visibility: public + hs-source-dirs: testlib + exposed-modules: + Test.Cardano.Crypto.Leios.Gen + + build-depends: + cardano-crypto-class, + cardano-crypto-leios, + hedgehog, + test-suite tests import: base, project-config type: exitcode-stdio-1.0 @@ -58,7 +70,7 @@ test-suite tests bytestring, cardano-binary:{cardano-binary, testlib}, cardano-crypto-class, - cardano-crypto-leios, + cardano-crypto-leios:{cardano-crypto-leios, testlib}, cardano-prelude-test, containers, hedgehog, diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 1c09988f1..e43a5fa71 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -55,6 +55,7 @@ import Hedgehog ( import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Cardano.Binary.Helpers.GoldenRoundTrip (goldenTestCBORExplicit) +import Test.Cardano.Crypto.Leios.Gen (genLeiosCert) tests :: IO Bool tests = @@ -75,23 +76,6 @@ tests = -- * CBOR roundtrip / golden --- | A 'LeiosCert' with a real (deterministically-derived) BLS aggregated --- signature and a 'signers' bitfield whose length walks the CBOR uint --- width boundaries (1 / 2 / 3-byte length headers). -genLeiosCert :: Gen LeiosCert -genLeiosCert = do - let seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) - seedBytes <- Gen.bytes (Range.singleton seedLen) - msg <- Gen.bytes (Range.linear 0 256) - signersLen <- Gen.element [0, 1, 23, 24, 255, 256] - signersBytes <- Gen.bytes (Range.singleton signersLen) - let sk = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes seedBytes) - pure - LeiosCert - { signers = bitFieldFromBytes signersBytes - , aggregatedSignature = signDSIGN leiosSignContext msg sk - } - prop_roundtrip_LeiosCert :: Property prop_roundtrip_LeiosCert = property $ do cert <- forAll genLeiosCert diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs new file mode 100644 index 000000000..ed1193cb0 --- /dev/null +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | Hedgehog generators for 'Cardano.Crypto.Leios' types, intended for +-- downstream test suites (e.g. @cardano-ledger@) that want a real +-- structurally-valid 'LeiosCert' without depending on the BLS plumbing. +-- +-- These generators produce values whose CBOR encoding round-trips, but they +-- do not attempt to satisfy 'verifyLeiosCert' against any particular +-- committee or message — the @signers@ bitfield is uncorrelated with the +-- aggregated signature. That makes them suitable for serialisation and +-- AST-shape tests, not for protocol-level acceptance tests. +module Test.Cardano.Crypto.Leios.Gen ( + genLeiosCert, + genLeiosSigningKey, +) where + +import Cardano.Crypto.DSIGN (genKeyDSIGN, seedSizeDSIGN, signDSIGN) +import Cardano.Crypto.Leios ( + LeiosCert (..), + LeiosDSIGN, + LeiosSigningKey, + bitFieldFromBytes, + leiosSignContext, + ) +import Cardano.Crypto.Seed (mkSeedFromBytes) +import Data.Proxy (Proxy (Proxy)) +import Hedgehog (Gen) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +-- | Generate a 'LeiosSigningKey' from a uniformly random seed of the +-- algorithm's expected size. +genLeiosSigningKey :: Gen LeiosSigningKey +genLeiosSigningKey = do + let seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) + seedBytes <- Gen.bytes (Range.singleton seedLen) + pure $ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes seedBytes) + +-- | Generate a 'LeiosCert' whose @signers@ bitfield length walks the CBOR +-- uint width boundaries (1 / 2 / 3-byte length headers) and whose +-- aggregated signature is a real BLS signature over a random message — but +-- whose bitfield is /not/ correlated with the signers of that signature, so +-- the cert will not pass 'verifyLeiosCert'. Use this for CBOR / AST-shape +-- tests, not for verifier-acceptance tests. +genLeiosCert :: Gen LeiosCert +genLeiosCert = do + sk <- genLeiosSigningKey + msg <- Gen.bytes (Range.linear 0 256) + signersLen <- Gen.element [0, 1, 23, 24, 255, 256] + signersBytes <- Gen.bytes (Range.singleton signersLen) + pure + LeiosCert + { signers = bitFieldFromBytes signersBytes + , aggregatedSignature = signDSIGN leiosSignContext msg sk + } From de0abab275113a21905594fe65adc287086d929b Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Wed, 17 Jun 2026 09:20:42 +0200 Subject: [PATCH 11/28] Add genLeiosSignature, leiosSignatureSize and leiosSignatureToBytes These were needed/useful in the cardano-ledger-dijkstra integration --- .../src/Cardano/Crypto/Leios.hs | 13 +++++++++++++ .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 19 +++++++++++++++---- 2 files changed, 28 insertions(+), 4 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index fda9ffea2..0af056d29 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -- Named fields on the 'InsufficientWeight' variant of 'VerificationError' -- are wanted at the call site; the project-wide @-Wpartial-fields@ would -- otherwise reject record syntax on a single sum-type alternative. @@ -21,6 +22,7 @@ module Cardano.Crypto.Leios where import Cardano.Binary (enforceSize) import Cardano.Crypto.DSIGN ( DSIGNAggregatable (aggregateSigsDSIGN, uncheckedAggregateVerKeysDSIGN), + DSIGNAlgorithm (rawSerialiseSigDSIGN), SigDSIGN, SignKeyDSIGN, VerKeyDSIGN, @@ -29,6 +31,7 @@ import Cardano.Crypto.DSIGN ( verifyDSIGN, ) import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN, BLS12381SignContext, minSigPoPDST) +import Cardano.Crypto.DSIGN.Class (sigSizeDSIGN) import Cardano.Crypto.Util (SignableRepresentation) import Codec.CBOR.Decoding (Decoder, decodeBytes) import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) @@ -36,9 +39,11 @@ import Control.DeepSeq (NFData) import Control.Monad (when) import Data.Array.Byte (ByteArray (ByteArray)) import Data.Bits (setBit, testBit) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Short (ShortByteString (SBS)) import qualified Data.ByteString.Short as SBS +import Data.Data (Proxy (..)) import Data.Foldable (foldlM) import Data.List (foldl') import Data.Map.Strict (Map) @@ -66,6 +71,14 @@ type LeiosSignature = SigDSIGN LeiosDSIGN leiosSignContext :: BLS12381SignContext leiosSignContext = minSigPoPDST +-- | Size of a Leios signature in the chosen signature scheme. +leiosSignatureSize :: Word +leiosSignatureSize = sigSizeDSIGN (Proxy @LeiosDSIGN) + +-- | Get the bytes of a Leios signature. +leiosSignatureToBytes :: LeiosSignature -> ByteString +leiosSignatureToBytes = rawSerialiseSigDSIGN + -- * Voting committee -- | A weight assigned to a committee voter, normalised so the total over a diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs index ed1193cb0..104b01bb5 100644 --- a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -- | Hedgehog generators for 'Cardano.Crypto.Leios' types, intended for @@ -12,6 +11,7 @@ -- AST-shape tests, not for protocol-level acceptance tests. module Test.Cardano.Crypto.Leios.Gen ( genLeiosCert, + genLeiosSignature, genLeiosSigningKey, ) where @@ -19,6 +19,7 @@ import Cardano.Crypto.DSIGN (genKeyDSIGN, seedSizeDSIGN, signDSIGN) import Cardano.Crypto.Leios ( LeiosCert (..), LeiosDSIGN, + LeiosSignature, LeiosSigningKey, bitFieldFromBytes, leiosSignContext, @@ -37,6 +38,17 @@ genLeiosSigningKey = do seedBytes <- Gen.bytes (Range.singleton seedLen) pure $ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes seedBytes) +-- | Generate a real BLS 'LeiosSignature' by signing a random message with a +-- freshly-generated signing key. Suitable as a byte-generator source for +-- CDDL specs that need on-wire bytes which round-trip through +-- 'Cardano.Crypto.DSIGN.rawDeserialiseSigDSIGN' — uniformly random 48-byte +-- strings do /not/ decode to valid BLS G1 points and will crash there. +genLeiosSignature :: Gen LeiosSignature +genLeiosSignature = do + sk <- genLeiosSigningKey + msg <- Gen.bytes (Range.linear 0 256) + pure $ signDSIGN leiosSignContext msg sk + -- | Generate a 'LeiosCert' whose @signers@ bitfield length walks the CBOR -- uint width boundaries (1 / 2 / 3-byte length headers) and whose -- aggregated signature is a real BLS signature over a random message — but @@ -45,12 +57,11 @@ genLeiosSigningKey = do -- tests, not for verifier-acceptance tests. genLeiosCert :: Gen LeiosCert genLeiosCert = do - sk <- genLeiosSigningKey - msg <- Gen.bytes (Range.linear 0 256) signersLen <- Gen.element [0, 1, 23, 24, 255, 256] signersBytes <- Gen.bytes (Range.singleton signersLen) + sig <- genLeiosSignature pure LeiosCert { signers = bitFieldFromBytes signersBytes - , aggregatedSignature = signDSIGN leiosSignContext msg sk + , aggregatedSignature = sig } From 6b4c275b2f26d53a7fe17d94bbde41ae8577862e Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Wed, 17 Jun 2026 23:16:10 +0200 Subject: [PATCH 12/28] Add a generateWith helper --- .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs index 104b01bb5..7f00b8671 100644 --- a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -13,6 +13,7 @@ module Test.Cardano.Crypto.Leios.Gen ( genLeiosCert, genLeiosSignature, genLeiosSigningKey, + generateWith, ) where import Cardano.Crypto.DSIGN (genKeyDSIGN, seedSizeDSIGN, signDSIGN) @@ -26,8 +27,12 @@ import Cardano.Crypto.Leios ( ) import Cardano.Crypto.Seed (mkSeedFromBytes) import Data.Proxy (Proxy (Proxy)) -import Hedgehog (Gen) +import Data.Word (Word64) +import Hedgehog (Gen, Size (..)) import qualified Hedgehog.Gen as Gen +import Hedgehog.Internal.Gen (evalGen) +import qualified Hedgehog.Internal.Seed as Seed +import Hedgehog.Internal.Tree (treeValue) import qualified Hedgehog.Range as Range -- | Generate a 'LeiosSigningKey' from a uniformly random seed of the @@ -65,3 +70,12 @@ genLeiosCert = do { signers = bitFieldFromBytes signersBytes , aggregatedSignature = sig } + +-- | Deterministically evaluate a Hedgehog 'Gen' at a fixed seed without needing +-- to 'sample' in 'MonadIO'. Useful for pinning a single value (e.g. for golden +-- tests). Errors if the generator discards at this seed. +generateWith :: Gen a -> Word64 -> a +generateWith gen seed = + case evalGen (Size 30) (Seed.from seed) gen of + Just tree -> treeValue tree + Nothing -> error "generateWith: generator discarded at this seed" From f1c5c074c55113d3d97ee9db9485af64dc44c50c Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 18 Jun 2026 21:17:46 +0200 Subject: [PATCH 13/28] Use qualified import of foldl' from Data.Foldable This avoids redundant import warnings on newer GHC versions --- cardano-crypto-leios/src/Cardano/Crypto/Leios.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 0af056d29..3ecbd2a44 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -45,7 +45,7 @@ import Data.ByteString.Short (ShortByteString (SBS)) import qualified Data.ByteString.Short as SBS import Data.Data (Proxy (..)) import Data.Foldable (foldlM) -import Data.List (foldl') +import qualified Data.Foldable as F (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) @@ -322,7 +322,7 @@ mkBitField n members = Set.member (VoterId (fromIntegral (b * 8 + bitIx))) members && b * 8 + bitIx < n byteFor b = - foldl' + F.foldl' (\acc bitIx -> if isSet b bitIx then setBit acc (7 - bitIx) else acc) (0 :: Word8) [0 .. 7] From 13b7c7fa2564d836f256ca74c19957f8fe8f2e16 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 19 Jun 2026 19:39:56 +0200 Subject: [PATCH 14/28] Switch cardano-crypto-leios tests to quickcheck --- .../cardano-crypto-leios.cabal | 10 +- cardano-crypto-leios/test/Main.hs | 7 +- .../test/Test/Cardano/Crypto/Leios.hs | 237 ++++++++++-------- .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 34 ++- 4 files changed, 153 insertions(+), 135 deletions(-) diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 3762de5e2..0c66225de 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -54,9 +54,10 @@ library testlib Test.Cardano.Crypto.Leios.Gen build-depends: + QuickCheck, + bytestring, cardano-crypto-class, cardano-crypto-leios, - hedgehog, test-suite tests import: base, project-config @@ -67,13 +68,14 @@ test-suite tests Test.Cardano.Crypto.Leios build-depends: + QuickCheck, + base16-bytestring, bytestring, - cardano-binary:{cardano-binary, testlib}, + cardano-binary, cardano-crypto-class, cardano-crypto-leios:{cardano-crypto-leios, testlib}, - cardano-prelude-test, containers, - hedgehog, + hspec, vector, ghc-options: diff --git a/cardano-crypto-leios/test/Main.hs b/cardano-crypto-leios/test/Main.hs index 9708d1bb6..5ffe47587 100644 --- a/cardano-crypto-leios/test/Main.hs +++ b/cardano-crypto-leios/test/Main.hs @@ -1,11 +1,8 @@ module Main (main) where import qualified Test.Cardano.Crypto.Leios -import Test.Cardano.Prelude (runTests) +import Test.Hspec (hspec) import Prelude main :: IO () -main = - runTests - [ Test.Cardano.Crypto.Leios.tests - ] +main = hspec Test.Cardano.Crypto.Leios.spec diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index e43a5fa71..c0e424cff 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Test.Cardano.Crypto.Leios (tests, exampleCert) where +module Test.Cardano.Crypto.Leios (spec, exampleCert) where import qualified Cardano.Binary as CBOR import Cardano.Crypto.DSIGN ( @@ -31,68 +31,92 @@ import Cardano.Crypto.Leios ( ) import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Data.Bits as Bits -import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) import qualified Data.Vector as V -import Hedgehog ( - Gen, - Group (..), - MonadTest, +import Test.Cardano.Crypto.Leios.Gen (genLeiosCert) +import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ( Property, - annotateShow, - checkParallel, - failure, + chooseInt, + counterexample, forAll, - property, - tripping, (===), ) -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import Test.Cardano.Binary.Helpers.GoldenRoundTrip (goldenTestCBORExplicit) -import Test.Cardano.Crypto.Leios.Gen (genLeiosCert) +import qualified Test.QuickCheck as QC -tests :: IO Bool -tests = - checkParallel $ - Group - "Test.Cardano.Crypto.Leios" - [ ("prop_roundtrip_LeiosCert", prop_roundtrip_LeiosCert) - , ("prop_golden_LeiosCert", prop_golden_LeiosCert) - , ("prop_verifyLeiosCert_accepts_aggregated", prop_verifyLeiosCert_accepts_aggregated) - , ("prop_verifyLeiosCert_accepts_subset", prop_verifyLeiosCert_accepts_subset) - , ("prop_verifyLeiosCert_rejects_wrong_message", prop_verifyLeiosCert_rejects_wrong_message) - , ("prop_verifyLeiosCert_rejects_below_threshold", prop_verifyLeiosCert_rejects_below_threshold) - , ("prop_verifyLeiosCert_rejects_oversized_signers", prop_verifyLeiosCert_rejects_oversized_signers) - , ("prop_verifyLeiosCert_rejects_tampered_bitfield", prop_verifyLeiosCert_rejects_tampered_bitfield) - , ("prop_aggregateLeiosCert_rejects_out_of_range", prop_aggregateLeiosCert_rejects_out_of_range) - , ("prop_aggregateLeiosCert_rejects_empty", prop_aggregateLeiosCert_rejects_empty) - ] +spec :: Spec +spec = describe "Test.Cardano.Crypto.Leios" $ do + prop "roundtrip_LeiosCert" prop_roundtrip_LeiosCert + it "golden_LeiosCert" prop_golden_LeiosCert + prop "verifyLeiosCert_accepts_aggregated" prop_verifyLeiosCert_accepts_aggregated + prop "verifyLeiosCert_accepts_subset" prop_verifyLeiosCert_accepts_subset + prop "verifyLeiosCert_rejects_wrong_message" prop_verifyLeiosCert_rejects_wrong_message + prop "verifyLeiosCert_rejects_below_threshold" prop_verifyLeiosCert_rejects_below_threshold + prop "verifyLeiosCert_rejects_oversized_signers" prop_verifyLeiosCert_rejects_oversized_signers + prop "verifyLeiosCert_rejects_tampered_bitfield" prop_verifyLeiosCert_rejects_tampered_bitfield + prop "aggregateLeiosCert_rejects_out_of_range" prop_aggregateLeiosCert_rejects_out_of_range + prop "aggregateLeiosCert_rejects_empty" prop_aggregateLeiosCert_rejects_empty -- * CBOR roundtrip / golden prop_roundtrip_LeiosCert :: Property -prop_roundtrip_LeiosCert = property $ do - cert <- forAll genLeiosCert - tripping - cert - (CBOR.serialize . encodeLeiosCert) - (CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert) +prop_roundtrip_LeiosCert = forAll genLeiosCert $ \cert -> + let bs = CBOR.serialize (encodeLeiosCert cert) + in CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert bs === Right cert -- | Locks the on-wire encoding of 'LeiosCert' against accidental drift. -- Inputs are fixed (constant seed, fixed message, fixed bitfield) so the -- byte-for-byte golden is reproducible. -prop_golden_LeiosCert :: Property -prop_golden_LeiosCert = - goldenTestCBORExplicit "LeiosCert" encodeLeiosCert decodeLeiosCert exampleCert path +prop_golden_LeiosCert :: IO () +prop_golden_LeiosCert = do + let actual = BSL.toStrict (CBOR.serialize (encodeLeiosCert exampleCert)) + actualHex = formatIndexedHex actual + expectedHex <- BS.readFile path + actualHex `shouldBe` expectedHex + case decodeIndexedHex expectedHex of + Left e -> expectationFailure ("golden file is not valid hex: " <> e) + Right raw -> + CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (BSL.fromStrict raw) + `shouldBe` Right exampleCert where path = "test/golden/LeiosCert" +-- | Format a strict 'ByteString' as 16-byte-per-line hex with a 2-hex-digit +-- offset prefix, matching the on-disk shape of the golden file. +formatIndexedHex :: BS.ByteString -> BS.ByteString +formatIndexedHex bs = + BS.concat + [ BSC.pack (twoHex offset) <> ": " <> Base16.encode chunk <> "\n" + | (offset, chunk) <- zip [0, 16 ..] (chunksOf 16 bs) + ] + where + twoHex n = case showHex2 n of + [c] -> ['0', c] + cs -> cs + showHex2 n + | n < 16 = [hexDigit n] + | otherwise = showHex2 (n `div` 16) <> [hexDigit (n `mod` 16)] + hexDigit d + | d < 10 = toEnum (fromEnum '0' + d) + | otherwise = toEnum (fromEnum 'a' + d - 10) + chunksOf n s + | BS.null s = [] + | otherwise = let (h, t) = BS.splitAt n s in h : chunksOf n t + +-- | Parse the indexed-hex format back to its raw bytes; offsets are dropped. +decodeIndexedHex :: BS.ByteString -> Either String BS.ByteString +decodeIndexedHex = + Base16.decode . BS.concat . map (BS.drop 4) . BSC.lines + exampleCert :: LeiosCert exampleCert = LeiosCert @@ -100,7 +124,7 @@ exampleCert = , aggregatedSignature = signDSIGN leiosSignContext exampleMessage exampleSigningKey } where - seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) + seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) exampleSigningKey = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen 0x01)) exampleMessage = "leios-golden-message" :: BS.ByteString @@ -117,7 +141,7 @@ fixedCommittee n = (V.fromList [(1 / fromIntegral n, deriveVerKeyDSIGN sk) | sk <- NE.toList sks]) ) where - seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) + seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) sks = NE.fromList [ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen (fromIntegral i))) @@ -127,90 +151,92 @@ fixedCommittee n = -- | Default committee size range exercised by the verify/aggregate properties. -- 1 ≤ n ≤ 16 covers single-voter (n=1), single-byte bitfield (n ≤ 8) and the -- two-byte boundary (n=9..16). -genN :: Gen Int -genN = Gen.int (Range.linear 1 16) +genN :: QC.Gen Int +genN = chooseInt (1, 16) + +genMsg :: QC.Gen BS.ByteString +genMsg = do + len <- chooseInt (0, 64) + BS.pack <$> QC.vectorOf len QC.arbitrary -- | Sign @msg@ with each of the given keys and pack them into a 'Map' keyed -- by 'VoterId', matching the input shape of 'aggregateLeiosCert'. -signContribs :: ByteString -> [(Int, LeiosSigningKey)] -> Map VoterId LeiosSignature +signContribs :: BS.ByteString -> [(Int, LeiosSigningKey)] -> Map VoterId LeiosSignature signContribs msg pairs = Map.fromList [(VoterId (fromIntegral i), signDSIGN leiosSignContext msg sk) | (i, sk) <- pairs] --- | Aggregate or fail the test with the error. +-- | Aggregate or fail the property with the error. aggregateOrFail :: - MonadTest m => Committee -> Map VoterId LeiosSignature -> m LeiosCert -aggregateOrFail committee contributions = case aggregateLeiosCert committee contributions of - Right c -> pure c - Left e -> do annotateShow e; failure + Committee -> + Map VoterId LeiosSignature -> + (LeiosCert -> Property) -> + Property +aggregateOrFail committee contributions k = case aggregateLeiosCert committee contributions of + Right c -> k c + Left e -> counterexample (show e) (QC.property False) -- | Apply a byte-level transform to a 'BitField', for adversarial test cases -- that need to mutate the wire form directly. -withSignerBytes :: (ByteString -> ByteString) -> BitField -> BitField +withSignerBytes :: (BS.ByteString -> BS.ByteString) -> BitField -> BitField withSignerBytes f = bitFieldFromBytes . f . bitFieldToBytes -- | All committee members sign the same message; the resulting cert verifies -- against that committee, threshold and message, and reports full weight. prop_verifyLeiosCert_accepts_aggregated :: Property -prop_verifyLeiosCert_accepts_aggregated = property $ do - n <- forAll genN - msg <- forAll (Gen.bytes (Range.linear 0 64)) +prop_verifyLeiosCert_accepts_aggregated = forAll genN $ \n -> forAll genMsg $ \msg -> let (sks, committee) = fixedCommittee n contributions = signContribs msg (zip [0 :: Int ..] (NE.toList sks)) - cert <- aggregateOrFail committee contributions - verifyLeiosCert committee 1 msg cert === Right 1 + in aggregateOrFail committee contributions $ \cert -> + verifyLeiosCert committee 1 msg cert === Right 1 -- | An arbitrary subset of @k@ committee members signs the same message. -- The cert must verify against any threshold @≤ k/n@ and report weight -- @k/n@. Catches bugs where the verifier doesn't actually sum the correct -- subset of weights. prop_verifyLeiosCert_accepts_subset :: Property -prop_verifyLeiosCert_accepts_subset = property $ do - n <- forAll genN - k <- forAll (Gen.int (Range.linear 1 n)) - msg <- forAll (Gen.bytes (Range.linear 0 64)) - let (sks, committee) = fixedCommittee n - contributions = signContribs msg (take k (zip [0 :: Int ..] (NE.toList sks))) - expectedWeight = fromIntegral k / fromIntegral n - cert <- aggregateOrFail committee contributions - verifyLeiosCert committee expectedWeight msg cert === Right expectedWeight +prop_verifyLeiosCert_accepts_subset = forAll genN $ \n -> + forAll (chooseInt (1, n)) $ \k -> + forAll genMsg $ \msg -> + let (sks, committee) = fixedCommittee n + contributions = signContribs msg (take k (zip [0 :: Int ..] (NE.toList sks))) + expectedWeight = fromIntegral k / fromIntegral n + in aggregateOrFail committee contributions $ \cert -> + verifyLeiosCert committee expectedWeight msg cert === Right expectedWeight -- | A cert built over message @m1@ must not verify against message @m2@. prop_verifyLeiosCert_rejects_wrong_message :: Property -prop_verifyLeiosCert_rejects_wrong_message = property $ do - n <- forAll genN +prop_verifyLeiosCert_rejects_wrong_message = forAll genN $ \n -> let (sks, committee) = fixedCommittee n - m1 = "leios-message-one" :: ByteString - m2 = "leios-message-two" :: ByteString + m1 = "leios-message-one" :: BS.ByteString + m2 = "leios-message-two" :: BS.ByteString contributions = signContribs m1 (zip [0 :: Int ..] (NE.toList sks)) - cert <- aggregateOrFail committee contributions - verifyLeiosCert committee 1 m2 cert === Left InvalidSignature + in aggregateOrFail committee contributions $ \cert -> + verifyLeiosCert committee 1 m2 cert === Left InvalidSignature -- | A cert whose signers' summed weight is below the threshold must be -- rejected with 'InsufficientWeight', without ever performing the BLS -- pairing. Uses n ≥ 2 so a single signer's weight @1/n@ is strictly less -- than the full-weight threshold. prop_verifyLeiosCert_rejects_below_threshold :: Property -prop_verifyLeiosCert_rejects_below_threshold = property $ do - n <- forAll (Gen.int (Range.linear 2 16)) +prop_verifyLeiosCert_rejects_below_threshold = forAll (chooseInt (2, 16)) $ \n -> let (sks, committee) = fixedCommittee n - msg = "leios-quorum-test" :: ByteString + msg = "leios-quorum-test" :: BS.ByteString contributions = signContribs msg [(0, NE.head sks)] - cert <- aggregateOrFail committee contributions - verifyLeiosCert committee 1 msg cert - === Left InsufficientWeight {got = 1 / fromIntegral n, required = 1} + in aggregateOrFail committee contributions $ \cert -> + verifyLeiosCert committee 1 msg cert + === Left InsufficientWeight {got = 1 / fromIntegral n, required = 1} -- | A 'signers' bitfield strictly longer than @⌈n/8⌉@ bytes must be -- rejected as 'MalformedSigners' before any signature work is done. prop_verifyLeiosCert_rejects_oversized_signers :: Property -prop_verifyLeiosCert_rejects_oversized_signers = property $ do - n <- forAll genN +prop_verifyLeiosCert_rejects_oversized_signers = forAll genN $ \n -> let (sks, committee) = fixedCommittee n - msg = "leios-malformed-test" :: ByteString + msg = "leios-malformed-test" :: BS.ByteString contributions = signContribs msg (zip [0 :: Int ..] (NE.toList sks)) - cert <- aggregateOrFail committee contributions - let oversized = cert {signers = withSignerBytes (`BS.snoc` 0x00) (signers cert)} - verifyLeiosCert committee 1 msg oversized === Left MalformedSigners + in aggregateOrFail committee contributions $ \cert -> + let oversized = cert {signers = withSignerBytes (`BS.snoc` 0x00) (signers cert)} + in verifyLeiosCert committee 1 msg oversized === Left MalformedSigners -- | Flipping on a non-signer's bit in the bitfield must be rejected with -- 'InvalidSignature': the aggregate verification key recomputed by the @@ -220,38 +246,35 @@ prop_verifyLeiosCert_rejects_oversized_signers = property $ do -- is voter 0; the tampered bit is voter 1's, which lives in bit 6 of byte 0 -- of the MSB-first bitfield. prop_verifyLeiosCert_rejects_tampered_bitfield :: Property -prop_verifyLeiosCert_rejects_tampered_bitfield = property $ do - n <- forAll (Gen.int (Range.linear 2 16)) +prop_verifyLeiosCert_rejects_tampered_bitfield = forAll (chooseInt (2, 16)) $ \n -> let (sks, committee) = fixedCommittee n - msg = "leios-tamper-test" :: ByteString + msg = "leios-tamper-test" :: BS.ByteString contributions = signContribs msg [(0, NE.head sks)] - cert <- aggregateOrFail committee contributions - let raw = bitFieldToBytes (signers cert) - tamperedByte0 = BS.head raw `Bits.setBit` 6 - tamperedSigners = bitFieldFromBytes (BS.cons tamperedByte0 (BS.tail raw)) - tampered = cert {signers = tamperedSigners} - -- Threshold is below the tampered weight 2/n so we exercise the BLS - -- pairing failure, not the short-circuit. - verifyLeiosCert committee (1 / fromIntegral n) msg tampered === Left InvalidSignature + in aggregateOrFail committee contributions $ \cert -> + let raw = bitFieldToBytes (signers cert) + tamperedByte0 = BS.head raw `Bits.setBit` 6 + tamperedSigners = bitFieldFromBytes (BS.cons tamperedByte0 (BS.tail raw)) + tampered = cert {signers = tamperedSigners} + in -- Threshold is below the tampered weight 2/n so we exercise the BLS + -- pairing failure, not the short-circuit. + verifyLeiosCert committee (1 / fromIntegral n) msg tampered === Left InvalidSignature -- | A 'VoterId' past the committee bound is rejected at aggregation time. prop_aggregateLeiosCert_rejects_out_of_range :: Property -prop_aggregateLeiosCert_rejects_out_of_range = property $ do - n <- forAll genN - badIdx <- forAll (Gen.int (Range.linear n (n + 100))) - let (sks, committee) = fixedCommittee n - msg = "x" :: ByteString - bad = VoterId (fromIntegral badIdx) - contributions = Map.singleton bad (signDSIGN leiosSignContext msg (NE.head sks)) - aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds bad) +prop_aggregateLeiosCert_rejects_out_of_range = forAll genN $ \n -> + forAll (chooseInt (n, n + 100)) $ \badIdx -> + let (sks, committee) = fixedCommittee n + msg = "x" :: BS.ByteString + bad = VoterId (fromIntegral badIdx) + contributions = Map.singleton bad (signDSIGN leiosSignContext msg (NE.head sks)) + in aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds bad) -- | Aggregating an empty contribution set must fail: the underlying BLS -- 'aggregateSigsDSIGN' rejects the empty input, which surfaces as -- 'BLSAggregationFailed'. We don't pin the exact message string. prop_aggregateLeiosCert_rejects_empty :: Property -prop_aggregateLeiosCert_rejects_empty = property $ do - n <- forAll genN +prop_aggregateLeiosCert_rejects_empty = forAll genN $ \n -> let (_, committee) = fixedCommittee n - case aggregateLeiosCert committee Map.empty of - Left BLSAggregationFailed {} -> pure () - other -> do annotateShow other; failure + in case aggregateLeiosCert committee Map.empty of + Left BLSAggregationFailed {} -> QC.property True + other -> counterexample (show other) (QC.property False) diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs index 7f00b8671..129861eee 100644 --- a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeApplications #-} --- | Hedgehog generators for 'Cardano.Crypto.Leios' types, intended for +-- | QuickCheck generators for 'Cardano.Crypto.Leios' types, intended for -- downstream test suites (e.g. @cardano-ledger@) that want a real -- structurally-valid 'LeiosCert' without depending on the BLS plumbing. -- @@ -26,21 +26,19 @@ import Cardano.Crypto.Leios ( leiosSignContext, ) import Cardano.Crypto.Seed (mkSeedFromBytes) +import qualified Data.ByteString as BS import Data.Proxy (Proxy (Proxy)) import Data.Word (Word64) -import Hedgehog (Gen, Size (..)) -import qualified Hedgehog.Gen as Gen -import Hedgehog.Internal.Gen (evalGen) -import qualified Hedgehog.Internal.Seed as Seed -import Hedgehog.Internal.Tree (treeValue) -import qualified Hedgehog.Range as Range +import Test.QuickCheck (Gen, arbitrary, choose, elements, vectorOf) +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random (mkQCGen) -- | Generate a 'LeiosSigningKey' from a uniformly random seed of the -- algorithm's expected size. genLeiosSigningKey :: Gen LeiosSigningKey genLeiosSigningKey = do - let seedLen = fromIntegral (seedSizeDSIGN (Proxy @LeiosDSIGN)) - seedBytes <- Gen.bytes (Range.singleton seedLen) + let seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) + seedBytes <- BS.pack <$> vectorOf seedLen arbitrary pure $ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes seedBytes) -- | Generate a real BLS 'LeiosSignature' by signing a random message with a @@ -51,7 +49,8 @@ genLeiosSigningKey = do genLeiosSignature :: Gen LeiosSignature genLeiosSignature = do sk <- genLeiosSigningKey - msg <- Gen.bytes (Range.linear 0 256) + msgLen <- choose (0, 256) + msg <- BS.pack <$> vectorOf msgLen arbitrary pure $ signDSIGN leiosSignContext msg sk -- | Generate a 'LeiosCert' whose @signers@ bitfield length walks the CBOR @@ -62,8 +61,8 @@ genLeiosSignature = do -- tests, not for verifier-acceptance tests. genLeiosCert :: Gen LeiosCert genLeiosCert = do - signersLen <- Gen.element [0, 1, 23, 24, 255, 256] - signersBytes <- Gen.bytes (Range.singleton signersLen) + signersLen <- elements [0, 1, 23, 24, 255, 256] + signersBytes <- BS.pack <$> vectorOf signersLen arbitrary sig <- genLeiosSignature pure LeiosCert @@ -71,11 +70,8 @@ genLeiosCert = do , aggregatedSignature = sig } --- | Deterministically evaluate a Hedgehog 'Gen' at a fixed seed without needing --- to 'sample' in 'MonadIO'. Useful for pinning a single value (e.g. for golden --- tests). Errors if the generator discards at this seed. +-- | Deterministically evaluate a QuickCheck 'Gen' at a fixed seed. Useful for +-- pinning a single value (e.g. for golden tests) without going through +-- 'Test.QuickCheck.generate' in 'IO'. generateWith :: Gen a -> Word64 -> a -generateWith gen seed = - case evalGen (Size 30) (Seed.from seed) gen of - Just tree -> treeValue tree - Nothing -> error "generateWith: generator discarded at this seed" +generateWith gen seed = unGen gen (mkQCGen (fromIntegral seed)) 30 From 87643a3a77af91fdb3cf35f5e343245545411c83 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 19 Jun 2026 22:30:20 +0200 Subject: [PATCH 15/28] Address review comments on Leios crypto - Replace indexed-hex golden file with raw binary; drop the .gitattributes LF pin and the base16-bytestring dep. - Extract InsufficientWeight's named fields into a WeightMismatch record so no constructor has partial accessors; drop -Wno-partial-fields and DuplicateRecordFields. - Introduce strict LeiosVoter to replace the lazy (Weight, VerKey) tuple in Committee; switch BLSAggregationFailed to Text; tighten verifier accumulator strictness. - Don't export field selectors that can easily overlap. --- .gitattributes | 5 -- .../cardano-crypto-leios.cabal | 2 +- .../src/Cardano/Crypto/Leios.hs | 63 +++++++++++++------ .../test/Test/Cardano/Crypto/Leios.hs | 54 ++++------------ cardano-crypto-leios/test/golden/LeiosCert | 5 +- 5 files changed, 58 insertions(+), 71 deletions(-) diff --git a/.gitattributes b/.gitattributes index f279e0004..54176f73c 100644 --- a/.gitattributes +++ b/.gitattributes @@ -4,8 +4,3 @@ nix/.stack.nix/*.nix linguist-generated=true nix/sources.nix linguist-generated=true - -# Golden test files are byte-exact hex dumps compared verbatim against the -# encoder output. Without this, Windows checkouts translate LF -> CRLF and -# the comparison fails (see cardano-crypto-leios:test:tests on Windows CI). -cardano-crypto-leios/test/golden/** text eol=lf diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 0c66225de..0f4fef3ec 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -44,6 +44,7 @@ library containers, deepseq, nothunks, + text, vector, library testlib @@ -69,7 +70,6 @@ test-suite tests build-depends: QuickCheck, - base16-bytestring, bytestring, cardano-binary, cardano-crypto-class, diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 3ecbd2a44..f44833f9d 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -1,17 +1,13 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} --- Named fields on the 'InsufficientWeight' variant of 'VerificationError' --- are wanted at the call site; the project-wide @-Wpartial-fields@ would --- otherwise reject record syntax on a single sum-type alternative. -{-# OPTIONS_GHC -Wno-partial-fields #-} -- | Cryptographic data types and operations used in Leios per CIP-164. Leios -- uses BLS12-381 MinSig as its signature scheme and defines a 'LeiosCert' that @@ -50,8 +46,10 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Vector (Vector) -import qualified Data.Vector as V +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector.Strict (Vector) +import qualified Data.Vector.Strict as V import Data.Word (Word16, Word8) import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) @@ -94,8 +92,17 @@ newtype VoterId = VoterId {voterIndex :: Word16} deriving stock (Eq, Ord, Show, Generic) deriving anyclass (NFData, NoThunks) +-- | A single seat in a 'Committee': a voter's normalised weight paired with +-- its BLS verification key. +data LeiosVoter = LeiosVoter + { voterWeight :: !Weight + , voterVKey :: !LeiosVerificationKey + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, NoThunks) + -- | The voting committee for a Leios epoch: an ordered vector of --- @(weight, verification-key)@ pairs. +-- 'LeiosVoter' seats. -- -- Position determines the voter's 'VoterId' and its bit in the certificate's -- bitfield, so callers must keep the order stable between construction and @@ -109,13 +116,19 @@ newtype VoterId = VoterId {voterIndex :: Word16} -- skip per-key PoP checks (they use 'uncheckedAggregateVerKeysDSIGN' / -- 'aggregateSigsDSIGN' under the hood). Passing in unchecked keys defeats -- the security of the aggregate signature. -newtype Committee = Committee {committeeVoters :: Vector (Weight, LeiosVerificationKey)} +newtype Committee = Committee {committeeVoters :: Vector LeiosVoter} deriving stock (Show, Eq, Generic) - deriving anyclass (NFData, NoThunks) + deriving anyclass (NFData) + -- 'nothunks' ships no instance for 'Data.Vector.Strict.Vector' and we don't + -- want to add an orphan. A WHNF-only check on the wrapper is sufficient here: + -- the strict 'Vector' forces every cell to WHNF, and a WHNF 'LeiosVoter' + -- forces both of its strict fields, so "Committee in WHNF" structurally + -- implies no thunks anywhere inside. + deriving (NoThunks) via OnlyCheckWhnfNamed "Committee" Committee -- | Number of seats in the committee. committeeSize :: Committee -> Int -committeeSize = V.length . committeeVoters +committeeSize Committee {committeeVoters} = V.length committeeVoters -- * Leios certificates @@ -165,7 +178,7 @@ data AggregationError = -- | A voter index in the contributions is past the committee bound. VoterIdOutOfBounds !VoterId | -- | BLS signature aggregation failed (e.g. malformed input signature). - BLSAggregationFailed !String + BLSAggregationFailed !Text deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -194,12 +207,12 @@ aggregateLeiosCert :: aggregateLeiosCert committee contributions = do let n = committeeSize committee entries = Map.toAscList contributions - case [v | (v, _) <- entries, fromIntegral (voterIndex v) >= n] of + case [v | (v, _) <- entries, fromIntegral v.voterIndex >= n] of v : _ -> Left (VoterIdOutOfBounds v) [] -> pure () aggSig <- case aggregateSigsDSIGN (map snd entries) of - Left e -> Left (BLSAggregationFailed e) + Left e -> Left (BLSAggregationFailed (T.pack e)) Right s -> Right s pure LeiosCert @@ -216,7 +229,17 @@ data VerificationError -- signature, or a bitfield/aggregate mismatch). InvalidSignature | -- | Sum of signers' weights is below the required threshold. - InsufficientWeight {got :: !Weight, required :: !Weight} + InsufficientWeight !WeightMismatch + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The mismatch between the actual contributing weight and the minimum +-- threshold a 'LeiosCert' is required to meet. Carried by +-- 'InsufficientWeight'. +data WeightMismatch = WeightMismatch + { got :: !Weight + , required :: !Weight + } deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -253,15 +276,15 @@ verifyLeiosCert :: -- | Total weight of the contributing signers on success. Either VerificationError Weight verifyLeiosCert committee required msg cert = do - let voters = committeeVoters committee + let voters = committee.committeeVoters n = V.length voters signerSet <- maybe (Left MalformedSigners) Right $ bitFieldMembers n cert.signers - let idxs = [fromIntegral (voterIndex v) | v <- Set.toAscList signerSet] + let idxs = [fromIntegral v.voterIndex | v <- Set.toAscList signerSet] (got, vks) <- foldlM (accumSigner voters) (0, []) idxs when (got < required) $ - Left InsufficientWeight {got, required} + Left (InsufficientWeight WeightMismatch {got, required}) aggVk <- case uncheckedAggregateVerKeysDSIGN (reverse vks) of Left _ -> Left InvalidSignature @@ -272,9 +295,9 @@ verifyLeiosCert committee required msg cert = do where -- The bitfield decoder already enforced @i < n@; if the committee is -- shorter than the decoder's idea of @n@ we treat it as a malformed cert. - accumSigner voters (w, ks) i = case voters V.!? i of + accumSigner voters (!w, !ks) i = case voters V.!? i of Nothing -> Left MalformedSigners - Just (w', vk) -> Right (w + w', vk : ks) + Just (LeiosVoter w' vk) -> Right (w + w', vk : ks) -- * Internal diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index c0e424cff..445136977 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -19,8 +19,10 @@ import Cardano.Crypto.Leios ( LeiosDSIGN, LeiosSignature, LeiosSigningKey, + LeiosVoter (..), VerificationError (..), VoterId (..), + WeightMismatch (..), aggregateLeiosCert, bitFieldFromBytes, bitFieldToBytes, @@ -32,17 +34,16 @@ import Cardano.Crypto.Leios ( import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Data.Bits as Bits import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) -import qualified Data.Vector as V +import qualified Data.Vector.Strict as V +import Data.Word (Word16, Word8) import Test.Cardano.Crypto.Leios.Gen (genLeiosCert) -import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe) +import Test.Hspec (Spec, describe, it, shouldBe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ( Property, @@ -79,44 +80,13 @@ prop_roundtrip_LeiosCert = forAll genLeiosCert $ \cert -> prop_golden_LeiosCert :: IO () prop_golden_LeiosCert = do let actual = BSL.toStrict (CBOR.serialize (encodeLeiosCert exampleCert)) - actualHex = formatIndexedHex actual - expectedHex <- BS.readFile path - actualHex `shouldBe` expectedHex - case decodeIndexedHex expectedHex of - Left e -> expectationFailure ("golden file is not valid hex: " <> e) - Right raw -> - CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (BSL.fromStrict raw) - `shouldBe` Right exampleCert + expected <- BS.readFile path + actual `shouldBe` expected + CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (BSL.fromStrict expected) + `shouldBe` Right exampleCert where path = "test/golden/LeiosCert" --- | Format a strict 'ByteString' as 16-byte-per-line hex with a 2-hex-digit --- offset prefix, matching the on-disk shape of the golden file. -formatIndexedHex :: BS.ByteString -> BS.ByteString -formatIndexedHex bs = - BS.concat - [ BSC.pack (twoHex offset) <> ": " <> Base16.encode chunk <> "\n" - | (offset, chunk) <- zip [0, 16 ..] (chunksOf 16 bs) - ] - where - twoHex n = case showHex2 n of - [c] -> ['0', c] - cs -> cs - showHex2 n - | n < 16 = [hexDigit n] - | otherwise = showHex2 (n `div` 16) <> [hexDigit (n `mod` 16)] - hexDigit d - | d < 10 = toEnum (fromEnum '0' + d) - | otherwise = toEnum (fromEnum 'a' + d - 10) - chunksOf n s - | BS.null s = [] - | otherwise = let (h, t) = BS.splitAt n s in h : chunksOf n t - --- | Parse the indexed-hex format back to its raw bytes; offsets are dropped. -decodeIndexedHex :: BS.ByteString -> Either String BS.ByteString -decodeIndexedHex = - Base16.decode . BS.concat . map (BS.drop 4) . BSC.lines - exampleCert :: LeiosCert exampleCert = LeiosCert @@ -138,7 +108,9 @@ fixedCommittee :: Int -> (NonEmpty LeiosSigningKey, Committee) fixedCommittee n = ( sks , Committee - (V.fromList [(1 / fromIntegral n, deriveVerKeyDSIGN sk) | sk <- NE.toList sks]) + ( V.fromList + [LeiosVoter (1 / fromIntegral n) (deriveVerKeyDSIGN sk) | sk <- NE.toList sks] + ) ) where seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) @@ -225,7 +197,7 @@ prop_verifyLeiosCert_rejects_below_threshold = forAll (chooseInt (2, 16)) $ \n - contributions = signContribs msg [(0, NE.head sks)] in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee 1 msg cert - === Left InsufficientWeight {got = 1 / fromIntegral n, required = 1} + === Left (InsufficientWeight WeightMismatch {got = 1 / fromIntegral n, required = 1}) -- | A 'signers' bitfield strictly longer than @⌈n/8⌉@ bytes must be -- rejected as 'MalformedSigners' before any signature work is done. diff --git a/cardano-crypto-leios/test/golden/LeiosCert b/cardano-crypto-leios/test/golden/LeiosCert index d3b135580..51e91091d 100644 --- a/cardano-crypto-leios/test/golden/LeiosCert +++ b/cardano-crypto-leios/test/golden/LeiosCert @@ -1,4 +1 @@ -00: 8241f05830b40d05252e372ab554776a -10: 5b713d618d4d8563349f24e2d37a3ce2 -20: 3de395a205f610db5d503bacf6e5d1f8 -30: 4b15506216 +AX0 %.7*Twj[q=aMc4$z<=㕢]P;KPb \ No newline at end of file From 4234a79cadff6d49e0e5e77cbec7abd85c77cda2 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 19 Jun 2026 23:11:56 +0200 Subject: [PATCH 16/28] Build BitField via mutable ByteArray ops Replaces the list-of-bytes construction in 'mkBitField' (and the 'BS.unpack' list comprehension in 'bitFieldMembers') with direct mutable 'ByteArray' operations from 'Data.Primitive.ByteArray', so the ByteArray-backed representation isn't undone by intermediate list allocations. Wire encode/decode stay zero-copy via the existing SBS aliasing; on-wire bytes are unchanged (golden test confirms). --- .../cardano-crypto-leios.cabal | 2 + .../src/Cardano/Crypto/Leios.hs | 90 +++++++++++-------- 2 files changed, 54 insertions(+), 38 deletions(-) diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 0f4fef3ec..4d1701531 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -38,12 +38,14 @@ library build-depends: bytestring, + cardano-base, cardano-binary, cardano-crypto-class, cborg, containers, deepseq, nothunks, + primitive, text, vector, diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index f44833f9d..dc314bd65 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,6 +15,7 @@ -- 'LeiosVote' because the vote itself is not an artifact that is on-chain. module Cardano.Crypto.Leios where +import Cardano.Base.Bytes (byteArrayFromByteString, byteArrayToByteString) import Cardano.Binary (enforceSize) import Cardano.Crypto.DSIGN ( DSIGNAggregatable (aggregateSigsDSIGN, uncheckedAggregateVerKeysDSIGN), @@ -32,18 +33,24 @@ import Cardano.Crypto.Util (SignableRepresentation) import Codec.CBOR.Decoding (Decoder, decodeBytes) import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) import Control.DeepSeq (NFData) -import Control.Monad (when) -import Data.Array.Byte (ByteArray (ByteArray)) -import Data.Bits (setBit, testBit) +import Control.Monad (forM_, unless, when) +import Data.Array.Byte (ByteArray) +import Data.Bits (setBit, shiftR, testBit, (.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.Short (ShortByteString (SBS)) -import qualified Data.ByteString.Short as SBS import Data.Data (Proxy (..)) import Data.Foldable (foldlM) -import qualified Data.Foldable as F (foldl') import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Primitive.ByteArray ( + fillByteArray, + indexByteArray, + newByteArray, + readByteArray, + runByteArray, + sizeofByteArray, + writeByteArray, + ) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -322,50 +329,57 @@ newtype BitField = BitField {bitFieldBytes :: ByteArray} deriving (NoThunks) via OnlyCheckWhnfNamed "BitField" BitField -- | Project the raw byte payload of a 'BitField' as a strict 'BS.ByteString'. --- O(1) — the underlying 'ByteArray' is reinterpreted via 'ShortByteString'. bitFieldToBytes :: BitField -> BS.ByteString -bitFieldToBytes (BitField (ByteArray ba#)) = SBS.fromShort (SBS ba#) +bitFieldToBytes BitField {bitFieldBytes} = + byteArrayToByteString bitFieldBytes --- | Wrap a strict 'BS.ByteString' as a 'BitField'. O(1) on the wire-level --- byte payload (no copy beyond 'ShortByteString' construction). +-- | Use a strict 'BS.ByteString' as a 'BitField'. bitFieldFromBytes :: BS.ByteString -> BitField -bitFieldFromBytes bs = case SBS.toShort bs of - SBS ba# -> BitField (ByteArray ba#) +bitFieldFromBytes = + BitField . byteArrayFromByteString --- | Build the @⌈n\/8⌉@-byte MSB-first 'BitField' for a committee of size @n@. +-- | Build the @⌈n\/8⌉@-byte 'BitField' for a committee of size @n@. -- Members at or past the committee bound are silently dropped (the producer -- should never pass any; 'aggregateLeiosCert' range-checks separately and -- raises 'VoterIdOutOfBounds'). +-- +-- Builds directly into a mutable 'ByteArray' — one allocation, no list +-- intermediate — and writes one bit per member of the input set. mkBitField :: Int -> Set VoterId -> BitField -mkBitField n members = - bitFieldFromBytes $ BS.pack [byteFor b | b <- [0 .. expectedBytes - 1]] +mkBitField n members = BitField $ runByteArray $ do + mba <- newByteArray len + fillByteArray mba 0 len 0 + forM_ (Set.toAscList members) $ \(VoterId i) -> do + let idx = fromIntegral @Word16 @Int i + when (idx < n) $ do + let byteIx = idx `shiftR` 3 + bitPos = 7 - (idx .&. 7) + b <- readByteArray mba byteIx + writeByteArray mba byteIx ((b :: Word8) `setBit` bitPos) + pure mba where - expectedBytes = (n + 7) `div` 8 - isSet b bitIx = - Set.member (VoterId (fromIntegral (b * 8 + bitIx))) members - && b * 8 + bitIx < n - byteFor b = - F.foldl' - (\acc bitIx -> if isSet b bitIx then setBit acc (7 - bitIx) else acc) - (0 :: Word8) - [0 .. 7] + len = (n + 7) `div` 8 -- | The voter ids whose bit is set in the 'BitField', interpreting it against -- a committee of size @n@. Returns 'Nothing' if the underlying byte payload -- is strictly longer than @⌈n\/8⌉@ bytes (malformed certificate); a shorter -- payload is accepted as if right-padded with zero bytes. +-- +-- Indexes the 'ByteArray' directly (no 'BS.unpack' intermediate); the +-- per-byte inner loop is over @[0..7]@ and fuses away. bitFieldMembers :: Int -> BitField -> Maybe (Set VoterId) -bitFieldMembers n bf - | BS.length bs > expectedBytes = Nothing - | otherwise = Just $ Set.fromList members +bitFieldMembers n (BitField ba) + | actualBytes > len = Nothing + | otherwise = + Just . Set.fromAscList $ + [ VoterId (fromIntegral globalIx) + | byteIx <- [0 .. actualBytes - 1] + , let byte = indexByteArray ba byteIx :: Word8 + , bitIx <- [0 .. 7] + , let globalIx = byteIx * 8 + bitIx + , globalIx < n + , testBit byte (7 - bitIx) + ] where - bs = bitFieldToBytes bf - expectedBytes = (n + 7) `div` 8 - members = - [ VoterId (fromIntegral globalIx) - | (byteIx, byte) <- zip [0 ..] (BS.unpack bs) - , bitIx <- [0 .. 7] - , let globalIx = byteIx * 8 + bitIx - , globalIx < n - , testBit byte (7 - bitIx) - ] + len = (n + 7) `div` 8 + actualBytes = sizeofByteArray ba From 74bcc360cf671211402293ee92f8702c680176bd Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 19 Jun 2026 23:26:03 +0200 Subject: [PATCH 17/28] Accept indefinite-length encoding in decodeLeiosCert 'enforceSize' from cardano-binary only accepts definite-length lists, which would reject any producer that emits the 2-element outer array of a Leios certificate as an indefinite-length CBOR array. Switch to 'decodeListLenOrIndef' + 'matchSize' for the definite branch and a trailing 'decodeBreakOr' for the indefinite branch. Adds a QuickCheck property that round-trips through a hand-rolled indefinite-length encoding to lock the new behaviour in. --- .../cardano-crypto-leios.cabal | 1 + .../src/Cardano/Crypto/Leios.hs | 23 ++++++++++++++----- .../test/Test/Cardano/Crypto/Leios.hs | 15 ++++++++++++ 3 files changed, 33 insertions(+), 6 deletions(-) diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 4d1701531..3881edfe7 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -76,6 +76,7 @@ test-suite tests cardano-binary, cardano-crypto-class, cardano-crypto-leios:{cardano-crypto-leios, testlib}, + cborg, containers, hspec, vector, diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index dc314bd65..699f68012 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -16,7 +16,7 @@ module Cardano.Crypto.Leios where import Cardano.Base.Bytes (byteArrayFromByteString, byteArrayToByteString) -import Cardano.Binary (enforceSize) +import Cardano.Binary (matchSize) import Cardano.Crypto.DSIGN ( DSIGNAggregatable (aggregateSigsDSIGN, uncheckedAggregateVerKeysDSIGN), DSIGNAlgorithm (rawSerialiseSigDSIGN), @@ -30,7 +30,7 @@ import Cardano.Crypto.DSIGN ( import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN, BLS12381SignContext, minSigPoPDST) import Cardano.Crypto.DSIGN.Class (sigSizeDSIGN) import Cardano.Crypto.Util (SignableRepresentation) -import Codec.CBOR.Decoding (Decoder, decodeBytes) +import Codec.CBOR.Decoding (Decoder, decodeBreakOr, decodeBytes, decodeListLenOrIndef) import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) import Control.DeepSeq (NFData) import Control.Monad (forM_, unless, when) @@ -172,12 +172,23 @@ encodeLeiosCert cert = <> encodeSigDSIGN cert.aggregatedSignature -- | Plain CBOR decoder for 'LeiosCert', matching the CDDL in 'LeiosCert'. +-- Accepts both definite-length and indefinite-length encodings of the +-- outer 2-element array. decodeLeiosCert :: Decoder s LeiosCert decodeLeiosCert = do - enforceSize "LeiosCert" 2 - LeiosCert - <$> (bitFieldFromBytes <$> decodeBytes) - <*> decodeSigDSIGN + isIndef <- + decodeListLenOrIndef >>= \case + Just n -> False <$ matchSize "LeiosCert" 2 n + Nothing -> pure True + cert <- + LeiosCert + <$> (bitFieldFromBytes <$> decodeBytes) + <*> decodeSigDSIGN + when isIndef $ do + isBreak <- decodeBreakOr + unless isBreak $ + fail "LeiosCert: expected break after 2 elements of indefinite-length list" + pure cert -- ** Construction diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 445136977..ebfce4dbf 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -7,10 +7,12 @@ module Test.Cardano.Crypto.Leios (spec, exampleCert) where import qualified Cardano.Binary as CBOR import Cardano.Crypto.DSIGN ( DSIGNAlgorithm (deriveVerKeyDSIGN), + encodeSigDSIGN, genKeyDSIGN, seedSizeDSIGN, signDSIGN, ) +import qualified Codec.CBOR.Encoding as CBOR.E import Cardano.Crypto.Leios ( AggregationError (..), BitField, @@ -57,6 +59,7 @@ import qualified Test.QuickCheck as QC spec :: Spec spec = describe "Test.Cardano.Crypto.Leios" $ do prop "roundtrip_LeiosCert" prop_roundtrip_LeiosCert + prop "decode_indefinite_LeiosCert" prop_decode_indefinite_LeiosCert it "golden_LeiosCert" prop_golden_LeiosCert prop "verifyLeiosCert_accepts_aggregated" prop_verifyLeiosCert_accepts_aggregated prop "verifyLeiosCert_accepts_subset" prop_verifyLeiosCert_accepts_subset @@ -74,6 +77,18 @@ prop_roundtrip_LeiosCert = forAll genLeiosCert $ \cert -> let bs = CBOR.serialize (encodeLeiosCert cert) in CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert bs === Right cert +-- | The decoder must accept indefinite-length encodings of the outer +-- 2-element array, not just the canonical definite-length form. +prop_decode_indefinite_LeiosCert :: Property +prop_decode_indefinite_LeiosCert = forAll genLeiosCert $ \cert -> + let indef = + CBOR.E.encodeListLenIndef + <> CBOR.E.encodeBytes (bitFieldToBytes (signers cert)) + <> encodeSigDSIGN (aggregatedSignature cert) + <> CBOR.E.encodeBreak + in CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (CBOR.serialize indef) + === Right cert + -- | Locks the on-wire encoding of 'LeiosCert' against accidental drift. -- Inputs are fixed (constant seed, fixed message, fixed bitfield) so the -- byte-for-byte golden is reproducible. From 5d45fdc274069886ebb1df51441edbe91fbf4da9 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 19 Jun 2026 23:40:41 +0200 Subject: [PATCH 18/28] Add explicit export list to Cardano.Crypto.Leios MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Section headers move into the export list; the body's '-- *' / '-- **' markers are removed to avoid double sections in Haddock. Doc strings stay at the definitions. 'mkBitField' and 'bitFieldMembers' are no longer exported — they're only callable through 'aggregateLeiosCert' / 'verifyLeiosCert', which the tests exercise transitively. Adversarial tests still have the 'bitFieldFromBytes' / 'bitFieldToBytes' wire helpers. --- .../src/Cardano/Crypto/Leios.hs | 57 ++++++++++++------- 1 file changed, 36 insertions(+), 21 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 699f68012..620fae6e0 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -13,7 +13,42 @@ -- uses BLS12-381 MinSig as its signature scheme and defines a 'LeiosCert' that -- can be included into blocks. This module deliberately not includes a -- 'LeiosVote' because the vote itself is not an artifact that is on-chain. -module Cardano.Crypto.Leios where +module Cardano.Crypto.Leios ( + -- * Cryptographic primitives + LeiosDSIGN, + LeiosSigningKey, + LeiosVerificationKey, + LeiosSignature, + leiosSignContext, + leiosSignatureSize, + leiosSignatureToBytes, + + -- * Voting committee + Weight, + VoterId (..), + LeiosVoter (..), + Committee (..), + committeeSize, + + -- * Leios certificates + LeiosCert (..), + encodeLeiosCert, + decodeLeiosCert, + + -- ** Construction + AggregationError (..), + aggregateLeiosCert, + + -- ** Verification + WeightMismatch (..), + VerificationError (..), + verifyLeiosCert, + + -- * Bitfield wire-format helpers + BitField, + bitFieldToBytes, + bitFieldFromBytes, +) where import Cardano.Base.Bytes (byteArrayFromByteString, byteArrayToByteString) import Cardano.Binary (matchSize) @@ -61,8 +96,6 @@ import Data.Word (Word16, Word8) import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) --- * Cryptographic primitives - type LeiosDSIGN = BLS12381MinSigDSIGN type LeiosSigningKey = SignKeyDSIGN LeiosDSIGN @@ -84,8 +117,6 @@ leiosSignatureSize = sigSizeDSIGN (Proxy @LeiosDSIGN) leiosSignatureToBytes :: LeiosSignature -> ByteString leiosSignatureToBytes = rawSerialiseSigDSIGN --- * Voting committee - -- | A weight assigned to a committee voter, normalised so the total over a -- committee sums to @1@. Threshold checks in 'verifyLeiosCert' are against -- this same scale. @@ -137,8 +168,6 @@ newtype Committee = Committee {committeeVoters :: Vector LeiosVoter} committeeSize :: Committee -> Int committeeSize Committee {committeeVoters} = V.length committeeVoters --- * Leios certificates - -- | A Leios certificate over an endorser block, as specified in CIP-164: -- -- @ @@ -190,8 +219,6 @@ decodeLeiosCert = do fail "LeiosCert: expected break after 2 elements of indefinite-length list" pure cert --- ** Construction - data AggregationError = -- | A voter index in the contributions is past the committee bound. VoterIdOutOfBounds !VoterId @@ -238,8 +265,6 @@ aggregateLeiosCert committee contributions = do , aggregatedSignature = aggSig } --- ** Verification - data VerificationError = -- | 'signers' bitfield is longer than @⌈committeeSize/8⌉@ bytes. MalformedSigners @@ -317,16 +342,6 @@ verifyLeiosCert committee required msg cert = do Nothing -> Left MalformedSigners Just (LeiosVoter w' vk) -> Right (w + w', vk : ks) --- * Internal - --- $internal --- --- These definitions back the wire-format @signers@ field of 'LeiosCert' and --- are exported only as an escape hatch for debugging, tooling, and --- adversarial testing. Production code should not need to touch them --- directly: producers go through 'aggregateLeiosCert' and consumers through --- 'verifyLeiosCert', and the CBOR codecs handle on-wire transport. - -- | The @signers@ bitfield of a 'LeiosCert': a @⌈committeeSize\/8⌉@-byte -- MSB-first packed-bits representation of which committee voters contributed -- to the aggregate signature. From e9bedb92f2a771f9352fd1861444097774567019 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sat, 20 Jun 2026 08:24:51 +0200 Subject: [PATCH 19/28] Inline Map.keys/elems and type-annotate fromIntegral 'aggregateLeiosCert' was binding 'entries = Map.toAscList contributions' just to feed two separate consumers: a range-check over keys and a signature-aggregation over values. Each consumer can take its Map.keys / Map.elems input directly, which lets list fusion eliminate the intermediates per pass. Adds source/destination type applications to every fromIntegral in the package (src + test + testlib) so the conversion's intent is explicit at the call site and silent type-changes during refactors are caught. --- .../src/Cardano/Crypto/Leios.hs | 9 ++++----- .../test/Test/Cardano/Crypto/Leios.hs | 17 +++++++++-------- .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 2 +- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 620fae6e0..3583cf756 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -251,12 +251,11 @@ aggregateLeiosCert :: Either AggregationError LeiosCert aggregateLeiosCert committee contributions = do let n = committeeSize committee - entries = Map.toAscList contributions - case [v | (v, _) <- entries, fromIntegral v.voterIndex >= n] of + case [v | v <- Map.keys contributions, fromIntegral @Word16 @Int v.voterIndex >= n] of v : _ -> Left (VoterIdOutOfBounds v) [] -> pure () aggSig <- - case aggregateSigsDSIGN (map snd entries) of + case aggregateSigsDSIGN (Map.elems contributions) of Left e -> Left (BLSAggregationFailed (T.pack e)) Right s -> Right s pure @@ -324,7 +323,7 @@ verifyLeiosCert committee required msg cert = do signerSet <- maybe (Left MalformedSigners) Right $ bitFieldMembers n cert.signers - let idxs = [fromIntegral v.voterIndex | v <- Set.toAscList signerSet] + let idxs = [fromIntegral @Word16 @Int v.voterIndex | v <- Set.toAscList signerSet] (got, vks) <- foldlM (accumSigner voters) (0, []) idxs when (got < required) $ Left (InsufficientWeight WeightMismatch {got, required}) @@ -398,7 +397,7 @@ bitFieldMembers n (BitField ba) | actualBytes > len = Nothing | otherwise = Just . Set.fromAscList $ - [ VoterId (fromIntegral globalIx) + [ VoterId (fromIntegral @Int @Word16 globalIx) | byteIx <- [0 .. actualBytes - 1] , let byte = indexByteArray ba byteIx :: Word8 , bitIx <- [0 .. 7] diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index ebfce4dbf..c329d649b 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -12,7 +12,6 @@ import Cardano.Crypto.DSIGN ( seedSizeDSIGN, signDSIGN, ) -import qualified Codec.CBOR.Encoding as CBOR.E import Cardano.Crypto.Leios ( AggregationError (..), BitField, @@ -24,6 +23,7 @@ import Cardano.Crypto.Leios ( LeiosVoter (..), VerificationError (..), VoterId (..), + Weight, WeightMismatch (..), aggregateLeiosCert, bitFieldFromBytes, @@ -34,6 +34,7 @@ import Cardano.Crypto.Leios ( verifyLeiosCert, ) import Cardano.Crypto.Seed (mkSeedFromBytes) +import qualified Codec.CBOR.Encoding as CBOR.E import qualified Data.Bits as Bits import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL @@ -124,14 +125,14 @@ fixedCommittee n = ( sks , Committee ( V.fromList - [LeiosVoter (1 / fromIntegral n) (deriveVerKeyDSIGN sk) | sk <- NE.toList sks] + [LeiosVoter (1 / fromIntegral @Int @Weight n) (deriveVerKeyDSIGN sk) | sk <- NE.toList sks] ) ) where seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) sks = NE.fromList - [ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen (fromIntegral i))) + [ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen (fromIntegral @Int @Word8 i))) | i <- [1 .. max 1 n] ] @@ -151,7 +152,7 @@ genMsg = do signContribs :: BS.ByteString -> [(Int, LeiosSigningKey)] -> Map VoterId LeiosSignature signContribs msg pairs = Map.fromList - [(VoterId (fromIntegral i), signDSIGN leiosSignContext msg sk) | (i, sk) <- pairs] + [(VoterId (fromIntegral @Int @Word16 i), signDSIGN leiosSignContext msg sk) | (i, sk) <- pairs] -- | Aggregate or fail the property with the error. aggregateOrFail :: @@ -187,7 +188,7 @@ prop_verifyLeiosCert_accepts_subset = forAll genN $ \n -> forAll genMsg $ \msg -> let (sks, committee) = fixedCommittee n contributions = signContribs msg (take k (zip [0 :: Int ..] (NE.toList sks))) - expectedWeight = fromIntegral k / fromIntegral n + expectedWeight = fromIntegral @Int @Weight k / fromIntegral @Int @Weight n in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee expectedWeight msg cert === Right expectedWeight @@ -212,7 +213,7 @@ prop_verifyLeiosCert_rejects_below_threshold = forAll (chooseInt (2, 16)) $ \n - contributions = signContribs msg [(0, NE.head sks)] in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee 1 msg cert - === Left (InsufficientWeight WeightMismatch {got = 1 / fromIntegral n, required = 1}) + === Left (InsufficientWeight WeightMismatch {got = 1 / fromIntegral @Int @Weight n, required = 1}) -- | A 'signers' bitfield strictly longer than @⌈n/8⌉@ bytes must be -- rejected as 'MalformedSigners' before any signature work is done. @@ -244,7 +245,7 @@ prop_verifyLeiosCert_rejects_tampered_bitfield = forAll (chooseInt (2, 16)) $ \n tampered = cert {signers = tamperedSigners} in -- Threshold is below the tampered weight 2/n so we exercise the BLS -- pairing failure, not the short-circuit. - verifyLeiosCert committee (1 / fromIntegral n) msg tampered === Left InvalidSignature + verifyLeiosCert committee (1 / fromIntegral @Int @Weight n) msg tampered === Left InvalidSignature -- | A 'VoterId' past the committee bound is rejected at aggregation time. prop_aggregateLeiosCert_rejects_out_of_range :: Property @@ -252,7 +253,7 @@ prop_aggregateLeiosCert_rejects_out_of_range = forAll genN $ \n -> forAll (chooseInt (n, n + 100)) $ \badIdx -> let (sks, committee) = fixedCommittee n msg = "x" :: BS.ByteString - bad = VoterId (fromIntegral badIdx) + bad = VoterId (fromIntegral @Int @Word16 badIdx) contributions = Map.singleton bad (signDSIGN leiosSignContext msg (NE.head sks)) in aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds bad) diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs index 129861eee..2afcbe036 100644 --- a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -74,4 +74,4 @@ genLeiosCert = do -- pinning a single value (e.g. for golden tests) without going through -- 'Test.QuickCheck.generate' in 'IO'. generateWith :: Gen a -> Word64 -> a -generateWith gen seed = unGen gen (mkQCGen (fromIntegral seed)) 30 +generateWith gen seed = unGen gen (mkQCGen (fromIntegral @Word64 @Int seed)) 30 From 8c2e49333a31f2b4c2bbd122812bd109b9819cd2 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sat, 20 Jun 2026 23:17:04 +0200 Subject: [PATCH 20/28] Move more voterId functions from consensus --- .../cardano-crypto-leios.cabal | 2 + .../src/Cardano/Crypto/Leios.hs | 51 +++++++++- .../test/Test/Cardano/Crypto/Leios.hs | 93 ++++++++++++++++--- cardano-crypto-leios/test/golden/VoterId | 1 + 4 files changed, 129 insertions(+), 18 deletions(-) create mode 100644 cardano-crypto-leios/test/golden/VoterId diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 3881edfe7..4380016b4 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -72,6 +72,7 @@ test-suite tests build-depends: QuickCheck, + base16-bytestring, bytestring, cardano-binary, cardano-crypto-class, @@ -79,6 +80,7 @@ test-suite tests cborg, containers, hspec, + hspec-golden, vector, ghc-options: diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 3583cf756..14276a620 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -26,9 +26,13 @@ module Cardano.Crypto.Leios ( -- * Voting committee Weight, VoterId (..), + encodeVoterId, + decodeVoterId, LeiosVoter (..), Committee (..), committeeSize, + resolveVoter, + getVoterId, -- * Leios certificates LeiosCert (..), @@ -46,6 +50,8 @@ module Cardano.Crypto.Leios ( -- * Bitfield wire-format helpers BitField, + encodeBitField, + decodeBitField, bitFieldToBytes, bitFieldFromBytes, ) where @@ -65,8 +71,8 @@ import Cardano.Crypto.DSIGN ( import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN, BLS12381SignContext, minSigPoPDST) import Cardano.Crypto.DSIGN.Class (sigSizeDSIGN) import Cardano.Crypto.Util (SignableRepresentation) -import Codec.CBOR.Decoding (Decoder, decodeBreakOr, decodeBytes, decodeListLenOrIndef) -import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen) +import Codec.CBOR.Decoding (Decoder, decodeBreakOr, decodeBytes, decodeListLenOrIndef, decodeWord16) +import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen, encodeWord16) import Control.DeepSeq (NFData) import Control.Monad (forM_, unless, when) import Data.Array.Byte (ByteArray) @@ -130,6 +136,14 @@ newtype VoterId = VoterId {voterIndex :: Word16} deriving stock (Eq, Ord, Show, Generic) deriving anyclass (NFData, NoThunks) +-- | Plain CBOR encoder for 'VoterId'. +encodeVoterId :: VoterId -> Encoding +encodeVoterId (VoterId idx) = encodeWord16 idx + +-- | Plain CBOR decoder for 'VoterId'. +decodeVoterId :: Decoder s VoterId +decodeVoterId = VoterId <$> decodeWord16 + -- | A single seat in a 'Committee': a voter's normalised weight paired with -- its BLS verification key. data LeiosVoter = LeiosVoter @@ -168,6 +182,23 @@ newtype Committee = Committee {committeeVoters :: Vector LeiosVoter} committeeSize :: Committee -> Int committeeSize Committee {committeeVoters} = V.length committeeVoters +-- | Resolve a 'VoterId' to its 'LeiosVoter' on the 'Committee', or 'Nothing' +-- if the index is past the committee bound. +resolveVoter :: Committee -> VoterId -> Maybe LeiosVoter +resolveVoter committee (VoterId idx) = + committee.committeeVoters V.!? fromIntegral idx + +-- | Find a voter's 'VoterId' on the 'Committee' by its +-- 'LeiosVerificationKey', or 'Nothing' if the key is not on the committee. +-- +-- If the committee carries duplicate verification keys, returns the smallest +-- index matching @vk@ (committee selection is expected to deduplicate, but +-- this module does not enforce it). +getVoterId :: LeiosVerificationKey -> Committee -> Maybe VoterId +getVoterId vk committee = + VoterId . fromIntegral + <$> V.findIndex ((== vk) . voterVKey) committee.committeeVoters + -- | A Leios certificate over an endorser block, as specified in CIP-164: -- -- @ @@ -186,6 +217,10 @@ committeeSize Committee {committeeVoters} = V.length committeeVoters -- Producers should build 'LeiosCert' values via 'aggregateLeiosCert' and -- consumers verify them via 'verifyLeiosCert'; the bitfield layout is an -- implementation detail of the wire format. +-- +-- XXX: This says it's over an EB, but this modules does not specify the +-- "message" that is signed anymore and only it's usage within a block will add +-- these semantics. data LeiosCert = LeiosCert { signers :: !BitField , aggregatedSignature :: !LeiosSignature @@ -197,7 +232,7 @@ data LeiosCert = LeiosCert encodeLeiosCert :: LeiosCert -> Encoding encodeLeiosCert cert = encodeListLen 2 - <> encodeBytes (bitFieldToBytes cert.signers) + <> encodeBitField cert.signers <> encodeSigDSIGN cert.aggregatedSignature -- | Plain CBOR decoder for 'LeiosCert', matching the CDDL in 'LeiosCert'. @@ -211,7 +246,7 @@ decodeLeiosCert = do Nothing -> pure True cert <- LeiosCert - <$> (bitFieldFromBytes <$> decodeBytes) + <$> decodeBitField <*> decodeSigDSIGN when isIndef $ do isBreak <- decodeBreakOr @@ -363,6 +398,14 @@ bitFieldFromBytes :: BS.ByteString -> BitField bitFieldFromBytes = BitField . byteArrayFromByteString +-- | Encode a 'BitField' to CBOR bytes. +encodeBitField :: BitField -> Encoding +encodeBitField = encodeBytes . bitFieldToBytes + +-- | Decode a 'BitField' from CBOR bytes. +decodeBitField :: Decoder s BitField +decodeBitField = bitFieldFromBytes <$> decodeBytes + -- | Build the @⌈n\/8⌉@-byte 'BitField' for a committee of size @n@. -- Members at or past the committee bound are silently dropped (the producer -- should never pass any; 'aggregateLeiosCert' range-checks separately and diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index c329d649b..2b602b88d 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -29,14 +30,21 @@ import Cardano.Crypto.Leios ( bitFieldFromBytes, bitFieldToBytes, decodeLeiosCert, + decodeVoterId, encodeLeiosCert, + encodeVoterId, + getVoterId, leiosSignContext, + resolveVoter, verifyLeiosCert, ) import Cardano.Crypto.Seed (mkSeedFromBytes) +import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR.E import qualified Data.Bits as Bits import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as BS16 +import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -46,7 +54,8 @@ import Data.Proxy (Proxy (Proxy)) import qualified Data.Vector.Strict as V import Data.Word (Word16, Word8) import Test.Cardano.Crypto.Leios.Gen (genLeiosCert) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Golden (Golden (..)) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ( Property, @@ -61,7 +70,13 @@ spec :: Spec spec = describe "Test.Cardano.Crypto.Leios" $ do prop "roundtrip_LeiosCert" prop_roundtrip_LeiosCert prop "decode_indefinite_LeiosCert" prop_decode_indefinite_LeiosCert - it "golden_LeiosCert" prop_golden_LeiosCert + it "golden_LeiosCert" $ + goldenEncoding "test/golden/LeiosCert" encodeLeiosCert exampleCert + prop "roundtrip_VoterId" prop_roundtrip_VoterId + it "golden_VoterId" $ + goldenEncoding "test/golden/VoterId" encodeVoterId exampleVoterId + prop "resolveVoter_getVoterId_inverse" prop_resolveVoter_getVoterId_inverse + prop "getVoterId_returns_first_index" prop_getVoterId_returns_first_index prop "verifyLeiosCert_accepts_aggregated" prop_verifyLeiosCert_accepts_aggregated prop "verifyLeiosCert_accepts_subset" prop_verifyLeiosCert_accepts_subset prop "verifyLeiosCert_rejects_wrong_message" prop_verifyLeiosCert_rejects_wrong_message @@ -90,18 +105,21 @@ prop_decode_indefinite_LeiosCert = forAll genLeiosCert $ \cert -> in CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (CBOR.serialize indef) === Right cert --- | Locks the on-wire encoding of 'LeiosCert' against accidental drift. --- Inputs are fixed (constant seed, fixed message, fixed bitfield) so the --- byte-for-byte golden is reproducible. -prop_golden_LeiosCert :: IO () -prop_golden_LeiosCert = do - let actual = BSL.toStrict (CBOR.serialize (encodeLeiosCert exampleCert)) - expected <- BS.readFile path - actual `shouldBe` expected - CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (BSL.fromStrict expected) - `shouldBe` Right exampleCert - where - path = "test/golden/LeiosCert" +-- | Pin the byte-for-byte CBOR encoding of a value to a golden file using +-- 'hspec-golden'. Failure diffs are rendered as base16 hex. Decode +-- round-trip of arbitrary values is covered by the matching @roundtrip_@ +-- property; this only locks the encoding shape. +goldenEncoding :: FilePath -> (a -> Encoding) -> a -> Golden BSL.ByteString +goldenEncoding path enc value = + Golden + { output = CBOR.serialize (enc value) + , encodePretty = BS8.unpack . BS16.encode . BSL.toStrict + , writeToFile = BSL.writeFile + , readFromFile = BSL.readFile + , goldenFile = path + , actualFile = Nothing + , failFirstTime = False + } exampleCert :: LeiosCert exampleCert = @@ -114,6 +132,53 @@ exampleCert = exampleSigningKey = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen 0x01)) exampleMessage = "leios-golden-message" :: BS.ByteString +-- * VoterId CBOR / committee lookup + +prop_roundtrip_VoterId :: Property +prop_roundtrip_VoterId = forAll (VoterId <$> QC.arbitrary) $ \vid -> + let bs = CBOR.serialize (encodeVoterId vid) + in CBOR.decodeFullDecoder "VoterId" decodeVoterId bs === Right vid + +exampleVoterId :: VoterId +exampleVoterId = VoterId 0xABCD + +-- | 'getVoterId' and 'resolveVoter' are mutual inverses on the verification +-- key projection: for any voter in the committee, looking up its 'VoterId' +-- via its key and resolving back to a 'LeiosVoter' yields the same key. +prop_resolveVoter_getVoterId_inverse :: Property +prop_resolveVoter_getVoterId_inverse = + forAll genN $ \n -> + let (_, committee) = fixedCommittee n + voters = V.toList committee.committeeVoters + in QC.conjoin + [ counterexample ("voter index " <> show i) $ + case getVoterId (voterVKey voter) committee of + Nothing -> QC.property False + Just vid -> + case resolveVoter committee vid of + Nothing -> QC.property False + Just voter' -> voterVKey voter' === voterVKey voter + | (i :: Int, voter) <- zip [0 ..] voters + ] + +-- | When the committee carries duplicate verification keys, 'getVoterId' +-- returns the smallest matching index. We don't deduplicate committees +-- internally; downstream selection is expected to. +prop_getVoterId_returns_first_index :: Property +prop_getVoterId_returns_first_index = + forAll genN $ \n -> + let (_, committee) = fixedCommittee n + voters = V.toList committee.committeeVoters + in QC.conjoin + [ counterexample ("first occurrence at " <> show i) $ + getVoterId (voterVKey voter) duped + === Just (VoterId (fromIntegral i)) + | let duped = + Committee + (committee.committeeVoters <> committee.committeeVoters) + , (i :: Int, voter) <- zip [0 ..] voters + ] + -- * aggregate / verify -- | Equal-weighted committee of @n@ voters derived from a fixed seed pattern. diff --git a/cardano-crypto-leios/test/golden/VoterId b/cardano-crypto-leios/test/golden/VoterId new file mode 100644 index 000000000..503ff1aaa --- /dev/null +++ b/cardano-crypto-leios/test/golden/VoterId @@ -0,0 +1 @@ + \ No newline at end of file From e270a3cbfc6c025eb4ff5845f68bce614015d9a2 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sat, 20 Jun 2026 23:27:08 +0200 Subject: [PATCH 21/28] Restructure tests --- .../test/Test/Cardano/Crypto/Leios.hs | 57 +++++++++++-------- 1 file changed, 34 insertions(+), 23 deletions(-) diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 2b602b88d..8e4288fac 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -39,7 +39,7 @@ import Cardano.Crypto.Leios ( verifyLeiosCert, ) import Cardano.Crypto.Seed (mkSeedFromBytes) -import Codec.CBOR.Encoding (Encoding) +import Codec.CBOR.Encoding (Encoding, encodeBreak, encodeBytes, encodeListLenIndef) import qualified Codec.CBOR.Encoding as CBOR.E import qualified Data.Bits as Bits import qualified Data.ByteString as BS @@ -54,7 +54,7 @@ import Data.Proxy (Proxy (Proxy)) import qualified Data.Vector.Strict as V import Data.Word (Word16, Word8) import Test.Cardano.Crypto.Leios.Gen (genLeiosCert) -import Test.Hspec (Spec, describe, it) +import Test.Hspec (Spec, context, describe, it) import Test.Hspec.Golden (Golden (..)) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck ( @@ -67,24 +67,35 @@ import Test.QuickCheck ( import qualified Test.QuickCheck as QC spec :: Spec -spec = describe "Test.Cardano.Crypto.Leios" $ do - prop "roundtrip_LeiosCert" prop_roundtrip_LeiosCert - prop "decode_indefinite_LeiosCert" prop_decode_indefinite_LeiosCert - it "golden_LeiosCert" $ - goldenEncoding "test/golden/LeiosCert" encodeLeiosCert exampleCert - prop "roundtrip_VoterId" prop_roundtrip_VoterId - it "golden_VoterId" $ - goldenEncoding "test/golden/VoterId" encodeVoterId exampleVoterId - prop "resolveVoter_getVoterId_inverse" prop_resolveVoter_getVoterId_inverse - prop "getVoterId_returns_first_index" prop_getVoterId_returns_first_index - prop "verifyLeiosCert_accepts_aggregated" prop_verifyLeiosCert_accepts_aggregated - prop "verifyLeiosCert_accepts_subset" prop_verifyLeiosCert_accepts_subset - prop "verifyLeiosCert_rejects_wrong_message" prop_verifyLeiosCert_rejects_wrong_message - prop "verifyLeiosCert_rejects_below_threshold" prop_verifyLeiosCert_rejects_below_threshold - prop "verifyLeiosCert_rejects_oversized_signers" prop_verifyLeiosCert_rejects_oversized_signers - prop "verifyLeiosCert_rejects_tampered_bitfield" prop_verifyLeiosCert_rejects_tampered_bitfield - prop "aggregateLeiosCert_rejects_out_of_range" prop_aggregateLeiosCert_rejects_out_of_range - prop "aggregateLeiosCert_rejects_empty" prop_aggregateLeiosCert_rejects_empty +spec = do + describe "LeiosCert" $ do + prop "round-trips through CBOR" prop_roundtrip_LeiosCert + prop "decodes indefinite-length encoding" prop_decode_indefinite_LeiosCert + it "matches golden encoding" $ + goldenEncoding "test/golden/LeiosCert" encodeLeiosCert exampleCert + + describe "aggregateLeiosCert" $ do + prop "rejects an out-of-range VoterId" prop_aggregateLeiosCert_rejects_out_of_range + prop "rejects empty contributions" prop_aggregateLeiosCert_rejects_empty + + describe "verifyLeiosCert" $ do + context "with a valid certificate" $ do + prop "accepts a full-committee aggregation" prop_verifyLeiosCert_accepts_aggregated + prop "accepts a subset of signers above threshold" prop_verifyLeiosCert_accepts_subset + context "with an invalid certificate" $ do + prop "rejects a wrong message" prop_verifyLeiosCert_rejects_wrong_message + prop "rejects when total weight is below threshold" prop_verifyLeiosCert_rejects_below_threshold + prop "rejects a bitfield wider than the committee" prop_verifyLeiosCert_rejects_oversized_signers + prop "rejects a tampered bitfield" prop_verifyLeiosCert_rejects_tampered_bitfield + + describe "VoterId" $ do + prop "round-trips through CBOR" prop_roundtrip_VoterId + it "matches golden encoding" $ + goldenEncoding "test/golden/VoterId" encodeVoterId exampleVoterId + + describe "Committee" $ do + prop "getVoterId and resolveVoter agree on verification keys" prop_resolveVoter_getVoterId_inverse + prop "getVoterId returns the first matching index" prop_getVoterId_returns_first_index -- * CBOR roundtrip / golden @@ -98,10 +109,10 @@ prop_roundtrip_LeiosCert = forAll genLeiosCert $ \cert -> prop_decode_indefinite_LeiosCert :: Property prop_decode_indefinite_LeiosCert = forAll genLeiosCert $ \cert -> let indef = - CBOR.E.encodeListLenIndef - <> CBOR.E.encodeBytes (bitFieldToBytes (signers cert)) + encodeListLenIndef + <> encodeBytes (bitFieldToBytes (signers cert)) <> encodeSigDSIGN (aggregatedSignature cert) - <> CBOR.E.encodeBreak + <> encodeBreak in CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (CBOR.serialize indef) === Right cert From 4f8cf77b52ad5811c5696029f388685a7d6507ad Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Sun, 21 Jun 2026 00:39:53 +0200 Subject: [PATCH 22/28] Refactor and move bitfield creation / access back in --- .../cardano-crypto-leios.cabal | 2 + .../src/Cardano/Crypto/Leios.hs | 178 +++++++----------- .../test/Test/Cardano/Crypto/Leios.hs | 79 ++++---- cardano-crypto-leios/test/golden/LeiosCert | 2 +- .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 61 ++++-- 5 files changed, 153 insertions(+), 169 deletions(-) diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 4380016b4..986ffbef0 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -61,6 +61,8 @@ library testlib bytestring, cardano-crypto-class, cardano-crypto-leios, + containers, + vector, test-suite tests import: base, project-config diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 14276a620..72929a84e 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -52,8 +52,6 @@ module Cardano.Crypto.Leios ( BitField, encodeBitField, decodeBitField, - bitFieldToBytes, - bitFieldFromBytes, ) where import Cardano.Base.Bytes (byteArrayFromByteString, byteArrayToByteString) @@ -76,13 +74,15 @@ import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen, encodeWord16) import Control.DeepSeq (NFData) import Control.Monad (forM_, unless, when) import Data.Array.Byte (ByteArray) +import Data.Bifunctor (first) import Data.Bits (setBit, shiftR, testBit, (.&.)) import Data.ByteString (ByteString) -import qualified Data.ByteString as BS import Data.Data (Proxy (..)) import Data.Foldable (foldlM) +import Data.Function ((&)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (isNothing) import Data.Primitive.ByteArray ( fillByteArray, indexByteArray, @@ -92,8 +92,6 @@ import Data.Primitive.ByteArray ( sizeofByteArray, writeByteArray, ) -import Data.Set (Set) -import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Vector.Strict (Vector) @@ -156,7 +154,7 @@ data LeiosVoter = LeiosVoter -- | The voting committee for a Leios epoch: an ordered vector of -- 'LeiosVoter' seats. -- --- Position determines the voter's 'VoterId' and its bit in the certificate's +-- Ixition determines the voter's 'VoterId' and its bit in the certificate's -- bitfield, so callers must keep the order stable between construction and -- verification of any cert. -- @@ -180,13 +178,15 @@ newtype Committee = Committee {committeeVoters :: Vector LeiosVoter} -- | Number of seats in the committee. committeeSize :: Committee -> Int -committeeSize Committee {committeeVoters} = V.length committeeVoters +committeeSize Committee {committeeVoters} = length committeeVoters -- | Resolve a 'VoterId' to its 'LeiosVoter' on the 'Committee', or 'Nothing' -- if the index is past the committee bound. resolveVoter :: Committee -> VoterId -> Maybe LeiosVoter -resolveVoter committee (VoterId idx) = - committee.committeeVoters V.!? fromIntegral idx +resolveVoter committee voterId = + committee.committeeVoters V.!? idx + where + idx = fromIntegral @Word16 @Int voterId.voterIndex -- | Find a voter's 'VoterId' on the 'Committee' by its -- 'LeiosVerificationKey', or 'Nothing' if the key is not on the committee. @@ -196,7 +196,7 @@ resolveVoter committee (VoterId idx) = -- this module does not enforce it). getVoterId :: LeiosVerificationKey -> Committee -> Maybe VoterId getVoterId vk committee = - VoterId . fromIntegral + VoterId . fromIntegral @Int @Word16 <$> V.findIndex ((== vk) . voterVKey) committee.committeeVoters -- | A Leios certificate over an endorser block, as specified in CIP-164: @@ -255,14 +255,14 @@ decodeLeiosCert = do pure cert data AggregationError - = -- | A voter index in the contributions is past the committee bound. + = -- | A voter index in the sigs is past the committee bound. VoterIdOutOfBounds !VoterId | -- | BLS signature aggregation failed (e.g. malformed input signature). BLSAggregationFailed !Text deriving stock (Eq, Show, Generic) deriving anyclass (NFData) --- | Build a 'LeiosCert' from the contributions of committee members. +-- | Build a 'LeiosCert' from the sigs of committee members. -- -- == Caller obligations -- @@ -284,20 +284,34 @@ aggregateLeiosCert :: Committee -> Map VoterId LeiosSignature -> Either AggregationError LeiosCert -aggregateLeiosCert committee contributions = do - let n = committeeSize committee - case [v | v <- Map.keys contributions, fromIntegral @Word16 @Int v.voterIndex >= n] of +aggregateLeiosCert committee sigs = do + case outOfBoundsVoterIds of v : _ -> Left (VoterIdOutOfBounds v) [] -> pure () - aggSig <- - case aggregateSigsDSIGN (Map.elems contributions) of - Left e -> Left (BLSAggregationFailed (T.pack e)) - Right s -> Right s - pure - LeiosCert - { signers = mkBitField n (Map.keysSet contributions) - , aggregatedSignature = aggSig - } + aggregatedSignature <- + first (BLSAggregationFailed . T.pack) $ + aggregateSigsDSIGN (Map.elems sigs) + pure LeiosCert {signers, aggregatedSignature} + where + outOfBoundsVoterIds = + [vid | vid <- Map.keys sigs, isNothing $ resolveVoter committee vid] + + -- Builds directly into a mutable 'ByteArray' via a single allocation and + -- writes one bit per member of the input set. + signers = BitField $ runByteArray $ do + let len = (n + 7) `div` 8 + mba <- newByteArray len + fillByteArray mba 0 len 0 + forM_ (Map.keys sigs) $ \(VoterId i) -> do + let idx = fromIntegral @Word16 @Int i + when (idx < n) $ do + let byteIx = idx `shiftR` 3 + bitIx = 7 - (idx .&. 7) + b <- readByteArray @Word8 mba byteIx + writeByteArray mba byteIx (b `setBit` bitIx) + pure mba + + n = committeeSize committee data VerificationError = -- | 'signers' bitfield is longer than @⌈committeeSize/8⌉@ bytes. @@ -333,14 +347,13 @@ data WeightMismatch = WeightMismatch -- == What this function does -- -- 1. Decodes the 'signers' bitfield to the list of contributing voter --- indices, rejecting an oversized bitfield with --- 'MalformedSigners'. +-- indices, rejecting too small or big bitfield with 'MalformedSigners'. +-- -- 2. Sums those voters' weights from the committee; short-circuits with --- 'InsufficientWeight' if the sum is below the threshold, --- which avoids the BLS pairing when the bitfield can't reach quorum on --- its own. +-- 'InsufficientWeight' if the sum is below the threshold. +-- -- 3. Aggregates the contributing verification keys and verifies the --- certificate's 'aggregatedSignature' against that aggregate key over +-- certificate's 'aggregatedSignature' against the aggregate key over -- @msg@. verifyLeiosCert :: SignableRepresentation msg => @@ -353,28 +366,37 @@ verifyLeiosCert :: -- | Total weight of the contributing signers on success. Either VerificationError Weight verifyLeiosCert committee required msg cert = do - let voters = committee.committeeVoters - n = V.length voters - signerSet <- - maybe (Left MalformedSigners) Right $ - bitFieldMembers n cert.signers - let idxs = [fromIntegral @Word16 @Int v.voterIndex | v <- Set.toAscList signerSet] - (got, vks) <- foldlM (accumSigner voters) (0, []) idxs + -- The bitfield must be exactly the canonical 'committee-many bits, padded + -- to a whole byte' length. Trailing bytes (zero-padded or otherwise) are + -- not accepted; the wire form is fixed for a given committee size. + when (sizeofByteArray (bitFieldBytes cert.signers) /= (n + 7) `div` 8) $ + Left MalformedSigners + (got, vks) <- foldlM accumSigner (0, []) $ bitFieldMembers cert.signers when (got < required) $ Left (InsufficientWeight WeightMismatch {got, required}) aggVk <- - case uncheckedAggregateVerKeysDSIGN (reverse vks) of - Left _ -> Left InvalidSignature - Right k -> Right k - case verifyDSIGN leiosSignContext aggVk msg cert.aggregatedSignature of - Left _ -> Left InvalidSignature - Right () -> Right got + uncheckedAggregateVerKeysDSIGN (reverse vks) -- REVIEW: reverse needed? + & first (const InvalidSignature) + verifyDSIGN leiosSignContext aggVk msg cert.aggregatedSignature + & first (const InvalidSignature) + pure got where - -- The bitfield decoder already enforced @i < n@; if the committee is - -- shorter than the decoder's idea of @n@ we treat it as a malformed cert. - accumSigner voters (!w, !ks) i = case voters V.!? i of - Nothing -> Left MalformedSigners - Just (LeiosVoter w' vk) -> Right (w + w', vk : ks) + n = committeeSize committee + + accumSigner (!w, !ks) vid = + case resolveVoter committee vid of + Nothing -> Left MalformedSigners + Just (LeiosVoter w' vk) -> Right (w + w', vk : ks) + + bitFieldMembers (BitField ba) = + [ VoterId (fromIntegral @Int @Word16 globalIx) + | byteIx <- [0 .. sizeofByteArray ba - 1] + , let byte = indexByteArray ba byteIx :: Word8 + , bitIx <- [0 .. 7] + , let globalIx = byteIx * 8 + bitIx + , globalIx < n + , testBit byte (7 - bitIx) + ] -- | The @signers@ bitfield of a 'LeiosCert': a @⌈committeeSize\/8⌉@-byte -- MSB-first packed-bits representation of which committee voters contributed @@ -388,66 +410,10 @@ newtype BitField = BitField {bitFieldBytes :: ByteArray} deriving anyclass (NFData) deriving (NoThunks) via OnlyCheckWhnfNamed "BitField" BitField --- | Project the raw byte payload of a 'BitField' as a strict 'BS.ByteString'. -bitFieldToBytes :: BitField -> BS.ByteString -bitFieldToBytes BitField {bitFieldBytes} = - byteArrayToByteString bitFieldBytes - --- | Use a strict 'BS.ByteString' as a 'BitField'. -bitFieldFromBytes :: BS.ByteString -> BitField -bitFieldFromBytes = - BitField . byteArrayFromByteString - -- | Encode a 'BitField' to CBOR bytes. encodeBitField :: BitField -> Encoding -encodeBitField = encodeBytes . bitFieldToBytes +encodeBitField = encodeBytes . byteArrayToByteString . bitFieldBytes -- | Decode a 'BitField' from CBOR bytes. decodeBitField :: Decoder s BitField -decodeBitField = bitFieldFromBytes <$> decodeBytes - --- | Build the @⌈n\/8⌉@-byte 'BitField' for a committee of size @n@. --- Members at or past the committee bound are silently dropped (the producer --- should never pass any; 'aggregateLeiosCert' range-checks separately and --- raises 'VoterIdOutOfBounds'). --- --- Builds directly into a mutable 'ByteArray' — one allocation, no list --- intermediate — and writes one bit per member of the input set. -mkBitField :: Int -> Set VoterId -> BitField -mkBitField n members = BitField $ runByteArray $ do - mba <- newByteArray len - fillByteArray mba 0 len 0 - forM_ (Set.toAscList members) $ \(VoterId i) -> do - let idx = fromIntegral @Word16 @Int i - when (idx < n) $ do - let byteIx = idx `shiftR` 3 - bitPos = 7 - (idx .&. 7) - b <- readByteArray mba byteIx - writeByteArray mba byteIx ((b :: Word8) `setBit` bitPos) - pure mba - where - len = (n + 7) `div` 8 - --- | The voter ids whose bit is set in the 'BitField', interpreting it against --- a committee of size @n@. Returns 'Nothing' if the underlying byte payload --- is strictly longer than @⌈n\/8⌉@ bytes (malformed certificate); a shorter --- payload is accepted as if right-padded with zero bytes. --- --- Indexes the 'ByteArray' directly (no 'BS.unpack' intermediate); the --- per-byte inner loop is over @[0..7]@ and fuses away. -bitFieldMembers :: Int -> BitField -> Maybe (Set VoterId) -bitFieldMembers n (BitField ba) - | actualBytes > len = Nothing - | otherwise = - Just . Set.fromAscList $ - [ VoterId (fromIntegral @Int @Word16 globalIx) - | byteIx <- [0 .. actualBytes - 1] - , let byte = indexByteArray ba byteIx :: Word8 - , bitIx <- [0 .. 7] - , let globalIx = byteIx * 8 + bitIx - , globalIx < n - , testBit byte (7 - bitIx) - ] - where - len = (n + 7) `div` 8 - actualBytes = sizeofByteArray ba +decodeBitField = BitField . byteArrayFromByteString <$> decodeBytes diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 8e4288fac..cc4a22e67 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -15,7 +15,6 @@ import Cardano.Crypto.DSIGN ( ) import Cardano.Crypto.Leios ( AggregationError (..), - BitField, Committee (..), LeiosCert (..), LeiosDSIGN, @@ -27,10 +26,9 @@ import Cardano.Crypto.Leios ( Weight, WeightMismatch (..), aggregateLeiosCert, - bitFieldFromBytes, - bitFieldToBytes, decodeLeiosCert, decodeVoterId, + encodeBitField, encodeLeiosCert, encodeVoterId, getVoterId, @@ -39,9 +37,7 @@ import Cardano.Crypto.Leios ( verifyLeiosCert, ) import Cardano.Crypto.Seed (mkSeedFromBytes) -import Codec.CBOR.Encoding (Encoding, encodeBreak, encodeBytes, encodeListLenIndef) -import qualified Codec.CBOR.Encoding as CBOR.E -import qualified Data.Bits as Bits +import Codec.CBOR.Encoding (Encoding, encodeBreak, encodeListLenIndef) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as BS8 @@ -110,7 +106,7 @@ prop_decode_indefinite_LeiosCert :: Property prop_decode_indefinite_LeiosCert = forAll genLeiosCert $ \cert -> let indef = encodeListLenIndef - <> encodeBytes (bitFieldToBytes (signers cert)) + <> encodeBitField (signers cert) <> encodeSigDSIGN (aggregatedSignature cert) <> encodeBreak in CBOR.decodeFullDecoder "LeiosCert" decodeLeiosCert (CBOR.serialize indef) @@ -133,15 +129,13 @@ goldenEncoding path enc value = } exampleCert :: LeiosCert -exampleCert = - LeiosCert - { signers = bitFieldFromBytes (BS.pack [0xF0]) - , aggregatedSignature = signDSIGN leiosSignContext exampleMessage exampleSigningKey - } +exampleCert = case aggregateLeiosCert committee contributions of + Right c -> c + Left e -> error ("exampleCert: aggregation failed: " <> show e) where - seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) - exampleSigningKey = genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen 0x01)) - exampleMessage = "leios-golden-message" :: BS.ByteString + (sks, committee) = fixedCommittee 4 + msg = "leios-golden-message" :: BS.ByteString + contributions = signContribs msg (zip [0 ..] (NE.toList sks)) -- * VoterId CBOR / committee lookup @@ -240,11 +234,6 @@ aggregateOrFail committee contributions k = case aggregateLeiosCert committee co Right c -> k c Left e -> counterexample (show e) (QC.property False) --- | Apply a byte-level transform to a 'BitField', for adversarial test cases --- that need to mutate the wire form directly. -withSignerBytes :: (BS.ByteString -> BS.ByteString) -> BitField -> BitField -withSignerBytes f = bitFieldFromBytes . f . bitFieldToBytes - -- | All committee members sign the same message; the resulting cert verifies -- against that committee, threshold and message, and reports full weight. prop_verifyLeiosCert_accepts_aggregated :: Property @@ -291,37 +280,41 @@ prop_verifyLeiosCert_rejects_below_threshold = forAll (chooseInt (2, 16)) $ \n - verifyLeiosCert committee 1 msg cert === Left (InsufficientWeight WeightMismatch {got = 1 / fromIntegral @Int @Weight n, required = 1}) --- | A 'signers' bitfield strictly longer than @⌈n/8⌉@ bytes must be --- rejected as 'MalformedSigners' before any signature work is done. +-- | A 'signers' bitfield whose byte length differs from @⌈n/8⌉@ must be +-- rejected as 'MalformedSigners' before any signature work is done. We +-- build a cert against committee A and verify against committee B whose +-- size sits in the next byte bucket (A's bitfield is one byte short of +-- what B expects). prop_verifyLeiosCert_rejects_oversized_signers :: Property prop_verifyLeiosCert_rejects_oversized_signers = forAll genN $ \n -> - let (sks, committee) = fixedCommittee n + let (sks, committeeA) = fixedCommittee n + (_, committeeB) = fixedCommittee (n + 8) msg = "leios-malformed-test" :: BS.ByteString contributions = signContribs msg (zip [0 :: Int ..] (NE.toList sks)) - in aggregateOrFail committee contributions $ \cert -> - let oversized = cert {signers = withSignerBytes (`BS.snoc` 0x00) (signers cert)} - in verifyLeiosCert committee 1 msg oversized === Left MalformedSigners - --- | Flipping on a non-signer's bit in the bitfield must be rejected with --- 'InvalidSignature': the aggregate verification key recomputed by the --- verifier no longer matches the aggregate signature the producer built. --- --- Uses n ≥ 2 so there's at least one non-signer to tamper with. The signer --- is voter 0; the tampered bit is voter 1's, which lives in bit 6 of byte 0 --- of the MSB-first bitfield. + in aggregateOrFail committeeA contributions $ \cert -> + verifyLeiosCert committeeB 1 msg cert === Left MalformedSigners + +-- | A cert whose 'signers' bitfield disagrees with its 'aggregatedSignature' +-- must be rejected with 'InvalidSignature'. We construct two real certs +-- against the same committee (voter 0 alone, then voters 0+1), then splice +-- certA's signature with certB's bitfield. The bitfield claims voter 1 also +-- signed but the aggregate doesn't include voter 1's signature, so the BLS +-- pairing fails. Uses n ≥ 2 so there are at least two voters to splice. prop_verifyLeiosCert_rejects_tampered_bitfield :: Property prop_verifyLeiosCert_rejects_tampered_bitfield = forAll (chooseInt (2, 16)) $ \n -> let (sks, committee) = fixedCommittee n msg = "leios-tamper-test" :: BS.ByteString - contributions = signContribs msg [(0, NE.head sks)] - in aggregateOrFail committee contributions $ \cert -> - let raw = bitFieldToBytes (signers cert) - tamperedByte0 = BS.head raw `Bits.setBit` 6 - tamperedSigners = bitFieldFromBytes (BS.cons tamperedByte0 (BS.tail raw)) - tampered = cert {signers = tamperedSigners} - in -- Threshold is below the tampered weight 2/n so we exercise the BLS - -- pairing failure, not the short-circuit. - verifyLeiosCert committee (1 / fromIntegral @Int @Weight n) msg tampered === Left InvalidSignature + sks0 = NE.head sks + sks1 = NE.toList sks !! 1 + contribsAlone = signContribs msg [(0, sks0)] + contribsPair = signContribs msg [(0, sks0), (1, sks1)] + in aggregateOrFail committee contribsAlone $ \certA -> + aggregateOrFail committee contribsPair $ \certB -> + let tampered = certA {signers = certB.signers} + in -- Threshold is below the tampered weight 2/n so we exercise the BLS + -- pairing failure, not the short-circuit. + verifyLeiosCert committee (1 / fromIntegral @Int @Weight n) msg tampered + === Left InvalidSignature -- | A 'VoterId' past the committee bound is rejected at aggregation time. prop_aggregateLeiosCert_rejects_out_of_range :: Property diff --git a/cardano-crypto-leios/test/golden/LeiosCert b/cardano-crypto-leios/test/golden/LeiosCert index 51e91091d..b3e1818a3 100644 --- a/cardano-crypto-leios/test/golden/LeiosCert +++ b/cardano-crypto-leios/test/golden/LeiosCert @@ -1 +1 @@ -AX0 %.7*Twj[q=aMc4$z<=㕢]P;KPb \ No newline at end of file +AX0b(Ucځ/_HےVs;I#Ŗo-뿌1 \ No newline at end of file diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs index 2afcbe036..be1a6d4e8 100644 --- a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -16,20 +16,30 @@ module Test.Cardano.Crypto.Leios.Gen ( generateWith, ) where -import Cardano.Crypto.DSIGN (genKeyDSIGN, seedSizeDSIGN, signDSIGN) +import Cardano.Crypto.DSIGN ( + DSIGNAlgorithm (deriveVerKeyDSIGN), + genKeyDSIGN, + seedSizeDSIGN, + signDSIGN, + ) import Cardano.Crypto.Leios ( - LeiosCert (..), + Committee (..), + LeiosCert, LeiosDSIGN, LeiosSignature, LeiosSigningKey, - bitFieldFromBytes, + LeiosVoter (..), + VoterId (..), + aggregateLeiosCert, leiosSignContext, ) import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) -import Data.Word (Word64) -import Test.QuickCheck (Gen, arbitrary, choose, elements, vectorOf) +import qualified Data.Vector.Strict as V +import Data.Word (Word16, Word64) +import Test.QuickCheck (Gen, arbitrary, choose, chooseInt, elements, shuffle, vectorOf) import Test.QuickCheck.Gen (unGen) import Test.QuickCheck.Random (mkQCGen) @@ -53,22 +63,35 @@ genLeiosSignature = do msg <- BS.pack <$> vectorOf msgLen arbitrary pure $ signDSIGN leiosSignContext msg sk --- | Generate a 'LeiosCert' whose @signers@ bitfield length walks the CBOR --- uint width boundaries (1 / 2 / 3-byte length headers) and whose --- aggregated signature is a real BLS signature over a random message — but --- whose bitfield is /not/ correlated with the signers of that signature, so --- the cert will not pass 'verifyLeiosCert'. Use this for CBOR / AST-shape --- tests, not for verifier-acceptance tests. +-- | Generate a real, canonical 'LeiosCert' by building a fresh committee +-- and aggregating a non-empty subset of its members' signatures over a +-- random message. The cert is structurally valid (bitfield length matches +-- the committee, aggregate signature is well-formed) but the committee is +-- not returned — suitable for CBOR / AST-shape tests, not for +-- protocol-acceptance tests in downstream packages. +-- +-- Coverage of bitfield byte-length boundaries (CBOR uint widths > 256 +-- bytes) is not exercised here; that belongs in this package's own test +-- suite, not in the shared testlib. genLeiosCert :: Gen LeiosCert genLeiosCert = do - signersLen <- elements [0, 1, 23, 24, 255, 256] - signersBytes <- BS.pack <$> vectorOf signersLen arbitrary - sig <- genLeiosSignature - pure - LeiosCert - { signers = bitFieldFromBytes signersBytes - , aggregatedSignature = sig - } + n <- elements [1, 8, 9, 16, 17, 24] + sks <- vectorOf n genLeiosSigningKey + let committee = + Committee . V.fromList $ + [LeiosVoter (1 / fromIntegral n) (deriveVerKeyDSIGN sk) | sk <- sks] + k <- chooseInt (1, n) + signerIxs <- take k <$> shuffle [0 .. n - 1] + msgLen <- choose (0, 64) + msg <- BS.pack <$> vectorOf msgLen arbitrary + let sigs = + Map.fromList + [ (VoterId (fromIntegral @Int @Word16 i), signDSIGN leiosSignContext msg (sks !! i)) + | i <- signerIxs + ] + case aggregateLeiosCert committee sigs of + Right cert -> pure cert + Left e -> error ("genLeiosCert: aggregation failed: " <> show e) -- | Deterministically evaluate a QuickCheck 'Gen' at a fixed seed. Useful for -- pinning a single value (e.g. for golden tests) without going through From 47a5eeffd46c05b0bcef874729b840a5393966d2 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 22 Jun 2026 10:49:34 +0200 Subject: [PATCH 23/28] Use 1000 voters in the example LeiosCert This should be a typical size (> 99% of current stake distribution) --- .../test/Test/Cardano/Crypto/Leios.hs | 18 +++++++++--------- cardano-crypto-leios/test/golden/LeiosCert | Bin 53 -> 178 bytes 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index cc4a22e67..1d44f1e33 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -133,7 +133,7 @@ exampleCert = case aggregateLeiosCert committee contributions of Right c -> c Left e -> error ("exampleCert: aggregation failed: " <> show e) where - (sks, committee) = fixedCommittee 4 + (sks, committee) = fixedCommittee 1000 msg = "leios-golden-message" :: BS.ByteString contributions = signContribs msg (zip [0 ..] (NE.toList sks)) @@ -157,12 +157,12 @@ prop_resolveVoter_getVoterId_inverse = voters = V.toList committee.committeeVoters in QC.conjoin [ counterexample ("voter index " <> show i) $ - case getVoterId (voterVKey voter) committee of - Nothing -> QC.property False - Just vid -> - case resolveVoter committee vid of - Nothing -> QC.property False - Just voter' -> voterVKey voter' === voterVKey voter + case getVoterId (voterVKey voter) committee of + Nothing -> QC.property False + Just vid -> + case resolveVoter committee vid of + Nothing -> QC.property False + Just voter' -> voterVKey voter' === voterVKey voter | (i :: Int, voter) <- zip [0 ..] voters ] @@ -176,8 +176,8 @@ prop_getVoterId_returns_first_index = voters = V.toList committee.committeeVoters in QC.conjoin [ counterexample ("first occurrence at " <> show i) $ - getVoterId (voterVKey voter) duped - === Just (VoterId (fromIntegral i)) + getVoterId (voterVKey voter) duped + === Just (VoterId (fromIntegral i)) | let duped = Committee (committee.committeeVoters <> committee.committeeVoters) diff --git a/cardano-crypto-leios/test/golden/LeiosCert b/cardano-crypto-leios/test/golden/LeiosCert index b3e1818a371d96863f0658b988063907d2d1e0bb..ed19b53d0d79265fd5b5aa64c2d1bf88e4aacd98 100644 GIT binary patch literal 178 zcmZpQsQo{XAi`j~+|Ocd|7Fvb9k_gV>W6PqH(K4Mu4KxSy~lX_#v(WOoA1&l{cpRR Ocr<4hL#hRni!1<@&X<<} literal 53 zcmV-50LuS@LGV~GvSKJzhKOSWr|b~gfiI%WXKfwLJ0 From 815a7fa5e2f0fd9dc5dadcd86b5c79a6e34baa43 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 22 Jun 2026 14:05:50 +0200 Subject: [PATCH 24/28] Run fourmolu --- .../test/Test/Cardano/Crypto/Leios.hs | 16 +++---- .../src/Cardano/Crypto/WalletHD/Encrypted.hs | 47 ++++++++++++++----- 2 files changed, 44 insertions(+), 19 deletions(-) diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 1d44f1e33..e37d33423 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -157,12 +157,12 @@ prop_resolveVoter_getVoterId_inverse = voters = V.toList committee.committeeVoters in QC.conjoin [ counterexample ("voter index " <> show i) $ - case getVoterId (voterVKey voter) committee of - Nothing -> QC.property False - Just vid -> - case resolveVoter committee vid of - Nothing -> QC.property False - Just voter' -> voterVKey voter' === voterVKey voter + case getVoterId (voterVKey voter) committee of + Nothing -> QC.property False + Just vid -> + case resolveVoter committee vid of + Nothing -> QC.property False + Just voter' -> voterVKey voter' === voterVKey voter | (i :: Int, voter) <- zip [0 ..] voters ] @@ -176,8 +176,8 @@ prop_getVoterId_returns_first_index = voters = V.toList committee.committeeVoters in QC.conjoin [ counterexample ("first occurrence at " <> show i) $ - getVoterId (voterVKey voter) duped - === Just (VoterId (fromIntegral i)) + getVoterId (voterVKey voter) duped + === Just (VoterId (fromIntegral i)) | let duped = Committee (committee.committeeVoters <> committee.committeeVoters) diff --git a/cardano-crypto-wallet/src/Cardano/Crypto/WalletHD/Encrypted.hs b/cardano-crypto-wallet/src/Cardano/Crypto/WalletHD/Encrypted.hs index 49ce85493..b5a2a83c1 100644 --- a/cardano-crypto-wallet/src/Cardano/Crypto/WalletHD/Encrypted.hs +++ b/cardano-crypto-wallet/src/Cardano/Crypto/WalletHD/Encrypted.hs @@ -289,7 +289,10 @@ unEncryptedKey (EncryptedKey e) = e encryptedCreate :: (ByteArrayAccess passphrase, ByteArrayAccess secret, ByteArrayAccess cc) => - secret -> passphrase -> cc -> IO (Either XPrvError EncryptedKey) + secret -> + passphrase -> + cc -> + IO (Either XPrvError EncryptedKey) encryptedCreate sec pass cc | B.length sec /= 32 = pure (Left XPrvInvalidSecretKey) | B.length cc /= ccSize = pure (Left XPrvInvalidChainCode) @@ -303,7 +306,9 @@ encryptedCreate sec pass cc encryptedCreateDirectWithTweak :: (ByteArrayAccess passphrase, ByteArrayAccess secret) => - secret -> passphrase -> IO (Either XPrvError EncryptedKey) + secret -> + passphrase -> + IO (Either XPrvError EncryptedKey) encryptedCreateDirectWithTweak sec pass | B.length sec /= 96 = pure (Left XPrvInvalidSecretKey) | otherwise = do @@ -316,7 +321,9 @@ encryptedCreateDirectWithTweak sec pass encryptedValidatePassphrase :: ByteArrayAccess passphrase => - EncryptedKey -> passphrase -> IO (Either XPrvError ()) + EncryptedKey -> + passphrase -> + IO (Either XPrvError ()) encryptedValidatePassphrase ekey pass = do emat <- decryptKeyMaterial ekey pass case emat of @@ -327,7 +334,10 @@ encryptedValidatePassphrase ekey pass = do encryptedChangePass :: (ByteArrayAccess oldPassPhrase, ByteArrayAccess newPassPhrase) => - oldPassPhrase -> newPassPhrase -> EncryptedKey -> IO (Either XPrvError EncryptedKey) + oldPassPhrase -> + newPassPhrase -> + EncryptedKey -> + IO (Either XPrvError EncryptedKey) encryptedChangePass oldPass newPass ekey = mask $ \restore -> do emat <- restore (decryptKeyMaterial ekey oldPass) @@ -338,7 +348,10 @@ encryptedChangePass oldPass newPass ekey = encryptedSign :: (ByteArrayAccess passphrase, ByteArrayAccess msg) => - EncryptedKey -> passphrase -> msg -> IO (Either XPrvError Signature) + EncryptedKey -> + passphrase -> + msg -> + IO (Either XPrvError Signature) encryptedSign ekey pass msg = mask $ \restore -> do emat <- restore (decryptKeyMaterial ekey pass) @@ -429,7 +442,9 @@ encryptedChainCode (EncryptedKey ekey) = -- done with it. encryptedKeyMaterial :: ByteArrayAccess passphrase => - EncryptedKey -> passphrase -> IO (Either XPrvError (MLockedSizedBytes 64)) + EncryptedKey -> + passphrase -> + IO (Either XPrvError (MLockedSizedBytes 64)) encryptedKeyMaterial ekey pass = do emat <- decryptKeyMaterial ekey pass case emat of @@ -580,7 +595,9 @@ decodeAadFields = do decryptKeyMaterial :: ByteArrayAccess passphrase => - EncryptedKey -> passphrase -> IO (Either XPrvError KeyMaterial) + EncryptedKey -> + passphrase -> + IO (Either XPrvError KeyMaterial) decryptKeyMaterial ekey pass = case encryptedKeyFormat ekey of LegacyV1 -> pure (Left XPrvDecodeError) @@ -588,7 +605,9 @@ decryptKeyMaterial ekey pass = v2Decrypt :: ByteArrayAccess passphrase => - EncryptedKey -> passphrase -> IO (Either XPrvError KeyMaterial) + EncryptedKey -> + passphrase -> + IO (Either XPrvError KeyMaterial) v2Decrypt (EncryptedKey bs) pass = case decodeV2Envelope bs of Left err -> pure (Left err) @@ -630,7 +649,9 @@ v2Decrypt (EncryptedKey bs) pass = wrapKeyMaterial :: ByteArrayAccess passphrase => - passphrase -> KeyMaterial -> IO (Either XPrvError EncryptedKey) + passphrase -> + KeyMaterial -> + IO (Either XPrvError EncryptedKey) wrapKeyMaterial pass material = do eVal <- validateKeyMaterial material case eVal of @@ -725,7 +746,9 @@ withEncryptedKeyOutput onFailure action = legacyMaterialFromSecret :: (ByteArrayAccess secret, ByteArrayAccess cc) => - secret -> cc -> IO (Either XPrvError KeyMaterial) + secret -> + cc -> + IO (Either XPrvError KeyMaterial) legacyMaterialFromSecret sec cc = withEncryptedKeyOutput XPrvInvalidSecretKey $ \outPtr -> withByteArray sec $ \psec -> @@ -756,7 +779,9 @@ legacyDerivePrivate dscheme parent childIndex = deriveWrappingKey :: ByteArrayAccess passphrase => - passphrase -> ByteString -> IO (Either XPrvError B.ScrubbedBytes) + passphrase -> + ByteString -> + IO (Either XPrvError B.ScrubbedBytes) deriveWrappingKey pass salt | BS.length salt /= saltSize = pure (Left XPrvInvalidSaltLength) | otherwise = do From b24b56196cbc4de358ea83181982764af26b0c5a Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 26 Jun 2026 21:08:24 +0200 Subject: [PATCH 25/28] Address reviewer requests Several small changes on error types and generators --- .../cardano-crypto-leios.cabal | 5 ++- .../src/Cardano/Crypto/Leios.hs | 26 ++++++------ .../test/Test/Cardano/Crypto/Leios.hs | 40 +++++++++---------- .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 13 +++--- 4 files changed, 44 insertions(+), 40 deletions(-) diff --git a/cardano-crypto-leios/cardano-crypto-leios.cabal b/cardano-crypto-leios/cardano-crypto-leios.cabal index 986ffbef0..2b52524c7 100644 --- a/cardano-crypto-leios/cardano-crypto-leios.cabal +++ b/cardano-crypto-leios/cardano-crypto-leios.cabal @@ -45,7 +45,7 @@ library containers, deepseq, nothunks, - primitive, + primitive >=0.7.3, text, vector, @@ -58,7 +58,7 @@ library testlib build-depends: QuickCheck, - bytestring, + cardano-base:testlib, cardano-crypto-class, cardano-crypto-leios, containers, @@ -76,6 +76,7 @@ test-suite tests QuickCheck, base16-bytestring, bytestring, + cardano-base:testlib, cardano-binary, cardano-crypto-class, cardano-crypto-leios:{cardano-crypto-leios, testlib}, diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 72929a84e..fd2f40788 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -54,8 +54,8 @@ module Cardano.Crypto.Leios ( decodeBitField, ) where -import Cardano.Base.Bytes (byteArrayFromByteString, byteArrayToByteString) -import Cardano.Binary (matchSize) +import Cardano.Base.Bytes (byteArrayFromByteString) +import Cardano.Binary (matchSize, toCBOR) import Cardano.Crypto.DSIGN ( DSIGNAggregatable (aggregateSigsDSIGN, uncheckedAggregateVerKeysDSIGN), DSIGNAlgorithm (rawSerialiseSigDSIGN), @@ -70,7 +70,7 @@ import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN, BLS12381SignContext, import Cardano.Crypto.DSIGN.Class (sigSizeDSIGN) import Cardano.Crypto.Util (SignableRepresentation) import Codec.CBOR.Decoding (Decoder, decodeBreakOr, decodeBytes, decodeListLenOrIndef, decodeWord16) -import Codec.CBOR.Encoding (Encoding, encodeBytes, encodeListLen, encodeWord16) +import Codec.CBOR.Encoding (Encoding, encodeListLen, encodeWord16) import Control.DeepSeq (NFData) import Control.Monad (forM_, unless, when) import Data.Array.Byte (ByteArray) @@ -78,8 +78,9 @@ import Data.Bifunctor (first) import Data.Bits (setBit, shiftR, testBit, (.&.)) import Data.ByteString (ByteString) import Data.Data (Proxy (..)) -import Data.Foldable (foldlM) +import Data.Foldable (foldrM) import Data.Function ((&)) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (isNothing) @@ -255,10 +256,10 @@ decodeLeiosCert = do pure cert data AggregationError - = -- | A voter index in the sigs is past the committee bound. - VoterIdOutOfBounds !VoterId + = -- | One or more voter indices in the sigs are past the committee bound. + VoterIdsOutOfBounds (NonEmpty VoterId) | -- | BLS signature aggregation failed (e.g. malformed input signature). - BLSAggregationFailed !Text + BLSAggregationFailed Text deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -285,9 +286,9 @@ aggregateLeiosCert :: Map VoterId LeiosSignature -> Either AggregationError LeiosCert aggregateLeiosCert committee sigs = do - case outOfBoundsVoterIds of - v : _ -> Left (VoterIdOutOfBounds v) - [] -> pure () + case nonEmpty outOfBoundsVoterIds of + Just vs -> Left (VoterIdsOutOfBounds vs) + Nothing -> pure () aggregatedSignature <- first (BLSAggregationFailed . T.pack) $ aggregateSigsDSIGN (Map.elems sigs) @@ -299,7 +300,6 @@ aggregateLeiosCert committee sigs = do -- Builds directly into a mutable 'ByteArray' via a single allocation and -- writes one bit per member of the input set. signers = BitField $ runByteArray $ do - let len = (n + 7) `div` 8 mba <- newByteArray len fillByteArray mba 0 len 0 forM_ (Map.keys sigs) $ \(VoterId i) -> do @@ -313,6 +313,8 @@ aggregateLeiosCert committee sigs = do n = committeeSize committee + len = (n + 7) `div` 8 + data VerificationError = -- | 'signers' bitfield is longer than @⌈committeeSize/8⌉@ bytes. MalformedSigners @@ -412,7 +414,7 @@ newtype BitField = BitField {bitFieldBytes :: ByteArray} -- | Encode a 'BitField' to CBOR bytes. encodeBitField :: BitField -> Encoding -encodeBitField = encodeBytes . byteArrayToByteString . bitFieldBytes +encodeBitField = toCBOR . bitFieldBytes -- | Decode a 'BitField' from CBOR bytes. decodeBitField :: Decoder s BitField diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index e37d33423..ad28c1e28 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -42,13 +42,14 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as BS16 import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..), fromList) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) import qualified Data.Vector.Strict as V import Data.Word (Word16, Word8) +import Test.Cardano.Base.Bytes (genByteString) import Test.Cardano.Crypto.Leios.Gen (genLeiosCert) import Test.Hspec (Spec, context, describe, it) import Test.Hspec.Golden (Golden (..)) @@ -135,7 +136,7 @@ exampleCert = case aggregateLeiosCert committee contributions of where (sks, committee) = fixedCommittee 1000 msg = "leios-golden-message" :: BS.ByteString - contributions = signContribs msg (zip [0 ..] (NE.toList sks)) + contributions = signContribs msg (zip [0 ..] (toList sks)) -- * VoterId CBOR / committee lookup @@ -189,19 +190,19 @@ prop_getVoterId_returns_first_index = -- | Equal-weighted committee of @n@ voters derived from a fixed seed pattern. -- Returns the signing keys alongside the committee so tests can produce -- contributions. The 'NonEmpty' return reflects the @n ≥ 1@ precondition and --- gives tests a total 'NE.head' for "any-one-signer" cases. +-- gives tests a total 'head' for "any-one-signer" cases. fixedCommittee :: Int -> (NonEmpty LeiosSigningKey, Committee) fixedCommittee n = ( sks , Committee ( V.fromList - [LeiosVoter (1 / fromIntegral @Int @Weight n) (deriveVerKeyDSIGN sk) | sk <- NE.toList sks] + [LeiosVoter (1 / fromIntegral @Int @Weight n) (deriveVerKeyDSIGN sk) | sk <- toList sks] ) ) where seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) sks = - NE.fromList + fromList [ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes (BS.replicate seedLen (fromIntegral @Int @Word8 i))) | i <- [1 .. max 1 n] ] @@ -213,9 +214,7 @@ genN :: QC.Gen Int genN = chooseInt (1, 16) genMsg :: QC.Gen BS.ByteString -genMsg = do - len <- chooseInt (0, 64) - BS.pack <$> QC.vectorOf len QC.arbitrary +genMsg = chooseInt (0, 64) >>= genByteString -- | Sign @msg@ with each of the given keys and pack them into a 'Map' keyed -- by 'VoterId', matching the input shape of 'aggregateLeiosCert'. @@ -239,7 +238,7 @@ aggregateOrFail committee contributions k = case aggregateLeiosCert committee co prop_verifyLeiosCert_accepts_aggregated :: Property prop_verifyLeiosCert_accepts_aggregated = forAll genN $ \n -> forAll genMsg $ \msg -> let (sks, committee) = fixedCommittee n - contributions = signContribs msg (zip [0 :: Int ..] (NE.toList sks)) + contributions = signContribs msg (zip [0 :: Int ..] (toList sks)) in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee 1 msg cert === Right 1 @@ -252,7 +251,7 @@ prop_verifyLeiosCert_accepts_subset = forAll genN $ \n -> forAll (chooseInt (1, n)) $ \k -> forAll genMsg $ \msg -> let (sks, committee) = fixedCommittee n - contributions = signContribs msg (take k (zip [0 :: Int ..] (NE.toList sks))) + contributions = signContribs msg (take k (zip [0 :: Int ..] (toList sks))) expectedWeight = fromIntegral @Int @Weight k / fromIntegral @Int @Weight n in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee expectedWeight msg cert === Right expectedWeight @@ -263,7 +262,7 @@ prop_verifyLeiosCert_rejects_wrong_message = forAll genN $ \n -> let (sks, committee) = fixedCommittee n m1 = "leios-message-one" :: BS.ByteString m2 = "leios-message-two" :: BS.ByteString - contributions = signContribs m1 (zip [0 :: Int ..] (NE.toList sks)) + contributions = signContribs m1 (zip [0 :: Int ..] (toList sks)) in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee 1 m2 cert === Left InvalidSignature @@ -273,9 +272,9 @@ prop_verifyLeiosCert_rejects_wrong_message = forAll genN $ \n -> -- than the full-weight threshold. prop_verifyLeiosCert_rejects_below_threshold :: Property prop_verifyLeiosCert_rejects_below_threshold = forAll (chooseInt (2, 16)) $ \n -> - let (sks, committee) = fixedCommittee n + let (sk0 :| _, committee) = fixedCommittee n msg = "leios-quorum-test" :: BS.ByteString - contributions = signContribs msg [(0, NE.head sks)] + contributions = signContribs msg [(0, sk0)] in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee 1 msg cert === Left (InsufficientWeight WeightMismatch {got = 1 / fromIntegral @Int @Weight n, required = 1}) @@ -290,7 +289,7 @@ prop_verifyLeiosCert_rejects_oversized_signers = forAll genN $ \n -> let (sks, committeeA) = fixedCommittee n (_, committeeB) = fixedCommittee (n + 8) msg = "leios-malformed-test" :: BS.ByteString - contributions = signContribs msg (zip [0 :: Int ..] (NE.toList sks)) + contributions = signContribs msg (zip [0 :: Int ..] (toList sks)) in aggregateOrFail committeeA contributions $ \cert -> verifyLeiosCert committeeB 1 msg cert === Left MalformedSigners @@ -303,9 +302,10 @@ prop_verifyLeiosCert_rejects_oversized_signers = forAll genN $ \n -> prop_verifyLeiosCert_rejects_tampered_bitfield :: Property prop_verifyLeiosCert_rejects_tampered_bitfield = forAll (chooseInt (2, 16)) $ \n -> let (sks, committee) = fixedCommittee n + (sks0, sks1) = case sks of + s0 :| (s1 : _) -> (s0, s1) + _ -> error "prop_verifyLeiosCert_rejects_tampered_bitfield: n >= 2 invariant violated" msg = "leios-tamper-test" :: BS.ByteString - sks0 = NE.head sks - sks1 = NE.toList sks !! 1 contribsAlone = signContribs msg [(0, sks0)] contribsPair = signContribs msg [(0, sks0), (1, sks1)] in aggregateOrFail committee contribsAlone $ \certA -> @@ -320,11 +320,11 @@ prop_verifyLeiosCert_rejects_tampered_bitfield = forAll (chooseInt (2, 16)) $ \n prop_aggregateLeiosCert_rejects_out_of_range :: Property prop_aggregateLeiosCert_rejects_out_of_range = forAll genN $ \n -> forAll (chooseInt (n, n + 100)) $ \badIdx -> - let (sks, committee) = fixedCommittee n + let (sk0 :| _, committee) = fixedCommittee n msg = "x" :: BS.ByteString bad = VoterId (fromIntegral @Int @Word16 badIdx) - contributions = Map.singleton bad (signDSIGN leiosSignContext msg (NE.head sks)) - in aggregateLeiosCert committee contributions === Left (VoterIdOutOfBounds bad) + contributions = Map.singleton bad (signDSIGN leiosSignContext msg sk0) + in aggregateLeiosCert committee contributions === Left (VoterIdsOutOfBounds (bad :| [])) -- | Aggregating an empty contribution set must fail: the underlying BLS -- 'aggregateSigsDSIGN' rejects the empty input, which surfaces as diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs index be1a6d4e8..2d6fea5ab 100644 --- a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -34,12 +34,13 @@ import Cardano.Crypto.Leios ( leiosSignContext, ) import Cardano.Crypto.Seed (mkSeedFromBytes) -import qualified Data.ByteString as BS import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (Proxy)) +import Data.Ratio ((%)) import qualified Data.Vector.Strict as V import Data.Word (Word16, Word64) -import Test.QuickCheck (Gen, arbitrary, choose, chooseInt, elements, shuffle, vectorOf) +import Test.Cardano.Base.Bytes (genByteString) +import Test.QuickCheck (Gen, choose, chooseInt, elements, shuffle, vectorOf) import Test.QuickCheck.Gen (unGen) import Test.QuickCheck.Random (mkQCGen) @@ -48,7 +49,7 @@ import Test.QuickCheck.Random (mkQCGen) genLeiosSigningKey :: Gen LeiosSigningKey genLeiosSigningKey = do let seedLen = fromIntegral @Word @Int (seedSizeDSIGN (Proxy @LeiosDSIGN)) - seedBytes <- BS.pack <$> vectorOf seedLen arbitrary + seedBytes <- genByteString seedLen pure $ genKeyDSIGN @LeiosDSIGN (mkSeedFromBytes seedBytes) -- | Generate a real BLS 'LeiosSignature' by signing a random message with a @@ -60,7 +61,7 @@ genLeiosSignature :: Gen LeiosSignature genLeiosSignature = do sk <- genLeiosSigningKey msgLen <- choose (0, 256) - msg <- BS.pack <$> vectorOf msgLen arbitrary + msg <- genByteString msgLen pure $ signDSIGN leiosSignContext msg sk -- | Generate a real, canonical 'LeiosCert' by building a fresh committee @@ -79,11 +80,11 @@ genLeiosCert = do sks <- vectorOf n genLeiosSigningKey let committee = Committee . V.fromList $ - [LeiosVoter (1 / fromIntegral n) (deriveVerKeyDSIGN sk) | sk <- sks] + [LeiosVoter (1 % toInteger n) (deriveVerKeyDSIGN sk) | sk <- sks] k <- chooseInt (1, n) signerIxs <- take k <$> shuffle [0 .. n - 1] msgLen <- choose (0, 64) - msg <- BS.pack <$> vectorOf msgLen arbitrary + msg <- genByteString msgLen let sigs = Map.fromList [ (VoterId (fromIntegral @Int @Word16 i), signDSIGN leiosSignContext msg (sks !! i)) From f7b17efeda93f1afae5a00633551f4c703b06d20 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 26 Jun 2026 21:11:09 +0200 Subject: [PATCH 26/28] Only report received weight on InsufficientWeight --- .../src/Cardano/Crypto/Leios.hs | 27 ++++++------------- .../test/Test/Cardano/Crypto/Leios.hs | 3 +-- 2 files changed, 9 insertions(+), 21 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index fd2f40788..fc3b39533 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -44,7 +44,6 @@ module Cardano.Crypto.Leios ( aggregateLeiosCert, -- ** Verification - WeightMismatch (..), VerificationError (..), verifyLeiosCert, @@ -322,17 +321,7 @@ data VerificationError -- signature, or a bitfield/aggregate mismatch). InvalidSignature | -- | Sum of signers' weights is below the required threshold. - InsufficientWeight !WeightMismatch - deriving stock (Eq, Show, Generic) - deriving anyclass (NFData) - --- | The mismatch between the actual contributing weight and the minimum --- threshold a 'LeiosCert' is required to meet. Carried by --- 'InsufficientWeight'. -data WeightMismatch = WeightMismatch - { got :: !Weight - , required :: !Weight - } + InsufficientWeight Weight deriving stock (Eq, Show, Generic) deriving anyclass (NFData) @@ -367,25 +356,25 @@ verifyLeiosCert :: LeiosCert -> -- | Total weight of the contributing signers on success. Either VerificationError Weight -verifyLeiosCert committee required msg cert = do +verifyLeiosCert committee weightRequired msg cert = do -- The bitfield must be exactly the canonical 'committee-many bits, padded -- to a whole byte' length. Trailing bytes (zero-padded or otherwise) are -- not accepted; the wire form is fixed for a given committee size. when (sizeofByteArray (bitFieldBytes cert.signers) /= (n + 7) `div` 8) $ Left MalformedSigners - (got, vks) <- foldlM accumSigner (0, []) $ bitFieldMembers cert.signers - when (got < required) $ - Left (InsufficientWeight WeightMismatch {got, required}) + (weightReceived, vks) <- foldrM accumSigner (0, []) $ bitFieldMembers cert.signers + when (weightReceived < weightRequired) $ + Left (InsufficientWeight weightReceived) aggVk <- - uncheckedAggregateVerKeysDSIGN (reverse vks) -- REVIEW: reverse needed? + uncheckedAggregateVerKeysDSIGN vks & first (const InvalidSignature) verifyDSIGN leiosSignContext aggVk msg cert.aggregatedSignature & first (const InvalidSignature) - pure got + pure weightReceived where n = committeeSize committee - accumSigner (!w, !ks) vid = + accumSigner vid (!w, !ks) = case resolveVoter committee vid of Nothing -> Left MalformedSigners Just (LeiosVoter w' vk) -> Right (w + w', vk : ks) diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index ad28c1e28..0f1ec76c6 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -24,7 +24,6 @@ import Cardano.Crypto.Leios ( VerificationError (..), VoterId (..), Weight, - WeightMismatch (..), aggregateLeiosCert, decodeLeiosCert, decodeVoterId, @@ -277,7 +276,7 @@ prop_verifyLeiosCert_rejects_below_threshold = forAll (chooseInt (2, 16)) $ \n - contributions = signContribs msg [(0, sk0)] in aggregateOrFail committee contributions $ \cert -> verifyLeiosCert committee 1 msg cert - === Left (InsufficientWeight WeightMismatch {got = 1 / fromIntegral @Int @Weight n, required = 1}) + === Left (InsufficientWeight (1 / fromIntegral @Int @Weight n)) -- | A 'signers' bitfield whose byte length differs from @⌈n/8⌉@ must be -- rejected as 'MalformedSigners' before any signature work is done. We From b674e7dc43c57d76452927cd0bc2bca0cdf25594 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 26 Jun 2026 22:39:21 +0200 Subject: [PATCH 27/28] Rename to Leios{Committee,VoterId} This should avoid conflicts with existing or currently being created types (Peras) --- .../src/Cardano/Crypto/Leios.hs | 88 +++++++++---------- .../test/Test/Cardano/Crypto/Leios.hs | 72 +++++++-------- .../test/golden/{VoterId => LeiosVoterId} | 0 .../testlib/Test/Cardano/Crypto/Leios/Gen.hs | 8 +- 4 files changed, 85 insertions(+), 83 deletions(-) rename cardano-crypto-leios/test/golden/{VoterId => LeiosVoterId} (100%) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index fc3b39533..477dcc6c7 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -25,14 +25,14 @@ module Cardano.Crypto.Leios ( -- * Voting committee Weight, - VoterId (..), - encodeVoterId, - decodeVoterId, + LeiosVoterId (..), + encodeLeiosVoterId, + decodeLeiosVoterId, LeiosVoter (..), - Committee (..), - committeeSize, - resolveVoter, - getVoterId, + LeiosCommittee (..), + leiosCommitteeSize, + resolveLeiosVoter, + getLeiosVoterId, -- * Leios certificates LeiosCert (..), @@ -130,19 +130,19 @@ type Weight = Rational -- 'committeeVoters' and determines its bit in the 'LeiosCert' @signers@ -- bitfield (MSB-first within each byte, so voter @i@ ↔ bit @7-(i mod 8)@ of -- byte @i \`div\` 8@). -newtype VoterId = VoterId {voterIndex :: Word16} +newtype LeiosVoterId = LeiosVoterId {voterIndex :: Word16} deriving stock (Eq, Ord, Show, Generic) deriving anyclass (NFData, NoThunks) --- | Plain CBOR encoder for 'VoterId'. -encodeVoterId :: VoterId -> Encoding -encodeVoterId (VoterId idx) = encodeWord16 idx +-- | Plain CBOR encoder for 'LeiosVoterId'. +encodeLeiosVoterId :: LeiosVoterId -> Encoding +encodeLeiosVoterId (LeiosVoterId idx) = encodeWord16 idx --- | Plain CBOR decoder for 'VoterId'. -decodeVoterId :: Decoder s VoterId -decodeVoterId = VoterId <$> decodeWord16 +-- | Plain CBOR decoder for 'LeiosVoterId'. +decodeLeiosVoterId :: Decoder s LeiosVoterId +decodeLeiosVoterId = LeiosVoterId <$> decodeWord16 --- | A single seat in a 'Committee': a voter's normalised weight paired with +-- | A single seat in a 'LeiosCommittee': a voter's normalised weight paired with -- its BLS verification key. data LeiosVoter = LeiosVoter { voterWeight :: !Weight @@ -154,49 +154,49 @@ data LeiosVoter = LeiosVoter -- | The voting committee for a Leios epoch: an ordered vector of -- 'LeiosVoter' seats. -- --- Ixition determines the voter's 'VoterId' and its bit in the certificate's +-- Ixition determines the voter's 'LeiosVoterId' and its bit in the certificate's -- bitfield, so callers must keep the order stable between construction and -- verification of any cert. -- -- This package intentionally does not provide committee selection — sampling -- voters from the active stake distribution lives in consensus/ledger. -- However, callers are responsible for ensuring that every voter's BLS --- proof-of-possession has been verified before a 'Committee' value is built; +-- proof-of-possession has been verified before a 'LeiosCommittee' value is built; -- 'verifyLeiosCert' and 'aggregateLeiosCert' both rely on this invariant to -- skip per-key PoP checks (they use 'uncheckedAggregateVerKeysDSIGN' / -- 'aggregateSigsDSIGN' under the hood). Passing in unchecked keys defeats -- the security of the aggregate signature. -newtype Committee = Committee {committeeVoters :: Vector LeiosVoter} +newtype LeiosCommittee = LeiosCommittee {committeeVoters :: Vector LeiosVoter} deriving stock (Show, Eq, Generic) deriving anyclass (NFData) -- 'nothunks' ships no instance for 'Data.Vector.Strict.Vector' and we don't -- want to add an orphan. A WHNF-only check on the wrapper is sufficient here: -- the strict 'Vector' forces every cell to WHNF, and a WHNF 'LeiosVoter' - -- forces both of its strict fields, so "Committee in WHNF" structurally + -- forces both of its strict fields, so "LeiosCommittee in WHNF" structurally -- implies no thunks anywhere inside. - deriving (NoThunks) via OnlyCheckWhnfNamed "Committee" Committee + deriving (NoThunks) via OnlyCheckWhnfNamed "LeiosCommittee" LeiosCommittee -- | Number of seats in the committee. -committeeSize :: Committee -> Int -committeeSize Committee {committeeVoters} = length committeeVoters +leiosCommitteeSize :: LeiosCommittee -> Int +leiosCommitteeSize LeiosCommittee {committeeVoters} = length committeeVoters --- | Resolve a 'VoterId' to its 'LeiosVoter' on the 'Committee', or 'Nothing' +-- | Resolve a 'LeiosVoterId' to its 'LeiosVoter' on the 'LeiosCommittee', or 'Nothing' -- if the index is past the committee bound. -resolveVoter :: Committee -> VoterId -> Maybe LeiosVoter -resolveVoter committee voterId = +resolveLeiosVoter :: LeiosCommittee -> LeiosVoterId -> Maybe LeiosVoter +resolveLeiosVoter committee voterId = committee.committeeVoters V.!? idx where idx = fromIntegral @Word16 @Int voterId.voterIndex --- | Find a voter's 'VoterId' on the 'Committee' by its +-- | Find a voter's 'LeiosVoterId' on the 'LeiosCommittee' by its -- 'LeiosVerificationKey', or 'Nothing' if the key is not on the committee. -- -- If the committee carries duplicate verification keys, returns the smallest -- index matching @vk@ (committee selection is expected to deduplicate, but -- this module does not enforce it). -getVoterId :: LeiosVerificationKey -> Committee -> Maybe VoterId -getVoterId vk committee = - VoterId . fromIntegral @Int @Word16 +getLeiosVoterId :: LeiosVerificationKey -> LeiosCommittee -> Maybe LeiosVoterId +getLeiosVoterId vk committee = + LeiosVoterId . fromIntegral @Int @Word16 <$> V.findIndex ((== vk) . voterVKey) committee.committeeVoters -- | A Leios certificate over an endorser block, as specified in CIP-164: @@ -256,7 +256,7 @@ decodeLeiosCert = do data AggregationError = -- | One or more voter indices in the sigs are past the committee bound. - VoterIdsOutOfBounds (NonEmpty VoterId) + VoterIdsOutOfBounds (NonEmpty LeiosVoterId) | -- | BLS signature aggregation failed (e.g. malformed input signature). BLSAggregationFailed Text deriving stock (Eq, Show, Generic) @@ -274,15 +274,15 @@ data AggregationError -- -- == What this function does -- --- * Range-checks each 'VoterId' against the committee. +-- * Range-checks each 'LeiosVoterId' against the committee. -- * Encodes the bitfield over the committee and aggregates the input -- signatures. -- -- This is the only way to construct a 'LeiosCert' from outside the package; -- the bitfield layout is an internal wire-format detail. aggregateLeiosCert :: - Committee -> - Map VoterId LeiosSignature -> + LeiosCommittee -> + Map LeiosVoterId LeiosSignature -> Either AggregationError LeiosCert aggregateLeiosCert committee sigs = do case nonEmpty outOfBoundsVoterIds of @@ -294,14 +294,14 @@ aggregateLeiosCert committee sigs = do pure LeiosCert {signers, aggregatedSignature} where outOfBoundsVoterIds = - [vid | vid <- Map.keys sigs, isNothing $ resolveVoter committee vid] + [vid | vid <- Map.keys sigs, isNothing $ resolveLeiosVoter committee vid] -- Builds directly into a mutable 'ByteArray' via a single allocation and -- writes one bit per member of the input set. signers = BitField $ runByteArray $ do mba <- newByteArray len fillByteArray mba 0 len 0 - forM_ (Map.keys sigs) $ \(VoterId i) -> do + forM_ (Map.keys sigs) $ \(LeiosVoterId i) -> do let idx = fromIntegral @Word16 @Int i when (idx < n) $ do let byteIx = idx `shiftR` 3 @@ -310,12 +310,12 @@ aggregateLeiosCert committee sigs = do writeByteArray mba byteIx (b `setBit` bitIx) pure mba - n = committeeSize committee + n = leiosCommitteeSize committee len = (n + 7) `div` 8 data VerificationError - = -- | 'signers' bitfield is longer than @⌈committeeSize/8⌉@ bytes. + = -- | 'signers' bitfield is longer than @⌈leiosCommitteeSize/8⌉@ bytes. MalformedSigners | -- | The aggregate-BLS verification failed (wrong message, tampered -- signature, or a bitfield/aggregate mismatch). @@ -325,12 +325,12 @@ data VerificationError deriving stock (Eq, Show, Generic) deriving anyclass (NFData) --- | Verify a 'LeiosCert' against a 'Committee', a weight threshold, and the +-- | Verify a 'LeiosCert' against a 'LeiosCommittee', a weight threshold, and the -- message the signers were supposed to have signed. -- -- == Caller obligations -- --- Every voter in the 'Committee' must have had its BLS proof-of-possession +-- Every voter in the 'LeiosCommittee' must have had its BLS proof-of-possession -- verified beforehand (when the committee was selected). 'verifyLeiosCert' -- uses 'uncheckedAggregateVerKeysDSIGN' and does not re-check PoPs; passing -- in an unchecked committee breaks the security of the aggregate signature. @@ -348,7 +348,7 @@ data VerificationError -- @msg@. verifyLeiosCert :: SignableRepresentation msg => - Committee -> + LeiosCommittee -> -- | Minimum signer weight required to accept the cert. Weight -> -- | The message the signers signed. @@ -372,15 +372,15 @@ verifyLeiosCert committee weightRequired msg cert = do & first (const InvalidSignature) pure weightReceived where - n = committeeSize committee + n = leiosCommitteeSize committee accumSigner vid (!w, !ks) = - case resolveVoter committee vid of + case resolveLeiosVoter committee vid of Nothing -> Left MalformedSigners Just (LeiosVoter w' vk) -> Right (w + w', vk : ks) bitFieldMembers (BitField ba) = - [ VoterId (fromIntegral @Int @Word16 globalIx) + [ LeiosVoterId (fromIntegral @Int @Word16 globalIx) | byteIx <- [0 .. sizeofByteArray ba - 1] , let byte = indexByteArray ba byteIx :: Word8 , bitIx <- [0 .. 7] @@ -389,7 +389,7 @@ verifyLeiosCert committee weightRequired msg cert = do , testBit byte (7 - bitIx) ] --- | The @signers@ bitfield of a 'LeiosCert': a @⌈committeeSize\/8⌉@-byte +-- | The @signers@ bitfield of a 'LeiosCert': a @⌈leiosCommitteeSize\/8⌉@-byte -- MSB-first packed-bits representation of which committee voters contributed -- to the aggregate signature. -- diff --git a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs index 0f1ec76c6..bc254ec71 100644 --- a/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/test/Test/Cardano/Crypto/Leios.hs @@ -15,24 +15,24 @@ import Cardano.Crypto.DSIGN ( ) import Cardano.Crypto.Leios ( AggregationError (..), - Committee (..), LeiosCert (..), + LeiosCommittee (..), LeiosDSIGN, LeiosSignature, LeiosSigningKey, LeiosVoter (..), + LeiosVoterId (..), VerificationError (..), - VoterId (..), Weight, aggregateLeiosCert, decodeLeiosCert, - decodeVoterId, + decodeLeiosVoterId, encodeBitField, encodeLeiosCert, - encodeVoterId, - getVoterId, + encodeLeiosVoterId, + getLeiosVoterId, leiosSignContext, - resolveVoter, + resolveLeiosVoter, verifyLeiosCert, ) import Cardano.Crypto.Seed (mkSeedFromBytes) @@ -71,7 +71,7 @@ spec = do goldenEncoding "test/golden/LeiosCert" encodeLeiosCert exampleCert describe "aggregateLeiosCert" $ do - prop "rejects an out-of-range VoterId" prop_aggregateLeiosCert_rejects_out_of_range + prop "rejects an out-of-range LeiosVoterId" prop_aggregateLeiosCert_rejects_out_of_range prop "rejects empty contributions" prop_aggregateLeiosCert_rejects_empty describe "verifyLeiosCert" $ do @@ -84,14 +84,16 @@ spec = do prop "rejects a bitfield wider than the committee" prop_verifyLeiosCert_rejects_oversized_signers prop "rejects a tampered bitfield" prop_verifyLeiosCert_rejects_tampered_bitfield - describe "VoterId" $ do + describe "LeiosVoterId" $ do prop "round-trips through CBOR" prop_roundtrip_VoterId it "matches golden encoding" $ - goldenEncoding "test/golden/VoterId" encodeVoterId exampleVoterId + goldenEncoding "test/golden/LeiosVoterId" encodeLeiosVoterId exampleVoterId - describe "Committee" $ do - prop "getVoterId and resolveVoter agree on verification keys" prop_resolveVoter_getVoterId_inverse - prop "getVoterId returns the first matching index" prop_getVoterId_returns_first_index + describe "LeiosCommittee" $ do + prop + "getLeiosVoterId and resolveLeiosVoter agree on verification keys" + prop_resolveVoter_getVoterId_inverse + prop "getLeiosVoterId returns the first matching index" prop_getVoterId_returns_first_index -- * CBOR roundtrip / golden @@ -137,18 +139,18 @@ exampleCert = case aggregateLeiosCert committee contributions of msg = "leios-golden-message" :: BS.ByteString contributions = signContribs msg (zip [0 ..] (toList sks)) --- * VoterId CBOR / committee lookup +-- * LeiosVoterId CBOR / committee lookup prop_roundtrip_VoterId :: Property -prop_roundtrip_VoterId = forAll (VoterId <$> QC.arbitrary) $ \vid -> - let bs = CBOR.serialize (encodeVoterId vid) - in CBOR.decodeFullDecoder "VoterId" decodeVoterId bs === Right vid +prop_roundtrip_VoterId = forAll (LeiosVoterId <$> QC.arbitrary) $ \vid -> + let bs = CBOR.serialize (encodeLeiosVoterId vid) + in CBOR.decodeFullDecoder "LeiosVoterId" decodeLeiosVoterId bs === Right vid -exampleVoterId :: VoterId -exampleVoterId = VoterId 0xABCD +exampleVoterId :: LeiosVoterId +exampleVoterId = LeiosVoterId 0xABCD --- | 'getVoterId' and 'resolveVoter' are mutual inverses on the verification --- key projection: for any voter in the committee, looking up its 'VoterId' +-- | 'getLeiosVoterId' and 'resolveLeiosVoter' are mutual inverses on the verification +-- key projection: for any voter in the committee, looking up its 'LeiosVoterId' -- via its key and resolving back to a 'LeiosVoter' yields the same key. prop_resolveVoter_getVoterId_inverse :: Property prop_resolveVoter_getVoterId_inverse = @@ -157,16 +159,16 @@ prop_resolveVoter_getVoterId_inverse = voters = V.toList committee.committeeVoters in QC.conjoin [ counterexample ("voter index " <> show i) $ - case getVoterId (voterVKey voter) committee of + case getLeiosVoterId (voterVKey voter) committee of Nothing -> QC.property False Just vid -> - case resolveVoter committee vid of + case resolveLeiosVoter committee vid of Nothing -> QC.property False Just voter' -> voterVKey voter' === voterVKey voter | (i :: Int, voter) <- zip [0 ..] voters ] --- | When the committee carries duplicate verification keys, 'getVoterId' +-- | When the committee carries duplicate verification keys, 'getLeiosVoterId' -- returns the smallest matching index. We don't deduplicate committees -- internally; downstream selection is expected to. prop_getVoterId_returns_first_index :: Property @@ -176,10 +178,10 @@ prop_getVoterId_returns_first_index = voters = V.toList committee.committeeVoters in QC.conjoin [ counterexample ("first occurrence at " <> show i) $ - getVoterId (voterVKey voter) duped - === Just (VoterId (fromIntegral i)) + getLeiosVoterId (voterVKey voter) duped + === Just (LeiosVoterId (fromIntegral i)) | let duped = - Committee + LeiosCommittee (committee.committeeVoters <> committee.committeeVoters) , (i :: Int, voter) <- zip [0 ..] voters ] @@ -190,10 +192,10 @@ prop_getVoterId_returns_first_index = -- Returns the signing keys alongside the committee so tests can produce -- contributions. The 'NonEmpty' return reflects the @n ≥ 1@ precondition and -- gives tests a total 'head' for "any-one-signer" cases. -fixedCommittee :: Int -> (NonEmpty LeiosSigningKey, Committee) +fixedCommittee :: Int -> (NonEmpty LeiosSigningKey, LeiosCommittee) fixedCommittee n = ( sks - , Committee + , LeiosCommittee ( V.fromList [LeiosVoter (1 / fromIntegral @Int @Weight n) (deriveVerKeyDSIGN sk) | sk <- toList sks] ) @@ -216,16 +218,16 @@ genMsg :: QC.Gen BS.ByteString genMsg = chooseInt (0, 64) >>= genByteString -- | Sign @msg@ with each of the given keys and pack them into a 'Map' keyed --- by 'VoterId', matching the input shape of 'aggregateLeiosCert'. -signContribs :: BS.ByteString -> [(Int, LeiosSigningKey)] -> Map VoterId LeiosSignature +-- by 'LeiosVoterId', matching the input shape of 'aggregateLeiosCert'. +signContribs :: BS.ByteString -> [(Int, LeiosSigningKey)] -> Map LeiosVoterId LeiosSignature signContribs msg pairs = Map.fromList - [(VoterId (fromIntegral @Int @Word16 i), signDSIGN leiosSignContext msg sk) | (i, sk) <- pairs] + [(LeiosVoterId (fromIntegral @Int @Word16 i), signDSIGN leiosSignContext msg sk) | (i, sk) <- pairs] -- | Aggregate or fail the property with the error. aggregateOrFail :: - Committee -> - Map VoterId LeiosSignature -> + LeiosCommittee -> + Map LeiosVoterId LeiosSignature -> (LeiosCert -> Property) -> Property aggregateOrFail committee contributions k = case aggregateLeiosCert committee contributions of @@ -315,13 +317,13 @@ prop_verifyLeiosCert_rejects_tampered_bitfield = forAll (chooseInt (2, 16)) $ \n verifyLeiosCert committee (1 / fromIntegral @Int @Weight n) msg tampered === Left InvalidSignature --- | A 'VoterId' past the committee bound is rejected at aggregation time. +-- | A 'LeiosVoterId' past the committee bound is rejected at aggregation time. prop_aggregateLeiosCert_rejects_out_of_range :: Property prop_aggregateLeiosCert_rejects_out_of_range = forAll genN $ \n -> forAll (chooseInt (n, n + 100)) $ \badIdx -> let (sk0 :| _, committee) = fixedCommittee n msg = "x" :: BS.ByteString - bad = VoterId (fromIntegral @Int @Word16 badIdx) + bad = LeiosVoterId (fromIntegral @Int @Word16 badIdx) contributions = Map.singleton bad (signDSIGN leiosSignContext msg sk0) in aggregateLeiosCert committee contributions === Left (VoterIdsOutOfBounds (bad :| [])) diff --git a/cardano-crypto-leios/test/golden/VoterId b/cardano-crypto-leios/test/golden/LeiosVoterId similarity index 100% rename from cardano-crypto-leios/test/golden/VoterId rename to cardano-crypto-leios/test/golden/LeiosVoterId diff --git a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs index 2d6fea5ab..f5aad0613 100644 --- a/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs +++ b/cardano-crypto-leios/testlib/Test/Cardano/Crypto/Leios/Gen.hs @@ -23,13 +23,13 @@ import Cardano.Crypto.DSIGN ( signDSIGN, ) import Cardano.Crypto.Leios ( - Committee (..), LeiosCert, + LeiosCommittee (..), LeiosDSIGN, LeiosSignature, LeiosSigningKey, LeiosVoter (..), - VoterId (..), + LeiosVoterId (..), aggregateLeiosCert, leiosSignContext, ) @@ -79,7 +79,7 @@ genLeiosCert = do n <- elements [1, 8, 9, 16, 17, 24] sks <- vectorOf n genLeiosSigningKey let committee = - Committee . V.fromList $ + LeiosCommittee . V.fromList $ [LeiosVoter (1 % toInteger n) (deriveVerKeyDSIGN sk) | sk <- sks] k <- chooseInt (1, n) signerIxs <- take k <$> shuffle [0 .. n - 1] @@ -87,7 +87,7 @@ genLeiosCert = do msg <- genByteString msgLen let sigs = Map.fromList - [ (VoterId (fromIntegral @Int @Word16 i), signDSIGN leiosSignContext msg (sks !! i)) + [ (LeiosVoterId (fromIntegral @Int @Word16 i), signDSIGN leiosSignContext msg (sks !! i)) | i <- signerIxs ] case aggregateLeiosCert committee sigs of From feba49c56a0714cde899ae2d5fcafca13671c20f Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Fri, 26 Jun 2026 22:45:12 +0200 Subject: [PATCH 28/28] Prevent Word16 overflow using a partial function While this is less defensive, it avoids an overflow going unnoticed. --- .../src/Cardano/Crypto/Leios.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs index 477dcc6c7..2312c09b0 100644 --- a/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs +++ b/cardano-crypto-leios/src/Cardano/Crypto/Leios.hs @@ -194,10 +194,24 @@ resolveLeiosVoter committee voterId = -- If the committee carries duplicate verification keys, returns the smallest -- index matching @vk@ (committee selection is expected to deduplicate, but -- this module does not enforce it). +-- +-- Errors if the matching index does not fit in 'Word16'. The wire format of +-- 'LeiosCert' indexes voters by a 16-bit field, so a committee with more than +-- @2^16@ seats is already malformed. NOTE: this partiality could later be +-- avoided by introducing a smart constructor for 'LeiosCommittee' (or for the +-- committee-selection step in consensus) that rejects oversized committees +-- up front. getLeiosVoterId :: LeiosVerificationKey -> LeiosCommittee -> Maybe LeiosVoterId getLeiosVoterId vk committee = - LeiosVoterId . fromIntegral @Int @Word16 - <$> V.findIndex ((== vk) . voterVKey) committee.committeeVoters + toVoterId <$> V.findIndex ((== vk) . voterVKey) committee.committeeVoters + where + toVoterId i + | i > fromIntegral @Word16 @Int maxBound = + error $ + "Cardano.Crypto.Leios.getVoterId: committee index " + <> show i + <> " does not fit in Word16" + | otherwise = LeiosVoterId (fromIntegral @Int @Word16 i) -- | A Leios certificate over an endorser block, as specified in CIP-164: --