Use mlocked KES

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

@@ -0,0 +1,18 @@
+### Breaking
+
+- Use new mlocked KES API for all internal KES sign key handling.
+- Add finalizers to all block forgings (required by `ouroboros-consensus`).
+- Change `HotKey` to manage not only KES sign keys, but also the corresponding
+  OpCerts. This is in preparation for KES agent connectivity: with the new
+  design, the KES agent will provide both KES sign keys and matching OpCerts
+  together, and we need to be able to dynamically replace them both together.
+- Add finalizer to `HotKey`. This takes care of securely forgetting any KES
+  keys the HotKey may still hold, and will be called automatically when the
+  owning block forging terminates.
+- 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).
+- The `KesKey` data type in `unstable-cardano-tools` has been renamed to
+  `UnsoundPureKesKey`, to reflect the fact that it uses the old, unsound KES
+  API (which does not use mlocking or secure forgetting).

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

@@ -301,7 +301,7 @@ library unstable-shelley-testlib
     cardano-ledger-alonzo,
     cardano-ledger-alonzo-test,
     cardano-ledger-babbage-test,
-    cardano-ledger-conway-test >=1.2.1,
+    cardano-ledger-conway-test >=1.3.0,
     cardano-ledger-core:{cardano-ledger-core, testlib},
     cardano-ledger-mary,
     cardano-ledger-shelley:{cardano-ledger-shelley, testlib},

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

@@ -140,6 +140,7 @@ byronBlockForging creds = BlockForging {
                                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

@@ -38,6 +38,9 @@ module Ouroboros.Consensus.Cardano.Node (
   , CardanoHardForkTriggers (.., CardanoHardForkTriggers', triggerHardForkShelley, triggerHardForkAllegra, triggerHardForkMary, triggerHardForkAlonzo, triggerHardForkBabbage, triggerHardForkConway)
   , CardanoProtocolParams (..)
   , MaxMajorProtVer (..)
+  , ProtocolParamsByron
+  , ProtocolParamsShelleyBased
+  , CheckpointsMap
   , TriggerHardFork (..)
   , protocolClientInfoCardano
   , protocolInfoCardano
@@ -92,10 +95,8 @@ import           Ouroboros.Consensus.Ledger.Extended
 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.Common
-                     (praosCanBeLeaderOpCert)
+import           Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..), instantiatePraosCredentials)
 import           Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..))
 import qualified Ouroboros.Consensus.Protocol.TPraos as Shelley
 import           Ouroboros.Consensus.Shelley.HFEras ()
@@ -104,9 +105,9 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley
 import           Ouroboros.Consensus.Shelley.Ledger.Block (IsShelleyBlock,
                      ShelleyBlockLedgerEra)
 import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion
+import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import           Ouroboros.Consensus.Shelley.Node
-import           Ouroboros.Consensus.Shelley.Node.Common (ShelleyEraWithCrypto,
-                     shelleyBlockIssuerVKey)
+import           Ouroboros.Consensus.Shelley.Node.Common (ShelleyEraWithCrypto, shelleyBlockIssuerVKey)
 import qualified Ouroboros.Consensus.Shelley.Node.Praos as Praos
 import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos
 import           Ouroboros.Consensus.Storage.Serialisation
@@ -475,12 +476,12 @@ protocolInfoCardano paramsCardano
   , length credssShelleyBased > 1
   = error "Multiple Shelley-based credentials not allowed for mainnet"
   | otherwise
-  = assertWithMsg (validateGenesis genesisShelley)
+  = assertWithMsg (validateGenesis genesisShelley) $
     ( ProtocolInfo {
         pInfoConfig       = cfg
       , pInfoInitLedger   = initExtLedgerStateCardano
       }
-    , blockForging
+    , mkBlockForgings
     )
   where
     CardanoProtocolParams {
@@ -827,8 +828,8 @@ 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
+    mkBlockForgings :: m ([BlockForging m (CardanoBlock c)])
+    mkBlockForgings = do
         shelleyBased <- traverse blockForgingShelleyBased credssShelleyBased
         let blockForgings :: [NonEmptyOptNP (BlockForging m) (CardanoEras c)]
             blockForgings = case (mBlockForgingByron, shelleyBased) of
@@ -854,24 +855,26 @@ protocolInfoCardano paramsCardano
          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
+        let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials
 
         let slotToPeriod :: SlotNo -> Absolute.KESPeriod
             slotToPeriod (SlotNo slot) = assert (tpraosSlotsPerKESPeriod == praosSlotsPerKESPeriod) $
               Absolute.KESPeriod $ fromIntegral $ slot `div` praosSlotsPerKESPeriod
 
+        (ocert, sk) <- instantiatePraosCredentials (praosCanBeLeaderCredentialsSource canBeLeader)
+
+        let startPeriod :: Absolute.KESPeriod
+            startPeriod = Absolute.ocertKESPeriod ocert
+
+        let maxKESEvo :: Word64
+            maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo
+
+        hotKey :: HotKey.HotKey c m <- HotKey.mkHotKey
+                    ocert
+                    sk
+                    startPeriod
+                    maxKESEvo
+
         let tpraos :: forall era.
                  ShelleyEraWithCrypto c       (TPraos c) era
               => BlockForging m (ShelleyBlock (TPraos c) era)

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

@@ -44,6 +44,7 @@ import           Ouroboros.Consensus.Shelley.Ledger
 import           Ouroboros.Consensus.Shelley.Ledger.Inspect ()
 import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ()
 import           Ouroboros.Consensus.Shelley.Node.DiffusionPipelining ()
+import           Ouroboros.Consensus.Shelley.Node.Common
 import           Ouroboros.Consensus.Shelley.Node.Serialisation ()
 import           Ouroboros.Consensus.Shelley.Node.TPraos
 import           Ouroboros.Consensus.Shelley.Protocol.Abstract (pHeaderIssuer)

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

@@ -20,8 +20,6 @@ module Ouroboros.Consensus.Shelley.Node.Common (
   , shelleyBlockIssuerVKey
   ) where
 
-import           Cardano.Crypto.KES (UnsoundPureSignKeyKES)
-import           Cardano.Ledger.Crypto
 import qualified Cardano.Ledger.Keys as SL
 import qualified Cardano.Ledger.Shelley.API as SL
 import           Cardano.Ledger.Slot
@@ -50,12 +48,7 @@ import           Ouroboros.Consensus.Storage.ImmutableDB
 -------------------------------------------------------------------------------}
 
 data ShelleyLeaderCredentials c = ShelleyLeaderCredentials
-  { -- | 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.
-    shelleyLeaderCredentialsInitSignKey :: UnsoundPureSignKeyKES (KES c),
-    shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c,
+  { shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c,
     -- | Identifier for this set of credentials.
     --
     -- Useful when the node is running with multiple sets of credentials.

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

@@ -28,8 +28,6 @@ import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool
 import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import           Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..),
                      praosCheckCanForge)
-import           Ouroboros.Consensus.Protocol.Praos.Common
-                     (PraosCanBeLeader (praosCanBeLeaderOpCert))
 import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock,
                      ShelleyCompatible, forgeShelleyBlock)
@@ -51,21 +49,13 @@ praosBlockForging ::
      , IOLike m
      )
   => PraosParams
+  -> HotKey.HotKey c m
   -> ShelleyLeaderCredentials (EraCrypto era)
-  -> 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) =
@@ -90,7 +80,7 @@ praosSharedBlockForging
   ShelleyLeaderCredentials {
       shelleyLeaderCredentialsCanBeLeader = canBeLeader
     , shelleyLeaderCredentialsLabel = label
-    } = do
+    } =
     BlockForging
       { forgeLabel = label <> "_" <> T.pack (L.eraName @era),
         canBeLeader = canBeLeader,
@@ -105,5 +95,6 @@ praosSharedBlockForging
           forgeShelleyBlock
             hotKey
             canBeLeader
-            cfg
+            cfg,
+        finalize = HotKey.finalize hotKey
       }

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

@@ -55,7 +55,7 @@ import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits)
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Protocol.Abstract
-import           Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
+import           Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey, mkHotKey)
 import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import           Ouroboros.Consensus.Protocol.Praos.Common
 import           Ouroboros.Consensus.Protocol.TPraos
@@ -65,7 +65,8 @@ import           Ouroboros.Consensus.Shelley.Ledger.Inspect ()
 import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ()
 import           Ouroboros.Consensus.Shelley.Node.Common
                      (ProtocolParamsShelleyBased (..), ShelleyEraWithCrypto,
-                     ShelleyLeaderCredentials (..), shelleyBlockIssuerVKey)
+                     ShelleyLeaderCredentials (..),
+                     shelleyBlockIssuerVKey)
 import           Ouroboros.Consensus.Shelley.Node.Serialisation ()
 import           Ouroboros.Consensus.Shelley.Protocol.TPraos ()
 import           Ouroboros.Consensus.Util.Assert
@@ -88,21 +89,13 @@ shelleyBlockForging ::
       , IOLike m
       )
   => TPraosParams
+  -> HotKey c m
   -> ShelleyLeaderCredentials (EraCrypto era)
-  -> 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) =
@@ -139,6 +132,7 @@ shelleySharedBlockForging hotKey slotToPeriod credentials =
             hotKey
             canBeLeader
             cfg
+      , finalize = HotKey.finalize hotKey
       }
   where
     ShelleyLeaderCredentials {
@@ -216,11 +210,25 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
         pInfoConfig       = topLevelConfig
       , pInfoInitLedger   = initExtLedgerState
       }
-    , traverse
-        (shelleyBlockForging tpraosParams)
-        credentialss
+    , traverse mkBlockForging credentialss
     )
   where
+    mkBlockForging :: ShelleyLeaderCredentials c -> m (BlockForging m (ShelleyBlock (TPraos c) era))
+    mkBlockForging credentials = do
+      let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials
+      (ocert, sk) <- instantiatePraosCredentials (praosCanBeLeaderCredentialsSource canBeLeader)
+
+      let startPeriod :: Absolute.KESPeriod
+          startPeriod = SL.ocertKESPeriod ocert
+
+      hotKey :: HotKey c m <- mkHotKey
+                  ocert
+                  sk
+                  startPeriod
+                  (tpraosMaxKESEvo tpraosParams)
+
+      return $ shelleyBlockForging tpraosParams hotKey credentials
+
     genesis :: SL.ShelleyGenesis c
     genesis = transitionCfg ^. L.tcShelleyGenesisL
 

ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs

@@ -66,6 +66,7 @@ dualByronBlockForging creds = BlockForging {
         fmap castForgeStateUpdateInfo .: updateForgeState (dualTopLevelConfigMain cfg)
     , checkCanForge    = checkCanForge . dualTopLevelConfigMain
     , forgeBlock       = return .....: forgeDualByronBlock
+    , finalize         = return ()
     }
   where
     BlockForging {..} = byronBlockForging creds

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs

@@ -9,7 +9,6 @@ module Cardano.Api.Key (
   , CastSigningKeyRole (..)
   , CastVerificationKeyRole (..)
   , Key (..)
-  , generateSigningKey
   ) where
 
 import           Cardano.Api.Any
@@ -51,16 +50,17 @@ class (Eq (VerificationKey keyrole),
     verificationKeyHash :: VerificationKey keyrole -> Hash keyrole
 
 
--- TODO: We should move this into the Key type class, with the existing impl as the default impl.
--- For KES we can then override it to keep the seed and key in mlocked memory at all times.
--- | Generate a 'SigningKey' using a seed from operating system entropy.
---
-generateSigningKey :: Key keyrole => AsType keyrole -> IO (SigningKey keyrole)
-generateSigningKey keytype = do
-    seed <- Crypto.readSeedFromSystemEntropy seedSize
-    return $! deterministicSigningKey keytype seed
-  where
-    seedSize = deterministicSigningKeySeedSize keytype
+    -- | Generate a 'SigningKey' using a seed from operating system entropy.
+    generateSigningKey :: AsType keyrole -> IO (SigningKey keyrole)
+    generateSigningKey keytype = do
+        --
+        -- For KES we can override this to keep the seed and key in mlocked memory
+        -- at all times.
+        --
+        seed <- Crypto.readSeedFromSystemEntropy seedSize
+        return $! deterministicSigningKey keytype seed
+      where
+        seedSize = deterministicSigningKeySeedSize keytype
 
 
 instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where