Leios: Use BLS keys from command line

cabal.project

@@ -13,10 +13,8 @@ repository cardano-haskell-packages
 -- See CONTRIBUTING for some Nix commands you will need to run if you
 -- update either of these.
 index-state:
-  -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2026-05-26T19:31:06Z
-  -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2026-06-29T12:05:19Z
+  , hackage.haskell.org 2026-07-15T21:58:35Z
+  , cardano-haskell-packages 2026-07-27T20:44:57Z
 
 -- TODO: needed to drop because newer cuddle on hackage would have not been seen
 -- active-repositories:
@@ -45,6 +43,12 @@ if os (windows)
   constraints:
     bitvec -simd
 
+-- TODO: bump packages instead of this
+allow-newer:
+  , cardano-crypto-class
+constraints:
+  , any.crypton < 1.1
+
 -- Points to ouroboros-network/leios-prototype
 source-repository-package
   type: git
@@ -69,8 +73,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/cardano-ledger
-  tag: fb8d6f8a83b0efb86281e0b80e7ffba160dad8b1
-  --sha256: sha256-U/vpyZNerL1YXiQg1TIAOL5L438NNE3XkuIYD0HPTJw=
+  tag: f3104f00f9819ba94de119c38bc3e0109982821f
+  --sha256: sha256-jkdxc8jmx1Paw+SxbQjPORBeeO2GVBeC6OGkP0vZwgc=
   subdir:
     libs/cardano-data
     libs/cardano-ledger-api
@@ -97,3 +101,15 @@ source-repository-package
   subdir:
     kes-agent
     kes-agent-crypto
+
+-- cardano-base ch1bo/mk-committee (Leios committee/BLS + crypton memory revert).
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/cardano-base
+  tag: 9c6078d9c39c542abcb5912d0d7c222b7ba8a03d
+  --sha256: sha256-FfzoMXitbX/pzEJDQExQikGef6FcantzGWvqu2g19ho=
+  subdir:
+    cardano-binary
+    cardano-crypto-class
+    cardano-crypto-leios
+    cardano-crypto-praos

changelog.d/20260731_094653_sebastian.nagel_bls_voting_key.md

@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+### Breaking
+
+- `PraosCanBeLeader` gained a `praosCanBeLeaderSignKeyBLS ::
+  Maybe (SignKeyDSIGN BLS12381MinSigDSIGN)` field, carrying the optional BLS
+  (Leios) signing key of a block producer. Code constructing `PraosCanBeLeader`
+  must set this field (`Nothing` when no BLS key is used).
+
+### Non-Breaking
+
+- Added `shelleyLeaderVotingKey`, projecting the BLS voting key out of a
+  `ShelleyLeaderCredentials`.
+
+- `topLevelConfigVotingKey` for the Cardano block is now taken from the
+  block-producer credentials (the BLS key supplied via `--shelley-bls-key`)
+  instead of being unsafely derived from cold-key material. Producers without a
+  BLS key now have `topLevelConfigVotingKey = Nothing` and do not vote.

flake.nix

@@ -21,7 +21,7 @@
       flake = false;
     };
     CHaP = {
-      url = "github:intersectmbo/cardano-haskell-packages?ref=repo";
+      url = "github:intersectmbo/cardano-haskell-packages?ref=index-only";
       flake = false;
     };
     iohkNix = {
@@ -47,7 +47,8 @@
       flake = false;
     };
   };
-  outputs = inputs:
+  outputs =
+    inputs:
     let
       supportedSystems = [
         "x86_64-linux"
@@ -88,7 +89,10 @@
           agda-spec = pkgs.agda-spec.shell;
 
           website = pkgs.mkShell {
-            packages = [ pkgs.nodejs pkgs.yarn ];
+            packages = [
+              pkgs.nodejs
+              pkgs.yarn
+            ];
           };
         };
         inherit hydraJobs;

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs

@@ -19,6 +19,7 @@ module Ouroboros.Consensus.Byron.Crypto.DSIGN
   , VerKeyDSIGN (..)
   ) where
 
+import Cardano.Binary.FixedSizeCodec (FixedSizeCodec (..))
 import qualified Cardano.Chain.Block as CC.Block
 import qualified Cardano.Chain.UTxO as CC.UTxO
 import Cardano.Crypto
@@ -43,7 +44,6 @@ import Data.Coerce (coerce)
 import Data.Proxy (Proxy (..))
 import GHC.Generics (Generic)
 import NoThunks.Class (InspectHeapNamed (..), NoThunks)
-import Ouroboros.Consensus.Util (eitherToMaybe)
 import Ouroboros.Consensus.Util.Condense
 
 class (HasSignTag a, Decoded a) => ByronSignable a
@@ -68,9 +68,6 @@ data ByronDSIGN
 
 instance DSIGNAlgorithm ByronDSIGN where
   type SeedSizeDSIGN ByronDSIGN = 32
-  type VerKeySizeDSIGN ByronDSIGN = 64
-  type SignKeySizeDSIGN ByronDSIGN = 128
-  type SigSizeDSIGN ByronDSIGN = 64
 
   algorithmNameDSIGN _ = "ByronDSIGN"
 
@@ -114,16 +111,23 @@ instance DSIGNAlgorithm ByronDSIGN where
       then Right ()
       else Left "Verification failed"
 
-  rawSerialiseVerKeyDSIGN (VerKeyByronDSIGN (VerificationKey vk)) = CC.unXPub vk
-  rawSerialiseSignKeyDSIGN (SignKeyByronDSIGN (SigningKey sk)) = CC.unXPrv sk
-  rawSerialiseSigDSIGN (SigByronDSIGN (Signature sig)) = CC.unXSignature sig
-
-  rawDeserialiseVerKeyDSIGN bs =
-    VerKeyByronDSIGN . VerificationKey <$> (eitherToMaybe $ CC.xpub bs)
-  rawDeserialiseSignKeyDSIGN bs =
-    SignKeyByronDSIGN . SigningKey <$> (eitherToMaybe $ CC.xprv bs)
-  rawDeserialiseSigDSIGN bs =
-    SigByronDSIGN . Signature <$> (eitherToMaybe $ CC.xsignature bs)
+instance FixedSizeCodec (VerKeyDSIGN ByronDSIGN) where
+  type FixedSize (VerKeyDSIGN ByronDSIGN) = 64
+  rawEncodeFixedSized (VerKeyByronDSIGN (VerificationKey vk)) = CC.unXPub vk
+  rawDecodeFixedSized bs =
+    VerKeyByronDSIGN . VerificationKey <$> either fail pure (CC.xpub bs)
+
+instance FixedSizeCodec (SignKeyDSIGN ByronDSIGN) where
+  type FixedSize (SignKeyDSIGN ByronDSIGN) = 128
+  rawEncodeFixedSized (SignKeyByronDSIGN (SigningKey sk)) = CC.unXPrv sk
+  rawDecodeFixedSized bs =
+    SignKeyByronDSIGN . SigningKey <$> either fail pure (CC.xprv bs)
+
+instance FixedSizeCodec (SigDSIGN ByronDSIGN) where
+  type FixedSize (SigDSIGN ByronDSIGN) = 64
+  rawEncodeFixedSized (SigByronDSIGN (Signature sig)) = CC.unXSignature sig
+  rawDecodeFixedSized bs =
+    SigByronDSIGN . Signature <$> either fail pure (CC.xsignature bs)
 
 instance Condense (SigDSIGN ByronDSIGN) where
   condense (SigByronDSIGN s) = show s

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -46,22 +46,21 @@ module Ouroboros.Consensus.Cardano.Node
 
 import Cardano.Binary (DecoderError (..), enforceSize)
 import Cardano.Chain.Slotting (EpochSlots)
-import Cardano.Crypto.DSIGN (DSIGNAlgorithm (rawDeserialiseSignKeyDSIGN))
-import Cardano.Crypto.Hash.Class (hashToBytes)
 import qualified Cardano.Ledger.Api.Era as L
 import qualified Cardano.Ledger.Api.Transition as L
 import qualified Cardano.Ledger.BaseTypes as SL
-import Cardano.Ledger.Hashes (KeyHash (..), hashKey)
 import qualified Cardano.Ledger.Shelley.API as SL
+import Cardano.Ledger.Shelley.LedgerState (NewEpochState, esSnapshotsL, nesEsL)
+import Cardano.Ledger.State (ssStakeGoL, ssStakeMarkL, ssStakeSetL)
 import Cardano.Prelude (cborError)
 import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..))
+import Cardano.Slotting.Slot (EpochNo (..))
 import qualified Codec.CBOR.Decoding as CBOR
 import Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import Codec.CBOR.Read (deserialiseFromBytes)
 import Control.Exception (assert)
 import qualified Control.Tracer as Tracer
-import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as Short
 import Data.Functor.These (These1 (..))
 import qualified Data.Map.Strict as Map
@@ -73,7 +72,7 @@ import Data.SOP.OptNP (NonEmptyOptNP, OptNP (OptSkip))
 import qualified Data.SOP.OptNP as OptNP
 import Data.SOP.Strict
 import Data.Word (Word16, Word64)
-import Lens.Micro ((^.))
+import Lens.Micro ((&), (.~), (^.))
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Byron.ByronHFC
 import Ouroboros.Consensus.Byron.Ledger (ByronBlock)
@@ -115,7 +114,10 @@ import Ouroboros.Consensus.Shelley.Ledger.Block
   )
 import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion
 import Ouroboros.Consensus.Shelley.Node
-import Ouroboros.Consensus.Shelley.Node.Common (shelleyBlockIssuerVKey)
+import Ouroboros.Consensus.Shelley.Node.Common
+  ( shelleyBlockIssuerVKey
+  , shelleyLeaderVotingKey
+  )
 import qualified Ouroboros.Consensus.Shelley.Node.Praos as Praos
 import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos
 import Ouroboros.Consensus.Storage.Serialisation
@@ -502,6 +504,30 @@ toTriggerHardFork = \case
   CardanoTriggerHardForkAtEpoch epochNo ->
     TriggerHardForkAtEpoch epochNo
 
+-- | Warm the initial stake snapshots for early-bootstrap (test) networks, so the
+-- stake distribution -- and hence anything reading it at genesis, e.g. the Leios
+-- committee via @nesPd@ -- is active from the first epochs instead of only after
+-- the ~2-epoch snapshot pipeline has run. @ssStakeMark@ is already seeded from
+-- genesis staking by the ledger's 'L.injectIntoTestState'; here we backfill
+-- set\/go by how early the era boots. Only fires for
+-- 'CardanoTriggerHardForkAtEpoch' (test-only; real networks use
+-- 'CardanoTriggerHardForkAtDefaultVersion' and are left untouched):
+--
+--   * hard fork at epoch 0   -> go = set = mark
+--   * hard fork at epoch 1   -> set = mark
+--   * hard fork at epoch >=2 -> unchanged
+seedInitialStakeSnapshots ::
+  TriggerHardFork ->
+  NewEpochState era ->
+  NewEpochState era
+seedInitialStakeSnapshots trigger nes = case trigger of
+  TriggerHardForkAtEpoch (EpochNo 0) -> nes & setSnap ssStakeSetL & setSnap ssStakeGoL
+  TriggerHardForkAtEpoch (EpochNo 1) -> nes & setSnap ssStakeSetL
+  _ -> nes
+ where
+  mark = nes ^. nesEsL . esSnapshotsL . ssStakeMarkL
+  setSnap l = (nesEsL . esSnapshotsL . l) .~ mark
+
 newtype CardanoHardForkTriggers = CardanoHardForkTriggers
   { getCardanoHardForkTriggers ::
       NP CardanoHardForkTrigger (CardanoShelleyEras StandardCrypto)
@@ -949,18 +975,13 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano
             (Shelley.ShelleyStorageConfig praosSlotsPerKESPeriod k)
             (Shelley.ShelleyStorageConfig praosSlotsPerKESPeriod k)
       , topLevelConfigCheckpoints = cardanoCheckpoints
-      , -- FIXME: REMOVE THIS. Accesses and re-uses KES signing key material.
-        topLevelConfigVotingKey = do
+      , -- The Leios/Peras voting key comes from the block-producer credentials
+        -- (loaded from @--shelley-bls-key@). We vote with the first set of
+        -- credentials that carries a BLS key; 'Nothing' disables voting.
+        topLevelConfigVotingKey =
           case credssShelleyBased of
             [] -> Nothing
-            (c : _) ->
-              rawDeserialiseSignKeyDSIGN
-                -- Pad the 28 bytes of blake2b_224 to get 32 bytes for BLS
-                . (<> BS.pack (replicate 4 0))
-                . hashToBytes
-                . unKeyHash
-                . hashKey
-                $ shelleyBlockIssuerVKey c
+            (c : _) -> shelleyLeaderVotingKey c
       }
 
   -- When the initial ledger state is not in the Byron era, register various
@@ -989,23 +1010,45 @@ protocolInfoCardano (SomeHasFS hasFS) paramsCardano
         (CardanoEras c)
     perEraInjections =
       fn (Comp . pure)
-        :* hcmap (Proxy @IsShelleyBlock) shelleyInjection shelleyTcfgs
+        :* hczipWith
+          (Proxy @IsShelleyBlock)
+          (\(K trigger) -> shelleyInjection trigger)
+          perEraTriggers
+          shelleyTcfgs
+
+    -- Crypto-erased triggers per Shelley-based era, so 'shelleyInjection' can
+    -- warm the initial stake snapshots on an early ('AtEpoch') bootstrap. A K-NP
+    -- avoids the @c ~ StandardCrypto@ mismatch of the raw 'CardanoHardForkTriggers'.
+    perEraTriggers :: NP (K TriggerHardFork) (CardanoShelleyEras c)
+    perEraTriggers =
+      K (toTriggerHardFork triggerHardForkShelley)
+        :* K (toTriggerHardFork triggerHardForkAllegra)
+        :* K (toTriggerHardFork triggerHardForkMary)
+        :* K (toTriggerHardFork triggerHardForkAlonzo)
+        :* K (toTriggerHardFork triggerHardForkBabbage)
+        :* K (toTriggerHardFork triggerHardForkConway)
+        :* K (toTriggerHardFork triggerHardForkDijkstra)
+        :* Nil
 
     shelleyInjection ::
       forall proto era.
       Shelley.ShelleyCompatible proto era =>
+      TriggerHardFork ->
       WrapTransitionConfig (ShelleyBlock proto era) ->
       (Flip LedgerState ValuesMK -.-> (m :.: Flip LedgerState ValuesMK))
         (ShelleyBlock proto era)
-    shelleyInjection (WrapTransitionConfig tcfg) = fn $ \(Flip stIn) -> Comp $ do
+    shelleyInjection trigger (WrapTransitionConfig tcfg) = fn $ \(Flip stIn) -> Comp $ do
       let stowed = stowLedgerTables stIn
       newNES <-
         L.injectIntoTestState
           hasFS
           tcfg
           (Shelley.shelleyLedgerState stowed)
       pure . Flip . unstowLedgerTables $
-        stowed{Shelley.shelleyLedgerState = newNES}
+        stowed
+          { Shelley.shelleyLedgerState =
+              seedInitialStakeSnapshots trigger newNES
+          }
 
     shelleyTcfgs :: NP WrapTransitionConfig (CardanoShelleyEras c)
     shelleyTcfgs =