Integrate KES agent functionality into ouroboros-consensus:

- Update to use newest cardano-crypto-class with unsound pure KES implementation

- Use mlocked KES

- Add KES agent connectivity

- Rebase cleanup

- Handle drop-key messages from KES Agent

- Provide KESAgentClientTrace to BlockForging

- Revert change to MockCrypto and require DSIGN only when running the KES agent

- Bump kes-agent SRP to remove SerDoc dependency

Author: lehins

cabal.project

@@ -14,9 +14,9 @@ repository cardano-haskell-packages
 -- update either of these.
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2025-07-22T09:13:54Z
+  , hackage.haskell.org 2025-08-05T11:23:47Z
   -- Bump this if you need newer packages from CHaP
-  , cardano-haskell-packages 2025-07-28T14:33:19Z
+  , cardano-haskell-packages 2025-08-06T09:39:20Z
 
 packages:
   ouroboros-consensus

ouroboros-consensus-cardano/changelog.d/20250130_093803_tdammers_mlocked_kes_rebase.md

@@ -0,0 +1,8 @@
+### Breaking
+
+- Use new mlocked KES API for all internal KES sign key handling.
+- Add finalizers to all block forgings (required by `ouroboros-consensus`).
+- Change `ShelleyLeaderCredentials` to not contain the KES sign key itself
+  anymore. Instead, the `CanBeLeader` data structure now contains a
+  `praosCanBeLeaderCredentialsSource` field, which specifies how to obtain the
+  actual credentials (OpCert and KES SignKey).

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -156,6 +156,7 @@ library
     cardano-strict-containers,
     cborg ^>=0.2.2,
     containers >=0.5 && <0.8,
+    contra-tracer,
     crypton,
     deepseq,
     formatting >=6.3 && <7.3,
@@ -324,6 +325,8 @@ library unstable-shelley-testlib
     cardano-slotting,
     cardano-strict-containers,
     containers,
+    contra-tracer,
+    kes-agent,
     microlens,
     mtl,
     ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib},
@@ -365,6 +368,7 @@ test-suite shelley-test
     cborg,
     constraints,
     containers,
+    contra-tracer,
     filepath,
     measures,
     microlens,
@@ -416,6 +420,7 @@ library unstable-cardano-testlib
     cardano-strict-containers,
     cborg,
     containers,
+    contra-tracer,
     mempack,
     microlens,
     mtl,

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

@@ -143,6 +143,7 @@ byronBlockForging creds =
           slot
           tickedPBftState
     , forgeBlock = \cfg -> return ....: forgeByronBlock cfg
+    , finalize = pure ()
     }
  where
   canBeLeader = mkPBftCanBeLeader creds

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

@@ -55,14 +55,12 @@ import qualified Cardano.Ledger.Api.Transition as L
 import qualified Cardano.Ledger.BaseTypes as SL
 import qualified Cardano.Ledger.Shelley.API as SL
 import Cardano.Prelude (cborError)
-import qualified Cardano.Protocol.TPraos.OCert as Absolute
-  ( KESPeriod (..)
-  , ocertKESPeriod
-  )
+import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..))
 import qualified Codec.CBOR.Decoding as CBOR
 import Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import Control.Exception (assert)
+import qualified Control.Tracer as Tracer
 import qualified Data.ByteString.Short as Short
 import Data.Functor.These (These1 (..))
 import qualified Data.Map.Strict as Map
@@ -97,10 +95,11 @@ import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables)
 import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.ProtocolInfo
 import Ouroboros.Consensus.Node.Run
-import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..))
+import Ouroboros.Consensus.Protocol.Praos.AgentClient
 import Ouroboros.Consensus.Protocol.Praos.Common
-  ( praosCanBeLeaderOpCert
+  ( PraosCanBeLeader (..)
+  , instantiatePraosCredentials
   )
 import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..))
 import qualified Ouroboros.Consensus.Protocol.TPraos as Shelley
@@ -122,7 +121,6 @@ import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos
 import Ouroboros.Consensus.Storage.Serialisation
 import Ouroboros.Consensus.TypeFamilyWrappers
 import Ouroboros.Consensus.Util.Assert
-import Ouroboros.Consensus.Util.IOLike
 
 {-------------------------------------------------------------------------------
   SerialiseHFC
@@ -569,10 +567,12 @@ data CardanoProtocolParams c = CardanoProtocolParams
 -- for mainnet (check against @'SL.gNetworkId' == 'SL.Mainnet'@).
 protocolInfoCardano ::
   forall c m.
-  (IOLike m, CardanoHardForkConstraints c) =>
+  ( CardanoHardForkConstraints c
+  , KESAgentContext c m
+  ) =>
   CardanoProtocolParams c ->
   ( ProtocolInfo (CardanoBlock c)
-  , m [BlockForging m (CardanoBlock c)]
+  , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (CardanoBlock c)]
   )
 protocolInfoCardano paramsCardano
   | SL.Mainnet <- SL.sgNetworkId genesisShelley
@@ -585,7 +585,7 @@ protocolInfoCardano paramsCardano
             { pInfoConfig = cfg
             , pInfoInitLedger = initExtLedgerStateCardano
             }
-        , blockForging
+        , mkBlockForgings
         )
  where
   CardanoProtocolParams
@@ -980,9 +980,9 @@ protocolInfoCardano paramsCardano
   -- credentials. If there are multiple Shelley credentials, we merge the
   -- Byron credentials with the first Shelley one but still have separate
   -- threads for the remaining Shelley ones.
-  blockForging :: m [BlockForging m (CardanoBlock c)]
-  blockForging = do
-    shelleyBased <- traverse blockForgingShelleyBased credssShelleyBased
+  mkBlockForgings :: Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (CardanoBlock c)]
+  mkBlockForgings tr = do
+    shelleyBased <- traverse (blockForgingShelleyBased tr) credssShelleyBased
     let blockForgings :: [NonEmptyOptNP (BlockForging m) (CardanoEras c)]
         blockForgings = case (mBlockForgingByron, shelleyBased) of
           (Nothing, shelleys) -> shelleys
@@ -1004,22 +1004,11 @@ protocolInfoCardano paramsCardano
     return $ byronBlockForging creds `OptNP.at` IZ
 
   blockForgingShelleyBased ::
+    Tracer.Tracer m KESAgentClientTrace ->
     ShelleyLeaderCredentials c ->
     m (NonEmptyOptNP (BlockForging m) (CardanoEras c))
-  blockForgingShelleyBased credentials = do
-    let ShelleyLeaderCredentials
-          { shelleyLeaderCredentialsInitSignKey = initSignKey
-          , shelleyLeaderCredentialsCanBeLeader = canBeLeader
-          } = credentials
-
-    hotKey <- do
-      let maxKESEvo :: Word64
-          maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo
-
-          startPeriod :: Absolute.KESPeriod
-          startPeriod = Absolute.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader
-
-      HotKey.mkHotKey @m @c initSignKey startPeriod maxKESEvo
+  blockForgingShelleyBased tr credentials = do
+    let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials
 
     let slotToPeriod :: SlotNo -> Absolute.KESPeriod
         slotToPeriod (SlotNo slot) =
@@ -1028,6 +1017,15 @@ protocolInfoCardano paramsCardano
               fromIntegral $
                 slot `div` praosSlotsPerKESPeriod
 
+        maxKESEvo :: Word64
+        maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo
+
+    hotKey <-
+      instantiatePraosCredentials
+        maxKESEvo
+        tr
+        (praosCanBeLeaderCredentialsSource canBeLeader)
+
     let tpraos ::
           forall era.
           ShelleyEraWithCrypto c (TPraos c) era =>

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs

@@ -18,9 +18,10 @@ module Ouroboros.Consensus.Shelley.HFEras
   , StandardShelleyBlock
   ) where
 
+import Cardano.Protocol.Crypto
 import Ouroboros.Consensus.Protocol.Praos (Praos)
 import qualified Ouroboros.Consensus.Protocol.Praos as Praos
-import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto, TPraos)
+import Ouroboros.Consensus.Protocol.TPraos (TPraos)
 import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos
 import Ouroboros.Consensus.Shelley.Eras
   ( AllegraEra

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs

@@ -19,12 +19,10 @@ module Ouroboros.Consensus.Shelley.Node.Common
   , shelleyBlockIssuerVKey
   ) where
 
-import Cardano.Crypto.KES (UnsoundPureSignKeyKES)
 import Cardano.Ledger.BaseTypes (unNonZero)
 import qualified Cardano.Ledger.Keys as SL
 import qualified Cardano.Ledger.Shelley.API as SL
 import Cardano.Ledger.Slot
-import Cardano.Protocol.Crypto
 import Data.Text (Text)
 import Ouroboros.Consensus.Block
   ( CannotForge
@@ -59,12 +57,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB
 -------------------------------------------------------------------------------}
 
 data ShelleyLeaderCredentials c = ShelleyLeaderCredentials
-  { shelleyLeaderCredentialsInitSignKey :: UnsoundPureSignKeyKES (KES c)
-  -- ^ The unevolved signing KES key (at evolution 0).
-  --
-  -- Note that this is not inside 'ShelleyCanBeLeader' since it gets evolved
-  -- automatically, whereas 'ShelleyCanBeLeader' does not change.
-  , shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c
+  { shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c
   , shelleyLeaderCredentialsLabel :: Text
   -- ^ Identifier for this set of credentials.
   --

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs

@@ -29,9 +29,6 @@ import Ouroboros.Consensus.Protocol.Praos
   , PraosParams (..)
   , praosCheckCanForge
   )
-import Ouroboros.Consensus.Protocol.Praos.Common
-  ( PraosCanBeLeader (praosCanBeLeaderOpCert)
-  )
 import Ouroboros.Consensus.Shelley.Ledger
   ( ShelleyBlock
   , ShelleyCompatible
@@ -56,21 +53,13 @@ praosBlockForging ::
   , IOLike m
   ) =>
   PraosParams ->
+  HotKey.HotKey c m ->
   ShelleyLeaderCredentials c ->
-  m (BlockForging m (ShelleyBlock (Praos c) era))
-praosBlockForging praosParams credentials = do
-  hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod praosMaxKESEvo
-  pure $ praosSharedBlockForging hotKey slotToPeriod credentials
+  BlockForging m (ShelleyBlock (Praos c) era)
+praosBlockForging praosParams hotKey credentials =
+  praosSharedBlockForging hotKey slotToPeriod credentials
  where
-  PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} = praosParams
-
-  ShelleyLeaderCredentials
-    { shelleyLeaderCredentialsInitSignKey = initSignKey
-    , shelleyLeaderCredentialsCanBeLeader = canBeLeader
-    } = credentials
-
-  startPeriod :: Absolute.KESPeriod
-  startPeriod = SL.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader
+  PraosParams{praosSlotsPerKESPeriod} = praosParams
 
   slotToPeriod :: SlotNo -> Absolute.KESPeriod
   slotToPeriod (SlotNo slot) =
@@ -95,7 +84,7 @@ praosSharedBlockForging
   ShelleyLeaderCredentials
     { shelleyLeaderCredentialsCanBeLeader = canBeLeader
     , shelleyLeaderCredentialsLabel = label
-    } = do
+    } =
     BlockForging
       { forgeLabel = label <> "_" <> T.pack (L.eraName @era)
       , canBeLeader = canBeLeader
@@ -111,4 +100,5 @@ praosSharedBlockForging
             hotKey
             canBeLeader
             cfg
+      , finalize = HotKey.finalize hotKey
       }

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -43,6 +44,7 @@ import qualified Cardano.Protocol.TPraos.OCert as SL
 import Cardano.Slotting.EpochInfo
 import Cardano.Slotting.Time (mkSlotLength)
 import Control.Monad.Except (Except)
+import qualified Control.Tracer as Tracer
 import Data.Bifunctor (first)
 import qualified Data.Text as T
 import qualified Data.Text as Text
@@ -59,6 +61,7 @@ import Ouroboros.Consensus.Node.ProtocolInfo
 import Ouroboros.Consensus.Protocol.Abstract
 import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
 import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
+import Ouroboros.Consensus.Protocol.Praos.AgentClient
 import Ouroboros.Consensus.Protocol.Praos.Common
 import Ouroboros.Consensus.Protocol.TPraos
 import Ouroboros.Consensus.Shelley.Eras
@@ -91,21 +94,13 @@ shelleyBlockForging ::
   , IOLike m
   ) =>
   TPraosParams ->
+  HotKey c m ->
   ShelleyLeaderCredentials c ->
-  m (BlockForging m (ShelleyBlock (TPraos c) era))
-shelleyBlockForging tpraosParams credentials = do
-  hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod tpraosMaxKESEvo
-  pure $ shelleySharedBlockForging hotKey slotToPeriod credentials
+  BlockForging m (ShelleyBlock (TPraos c) era)
+shelleyBlockForging tpraosParams hotKey credentials = do
+  shelleySharedBlockForging hotKey slotToPeriod credentials
  where
-  TPraosParams{tpraosMaxKESEvo, tpraosSlotsPerKESPeriod} = tpraosParams
-
-  ShelleyLeaderCredentials
-    { shelleyLeaderCredentialsInitSignKey = initSignKey
-    , shelleyLeaderCredentialsCanBeLeader = canBeLeader
-    } = credentials
-
-  startPeriod :: Absolute.KESPeriod
-  startPeriod = SL.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader
+  TPraosParams{tpraosSlotsPerKESPeriod} = tpraosParams
 
   slotToPeriod :: SlotNo -> Absolute.KESPeriod
   slotToPeriod (SlotNo slot) =
@@ -141,6 +136,7 @@ shelleySharedBlockForging hotKey slotToPeriod credentials =
           hotKey
           canBeLeader
           cfg
+    , finalize = HotKey.finalize hotKey
     }
  where
   ShelleyLeaderCredentials
@@ -173,14 +169,16 @@ validateGenesis = first errsToString . SL.validateGenesis
 protocolInfoShelley ::
   forall m c.
   ( IOLike m
+  , AgentCrypto c
   , ShelleyCompatible (TPraos c) ShelleyEra
   , TxLimits (ShelleyBlock (TPraos c) ShelleyEra)
+  , MonadKESAgent m
   ) =>
   SL.ShelleyGenesis ->
   ProtocolParamsShelleyBased c ->
   SL.ProtVer ->
   ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra)
-  , m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)]
+  , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)]
   )
 protocolInfoShelley
   shelleyGenesis
@@ -193,16 +191,16 @@ protocolInfoShelley
 
 protocolInfoTPraosShelleyBased ::
   forall m era c.
-  ( IOLike m
-  , ShelleyCompatible (TPraos c) era
+  ( ShelleyCompatible (TPraos c) era
   , TxLimits (ShelleyBlock (TPraos c) era)
+  , KESAgentContext c m
   ) =>
   ProtocolParamsShelleyBased c ->
   L.TransitionConfig era ->
   -- | see 'shelleyProtVer', mutatis mutandi
   SL.ProtVer ->
   ( ProtocolInfo (ShelleyBlock (TPraos c) era)
-  , m [BlockForging m (ShelleyBlock (TPraos c) era)]
+  , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (ShelleyBlock (TPraos c) era)]
   )
 protocolInfoTPraosShelleyBased
   ProtocolParamsShelleyBased
@@ -216,11 +214,24 @@ protocolInfoTPraosShelleyBased
           { pInfoConfig = topLevelConfig
           , pInfoInitLedger = initExtLedgerState
           }
-      , traverse
-          (shelleyBlockForging tpraosParams)
-          credentialss
+      , \tr -> traverse (mkBlockForging tr) credentialss
       )
    where
+    mkBlockForging ::
+      Tracer.Tracer m KESAgentClientTrace ->
+      ShelleyLeaderCredentials c ->
+      m (BlockForging m (ShelleyBlock (TPraos c) era))
+    mkBlockForging tr credentials = do
+      let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials
+
+      hotKey :: HotKey c m <-
+        instantiatePraosCredentials
+          (tpraosMaxKESEvo tpraosParams)
+          tr
+          (praosCanBeLeaderCredentialsSource canBeLeader)
+
+      return $ shelleyBlockForging tpraosParams hotKey credentials
+
     genesis :: SL.ShelleyGenesis
     genesis = transitionCfg ^. L.tcShelleyGenesisL