diff --git a/cabal.project b/cabal.project index 210a9d1abd..5e3a45d4c3 100644 --- a/cabal.project +++ b/cabal.project @@ -26,6 +26,8 @@ packages: sop-extras strict-sop-core +allow-newer: plutus-core:cardano-crypto-class + -- We want to always build the test-suites and benchmarks tests: true benchmarks: true @@ -44,3 +46,38 @@ package ouroboros-network if(os(windows)) constraints: bitvec -simd + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-ledger + tag: 9d380ab7d6ae52ff66aae9a19dbb3036b1b13c94 + --sha256: sha256-N4XRVqC+UgWej+J16RPh3EO6MSIE3wmJvmP5/nRgIuw= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/babbage/test-suite + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/crypto/test + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/ledger/impl/test + eras/conway/impl + eras/conway/test-suite + eras/mary/impl + eras/shelley/impl + eras/shelley-ma/test-suite + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-ledger-test + libs/cardano-protocol-tpraos + libs/constrained-generators + libs/non-integral + libs/set-algebra + libs/small-steps + libs/vector-map diff --git a/ouroboros-consensus-cardano/changelog.d/20250130_093803_tdammers_mlocked_kes_rebase.md b/ouroboros-consensus-cardano/changelog.d/20250130_093803_tdammers_mlocked_kes_rebase.md new file mode 100644 index 0000000000..ef7b3ec95a --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20250130_093803_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,11 @@ +### 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). +- 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). diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 061513b2b2..7d73731fb7 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -129,16 +129,16 @@ library bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-crypto-wrapper, cardano-ledger-allegra ^>=1.6, cardano-ledger-alonzo ^>=1.12, cardano-ledger-api ^>=1.10, cardano-ledger-babbage ^>=1.10, - cardano-ledger-binary ^>=1.5, + cardano-ledger-binary ^>=1.6, cardano-ledger-byron ^>=1.0.1, cardano-ledger-conway ^>=1.18, - cardano-ledger-core ^>=1.16, + cardano-ledger-core ^>=1.17, cardano-ledger-mary ^>=1.7, cardano-ledger-shelley ^>=1.15, cardano-prelude, @@ -147,7 +147,7 @@ library cardano-strict-containers, cborg ^>=0.2.2, containers >=0.5 && <0.8, - cryptonite >=0.25 && <0.31, + crypton, deepseq, formatting >=6.3 && <7.3, measures, @@ -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}, diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs index 5fe214077a..bb8fe671dd 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs @@ -92,7 +92,7 @@ instance DSIGNAlgorithm ByronDSIGN where where seedBytes = case getBytesFromSeed 32 seed of Just (x,_) -> x - Nothing -> throw $ SeedBytesExhausted (-1) -- TODO We can't get the seed size! + Nothing -> throw $ SeedBytesExhausted (-1) (-1) -- TODO We can't get the seed size! deriveVerKeyDSIGN (SignKeyByronDSIGN sk) = VerKeyByronDSIGN $ toVerification sk diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 9fb24f382d..76082e4c4e 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index e4297052e7..79781e124d 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -92,10 +92,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 +102,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 @@ -480,7 +478,7 @@ protocolInfoCardano paramsCardano pInfoConfig = cfg , pInfoInitLedger = initExtLedgerStateCardano } - , blockForging + , mkBlockForgings ) where CardanoProtocolParams { @@ -827,8 +825,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 +852,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.mkHotKey + ocert + sk + startPeriod + maxKESEvo + let tpraos :: forall era. ShelleyEraWithCrypto c (TPraos c) era => BlockForging m (ShelleyBlock (TPraos c) era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs index 572ed23a4e..9683f3a0be 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs @@ -48,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 :: SL.SignKeyKES c, - shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c, + { shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c, -- | Identifier for this set of credentials. -- -- Useful when the node is running with multiple sets of credentials. diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index 35fcbaf0ba..626d016858 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/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 } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 82e5698885..a1334ef0f2 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 0b2045dd7c..c6f81b9aa0 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs index 6322d3aa3d..559035aebc 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs index 153f0a3cd5..e852db11aa 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs @@ -14,7 +14,7 @@ -- module Cardano.Api.KeysPraos ( -- * Key types - KesKey + UnsoundPureKesKey , VrfKey -- * Data family instances , AsType (..) @@ -31,7 +31,7 @@ import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.KES.Class as Crypto import qualified Cardano.Crypto.VRF.Class as Crypto -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (Crypto(..), StandardCrypto) import qualified Cardano.Ledger.Crypto as Shelley (KES, VRF) import qualified Cardano.Ledger.Keys as Shelley import Data.String (IsString (..)) @@ -40,95 +40,95 @@ import Data.String (IsString (..)) -- KES keys -- -data KesKey +data UnsoundPureKesKey -instance HasTypeProxy KesKey where - data AsType KesKey = AsKesKey - proxyToAsType _ = AsKesKey +instance HasTypeProxy UnsoundPureKesKey where + data AsType UnsoundPureKesKey = AsUnsoundPureKesKey + proxyToAsType _ = AsUnsoundPureKesKey -instance Key KesKey where +instance Key UnsoundPureKesKey where - newtype VerificationKey KesKey = + newtype VerificationKey UnsoundPureKesKey = KesVerificationKey (Shelley.VerKeyKES StandardCrypto) deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey KesKey) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey UnsoundPureKesKey) deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) deriving anyclass SerialiseAsCBOR - newtype SigningKey KesKey = - KesSigningKey (Shelley.SignKeyKES StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey KesKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR + newtype SigningKey UnsoundPureKesKey = + KesSigningKey (Crypto.UnsoundPureSignKeyKES (KES StandardCrypto)) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey UnsoundPureKesKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (EncCBOR, DecCBOR, SerialiseAsCBOR) --This loses the mlock safety of the seed, since it starts from a normal in-memory seed. - deterministicSigningKey :: AsType KesKey -> Crypto.Seed -> SigningKey KesKey - deterministicSigningKey AsKesKey = - KesSigningKey . Crypto.genKeyKES + deterministicSigningKey :: AsType UnsoundPureKesKey -> Crypto.Seed -> SigningKey UnsoundPureKesKey + deterministicSigningKey AsUnsoundPureKesKey = + KesSigningKey . Crypto.unsoundPureGenKeyKES - deterministicSigningKeySeedSize :: AsType KesKey -> Word - deterministicSigningKeySeedSize AsKesKey = + deterministicSigningKeySeedSize :: AsType UnsoundPureKesKey -> Word + deterministicSigningKeySeedSize AsUnsoundPureKesKey = Crypto.seedSizeKES proxy where proxy :: Proxy (Shelley.KES StandardCrypto) proxy = Proxy - getVerificationKey :: SigningKey KesKey -> VerificationKey KesKey + getVerificationKey :: SigningKey UnsoundPureKesKey -> VerificationKey UnsoundPureKesKey getVerificationKey (KesSigningKey sk) = - KesVerificationKey (Crypto.deriveVerKeyKES sk) + KesVerificationKey (Crypto.unsoundPureDeriveVerKeyKES sk) - verificationKeyHash :: VerificationKey KesKey -> Hash KesKey + verificationKeyHash :: VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey verificationKeyHash (KesVerificationKey vkey) = - KesKeyHash (Crypto.hashVerKeyKES vkey) + UnsoundPureKesKeyHash (Crypto.hashVerKeyKES vkey) -instance SerialiseAsRawBytes (VerificationKey KesKey) where +instance SerialiseAsRawBytes (VerificationKey UnsoundPureKesKey) where serialiseToRawBytes (KesVerificationKey vk) = Crypto.rawSerialiseVerKeyKES vk - deserialiseFromRawBytes (AsVerificationKey AsKesKey) bs = + deserialiseFromRawBytes (AsVerificationKey AsUnsoundPureKesKey) bs = KesVerificationKey <$> Crypto.rawDeserialiseVerKeyKES bs -instance SerialiseAsRawBytes (SigningKey KesKey) where +instance SerialiseAsRawBytes (SigningKey UnsoundPureKesKey) where serialiseToRawBytes (KesSigningKey sk) = - Crypto.rawSerialiseSignKeyKES sk + Crypto.rawSerialiseUnsoundPureSignKeyKES sk - deserialiseFromRawBytes (AsSigningKey AsKesKey) bs = - KesSigningKey <$> Crypto.rawDeserialiseSignKeyKES bs + deserialiseFromRawBytes (AsSigningKey AsUnsoundPureKesKey) bs = + KesSigningKey <$> Crypto.rawDeserialiseUnsoundPureSignKeyKES bs -instance SerialiseAsBech32 (VerificationKey KesKey) where +instance SerialiseAsBech32 (VerificationKey UnsoundPureKesKey) where bech32PrefixFor _ = "kes_vk" bech32PrefixesPermitted _ = ["kes_vk"] -instance SerialiseAsBech32 (SigningKey KesKey) where +instance SerialiseAsBech32 (SigningKey UnsoundPureKesKey) where bech32PrefixFor _ = "kes_sk" bech32PrefixesPermitted _ = ["kes_sk"] -newtype instance Hash KesKey = - KesKeyHash (Shelley.Hash StandardCrypto +newtype instance Hash UnsoundPureKesKey = + UnsoundPureKesKeyHash (Shelley.Hash StandardCrypto (Shelley.VerKeyKES StandardCrypto)) deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash KesKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash KesKey) + deriving (Show, IsString) via UsingRawBytesHex (Hash UnsoundPureKesKey) + deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash UnsoundPureKesKey) deriving anyclass SerialiseAsCBOR -instance SerialiseAsRawBytes (Hash KesKey) where - serialiseToRawBytes (KesKeyHash vkh) = +instance SerialiseAsRawBytes (Hash UnsoundPureKesKey) where + serialiseToRawBytes (UnsoundPureKesKeyHash vkh) = Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsKesKey) bs = - KesKeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsUnsoundPureKesKey) bs = + UnsoundPureKesKeyHash <$> Crypto.hashFromBytes bs -instance HasTextEnvelope (VerificationKey KesKey) where +instance HasTextEnvelope (VerificationKey UnsoundPureKesKey) where textEnvelopeType _ = "KesVerificationKey_" <> fromString (Crypto.algorithmNameKES proxy) where proxy :: Proxy (Shelley.KES StandardCrypto) proxy = Proxy -instance HasTextEnvelope (SigningKey KesKey) where +instance HasTextEnvelope (SigningKey UnsoundPureKesKey) where textEnvelopeType _ = "KesSigningKey_" <> fromString (Crypto.algorithmNameKES proxy) where diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs index 9570a3175b..be6f1c9222 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs @@ -94,7 +94,7 @@ instance HasTypeProxy OperationalCertificateIssueCounter where instance HasTextEnvelope OperationalCertificate where textEnvelopeType _ = "NodeOperationalCertificate" -getHotKey :: OperationalCertificate -> VerificationKey KesKey +getHotKey :: OperationalCertificate -> VerificationKey UnsoundPureKesKey getHotKey (OperationalCertificate cert _) = KesVerificationKey $ Shelley.ocertVkHot cert getKesPeriod :: OperationalCertificate -> Word diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs index fd58263650..743517cba9 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs @@ -45,7 +45,7 @@ import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.Protocol.Praos.Common - (PraosCanBeLeader (..)) + (PraosCanBeLeader (..), PraosCredentialsSource (..)) import Ouroboros.Consensus.Shelley.Node (Nonce (..), ProtocolParamsShelleyBased (..), ShelleyGenesis (..), ShelleyLeaderCredentials (..)) @@ -170,12 +170,12 @@ opCertKesKeyCheck :: -- ^ KES key -> FilePath -- ^ Operational certificate - -> ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey KesKey) + -> ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey UnsoundPureKesKey) opCertKesKeyCheck kesFile certFile = do opCert <- firstExceptT FileError (newExceptT $ readFileTextEnvelope AsOperationalCertificate certFile) kesSKey <- - firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsKesKey) kesFile) + firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsUnsoundPureKesKey) kesFile) let opCertSpecifiedKesKeyhash = verificationKeyHash $ getHotKey opCert suppliedKesKeyHash = verificationKeyHash $ getVerificationKey kesSKey -- Specified KES key in operational certificate should match the one @@ -200,11 +200,11 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = parseShelleyCredentials :: ShelleyCredentials -> ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto) - parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = do + parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = mkPraosLeaderCredentials - <$> parseEnvelope AsOperationalCertificate scCert - <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf - <*> parseEnvelope (AsSigningKey AsKesKey) scKes + <$> parseEnvelope AsOperationalCertificate scCert + <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf + <*> parseEnvelope (AsSigningKey AsUnsoundPureKesKey) scKes readBulkFile :: Maybe FilePath @@ -228,7 +228,7 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = mkPraosLeaderCredentials :: OperationalCertificate -> SigningKey VrfKey - -> SigningKey KesKey + -> SigningKey UnsoundPureKesKey -> ShelleyLeaderCredentials StandardCrypto mkPraosLeaderCredentials (OperationalCertificate opcert (StakePoolVerificationKey vkey)) @@ -237,11 +237,10 @@ mkPraosLeaderCredentials ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { - praosCanBeLeaderOpCert = opcert, praosCanBeLeaderColdVerKey = coerceKeyRole vkey, - praosCanBeLeaderSignKeyVRF = vrfKey + praosCanBeLeaderSignKeyVRF = vrfKey, + praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound opcert kesKey }, - shelleyLeaderCredentialsInitSignKey = kesKey, shelleyLeaderCredentialsLabel = "Shelley" } diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index cc88fbd694..1a7e18addd 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -23,6 +23,7 @@ import Data.Aeson as Aeson (FromJSON, Result (..), Value, import Data.Bool (bool) import Data.ByteString as BS (ByteString, readFile) import qualified Data.Set as Set +import qualified Ouroboros.Consensus.Block.Forging as BlockForging import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.Config (TopLevelConfig, configStorage) @@ -134,7 +135,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir (Node.stdMkChainDbHasFS confDbDir) $ ChainDB.defaultArgs - forgers <- blockForging + (_, forgers) <- allocate registry (const $ mkForgers) (mapM_ BlockForging.finalize) let fCount = length forgers putStrLn $ "--> forger count: " ++ show fCount if fCount > 0 @@ -163,9 +164,10 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir { pInfoConfig , pInfoInitLedger } - , blockForging + , mkForgers ) = protocolInfoCardano runP + preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () preOpenChainDB mode db = doesDirectoryExist db >>= bool create checkMode diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index b67594b964..14ad1969fc 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs @@ -37,7 +37,9 @@ module Test.ThreadNet.Infra.Shelley ( import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), seedSizeDSIGN) import Cardano.Crypto.Hash (HashAlgorithm) -import Cardano.Crypto.KES (KESAlgorithm (..)) +import Cardano.Crypto.KES (UnsoundPureSignKeyKES, KESAlgorithm (..), + UnsoundPureKESAlgorithm (..), + seedSizeKES, unsoundPureGenKeyKES, unsoundPureDeriveVerKeyKES) import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Cardano.Crypto.Seed as Cardano.Crypto import Cardano.Crypto.VRF (SignKeyVRF, deriveVerKeyVRF, genKeyVRF, @@ -78,8 +80,10 @@ import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (PraosCanBeLeader), - praosCanBeLeaderColdVerKey, praosCanBeLeaderOpCert, - praosCanBeLeaderSignKeyVRF) + praosCanBeLeaderColdVerKey, + praosCanBeLeaderSignKeyVRF, + praosCanBeLeaderCredentialsSource, + PraosCredentialsSource (..)) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyEra) import Ouroboros.Consensus.Shelley.Ledger (GenTx (..), @@ -138,7 +142,7 @@ data CoreNode c = CoreNode { -- ^ The hash of the corresponding verification (public) key will be -- used as the staking credential. , cnVRF :: !(SL.SignKeyVRF c) - , cnKES :: !(SL.SignKeyKES c) + , cnKES :: !(UnsoundPureSignKeyKES (KES c)) , cnOCert :: !(SL.OCert c) } @@ -180,8 +184,8 @@ genCoreNode startKESPeriod = do delKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN c))) stkKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN c))) vrfKey <- genKeyVRF <$> genSeed (seedSizeVRF (Proxy @(VRF c))) - kesKey <- genKeyKES <$> genSeed (seedSizeKES (Proxy @(KES c))) - let kesPub = deriveVerKeyKES kesKey + kesKey <- unsoundPureGenKeyKES <$> genSeed (seedSizeKES (Proxy @(KES c))) + let kesPub = unsoundPureDeriveVerKeyKES kesKey sigma = LK.signedDSIGN @c delKey @@ -212,9 +216,8 @@ genCoreNode startKESPeriod = do mkLeaderCredentials :: PraosCrypto c => CoreNode c -> ShelleyLeaderCredentials c mkLeaderCredentials CoreNode { cnDelegateKey, cnVRF, cnKES, cnOCert } = ShelleyLeaderCredentials { - shelleyLeaderCredentialsInitSignKey = cnKES - , shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { - praosCanBeLeaderOpCert = cnOCert + shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { + praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound cnOCert cnKES , praosCanBeLeaderColdVerKey = SL.VKey $ deriveVerKeyDSIGN cnDelegateKey , praosCanBeLeaderSignKeyVRF = cnVRF } @@ -421,6 +424,7 @@ mkProtocolShelley genesis initialNonce protVer coreNode = , shelleyBasedLeaderCredentials = [mkLeaderCredentials coreNode] } protVer + {------------------------------------------------------------------------------- Necessary transactions for updating the 'DecentralizationParam' -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-diffusion/changelog.d/20250130_100651_tdammers_mlocked_kes_rebase.md b/ouroboros-consensus-diffusion/changelog.d/20250130_100651_tdammers_mlocked_kes_rebase.md new file mode 100644 index 0000000000..a400a1577f --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20250130_100651_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,3 @@ +### Non-Breaking + +- Use registry to ensure block forging threads are finalized in node kernel. diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index c246d94044..e294051774 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -174,8 +174,8 @@ library unstable-mock-testlib QuickCheck, base, bytestring, - cardano-crypto-class, - cardano-crypto-tests, + cardano-crypto-class ^>= 2.2, + cardano-crypto-tests ^>= 2.2, containers, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib, unstable-mock-block}, ouroboros-network-protocols:testlib, @@ -281,7 +281,7 @@ test-suite consensus-test base, binary, bytestring, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-slotting:{cardano-slotting, testlib}, cardano-strict-containers, containers, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 4d645bdd54..027ef8e318 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -435,10 +435,13 @@ forkBlockForging :: -> BlockForging m blk -> m (Thread m Void) forkBlockForging IS{..} blockForging = - forkLinkedWatcher registry threadLabel - $ knownSlotWatcher btime - $ withEarlyExit_ . go + forkLinkedWatcherFinalize registry threadLabel + watcher + (finalize blockForging) where + watcher :: Watcher m SlotNo SlotNo + watcher = knownSlotWatcher btime $ withEarlyExit_ . go + threadLabel :: String threadLabel = "NodeKernel.blockForging." <> Text.unpack (forgeLabel blockForging) diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index d7dd9e75cc..0e39141e9b 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -63,6 +63,7 @@ import Network.TypedProtocol.Codec (AnyMessage (..), CodecFailure, mapFailureCodec) import qualified Network.TypedProtocol.Codec as Codec import Ouroboros.Consensus.Block +import qualified Ouroboros.Consensus.Block.Forging as BlockForging import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract @@ -802,7 +803,7 @@ runThreadNetwork systemTime ThreadNetworkArgs -> m ( NodeKernel m NodeId Void blk , LimitedApp m NodeId blk ) - forkNode coreNodeId clock joinSlot registry pInfo blockForging nodeInfo txs0 = do + forkNode coreNodeId clock joinSlot registry pInfo mkBlockForging nodeInfo txs0 = do let ProtocolInfo{..} = pInfo let NodeInfo @@ -1042,9 +1043,9 @@ runThreadNetwork systemTime ThreadNetworkArgs nodeKernel <- initNodeKernel nodeKernelArgs - blockForging' <- - map (\bf -> bf { forgeBlock = customForgeBlock bf }) - <$> blockForging + (_, blockForging) <- allocate registry (const mkBlockForging) (mapM_ BlockForging.finalize) + let blockForging' = + map (\bf -> bf { forgeBlock = customForgeBlock bf }) blockForging setBlockForging nodeKernel blockForging' let mempool = getMempool nodeKernel diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 4aa3b65074..6155b3fcb5 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -292,6 +292,7 @@ blockForgingA = BlockForging { , checkCanForge = \_ _ _ _ _ -> return () , forgeBlock = \cfg bno slot st txs proof -> return $ forgeBlockA cfg bno slot st (fmap txForgetValidated txs) proof + , finalize = return () } -- | See 'Ouroboros.Consensus.HardFork.History.EraParams.safeFromTip' diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 7c45c64137..e58145554a 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -240,6 +240,7 @@ blockForgingB = BlockForging { , checkCanForge = \_ _ _ _ _ -> return () , forgeBlock = \cfg bno slot st txs proof -> return $ forgeBlockB cfg bno slot st (fmap txForgetValidated txs) proof + , finalize = return () } -- | A basic 'History.SafeZone' diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs index d65cddcc3a..35b3883722 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs @@ -49,7 +49,7 @@ data TestSetup = TestSetup genEvolvingStake :: EpochSize -> TestConfig -> Gen PraosEvolvingStake genEvolvingStake epochSize TestConfig {numSlots, numCoreNodes} = do - chosenEpochs <- sublistOf [0..EpochNo $ max 1 maxEpochs - 1] + chosenEpochs <- sublistOf [EpochNo 0..EpochNo $ max 1 maxEpochs - 1] let l = fromIntegral maxEpochs stakeDists <- replicateM l genStakeDist return . PraosEvolvingStake . Map.fromList $ zip chosenEpochs stakeDists diff --git a/ouroboros-consensus-protocol/changelog.d/20250130_101128_tdammers_mlocked_kes_rebase.md b/ouroboros-consensus-protocol/changelog.d/20250130_101128_tdammers_mlocked_kes_rebase.md new file mode 100644 index 0000000000..804067168e --- /dev/null +++ b/ouroboros-consensus-protocol/changelog.d/20250130_101128_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 `PraosCanBeLeader` to not contain the KES sign key itself anymore. + Instead, it now contains a `PraosCredentialsSource` field, which + specifies how to obtain the actual credentials (OpCert and KES SignKey). For + now, the only supported method is passing an OpCert and an + UnsoundPureSignKeyKES, presumably loaded from disk + (`PraosCredentialsUnsound`); future iterations will add support for + connecting to a KES agent. diff --git a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal index 9725c76e0b..740f31e895 100644 --- a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal +++ b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal @@ -66,7 +66,7 @@ library base >=4.14 && <4.21, bytestring, cardano-binary, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-ledger-binary, cardano-ledger-core, cardano-ledger-shelley, @@ -74,6 +74,7 @@ library cardano-slotting, cborg, containers, + io-classes >=1.5.0, mtl, nothunks, ouroboros-consensus ^>=0.22, @@ -94,9 +95,9 @@ library unstable-protocol-testlib base, base16-bytestring, bytestring, - cardano-crypto-class, - cardano-crypto-praos, - cardano-crypto-tests, + cardano-crypto-class ^>= 2.2, + cardano-crypto-praos ^>= 2.2, + cardano-crypto-tests ^>= 2.2, cardano-ledger-binary, cardano-ledger-core, cardano-ledger-shelley-test, @@ -117,9 +118,9 @@ test-suite protocol-test build-depends: QuickCheck, base, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-ledger-binary:testlib, - cardano-ledger-core ^>=1.16, + cardano-ledger-core ^>=1.17, containers, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, ouroboros-consensus-protocol, diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs index 8a46088450..a419d9b74c 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs @@ -1,9 +1,13 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Hot key -- @@ -18,21 +22,26 @@ module Ouroboros.Consensus.Protocol.Ledger.HotKey ( , kesStatus -- * Hot Key , HotKey (..) + , getOCert , KESEvolutionError (..) , KESEvolutionInfo , mkHotKey + , mkHotKeyEv + , mkEmptyHotKey , sign ) where import qualified Cardano.Crypto.KES as Relative (Period) -import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Crypto (Crypto (..)) import qualified Cardano.Ledger.Keys as SL +import qualified Cardano.Protocol.TPraos.OCert as OCert import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block.Forging (UpdateInfo (..)) import Ouroboros.Consensus.Util.IOLike +import NoThunks.Class (OnlyCheckWhnfNamed (..)) {------------------------------------------------------------------------------- KES Info @@ -126,19 +135,58 @@ data HotKey c m = HotKey { -- -- When the key cannot evolve anymore, we poison it. evolve :: Absolute.KESPeriod -> m KESEvolutionInfo + -- | Return 'KESInfo' of the signing key. , getInfo :: m KESInfo - -- | Return 'True' when the signing key is poisoned because it expired. + + -- | Return the 'OCert' corresponding to the KES signing key, if any. + , getOCertMaybe :: m (Maybe (OCert.OCert c)) + + -- | Check whether a valid KES signing key exists. "Poisoned" means no + -- key exists; reasons for this could be: + -- - no signing key has been set yet + -- - the signing key has been explicitly erased ('forget') + -- - the signing key has been evolved past the end of the available + -- evolutions , isPoisoned :: m Bool + -- | Sign the given @toSign@ with the current signing key. -- -- PRECONDITION: the key is not poisoned. -- -- POSTCONDITION: the signature is in normal form. , sign_ :: forall toSign. (SL.KESignable c toSign, HasCallStack) - => toSign -> m (SL.SignedKES c toSign) + => toSign + -> m (SL.SignedKES c toSign) + + -- | Securely erase the key and release its memory. + , forget :: m () + + -- | Set a new sign key. + , set :: OCert.OCert c + -- ^ The new OCert + -> SL.SignKeyKES c + -- ^ The new KES key + -> Word + -- ^ The new KES key's current evolution + -> Absolute.KESPeriod + -- ^ Start period (relative to the KES key's 0th evolution) + -> m () + + -- | Release any resources held by the 'HotKey'. Must be run exactly once + -- per 'HotKey'. + , finalize :: m () } +deriving via (OnlyCheckWhnfNamed "HotKey" (HotKey c m)) instance NoThunks (HotKey c m) + +getOCert :: Monad m => HotKey c m -> m (OCert.OCert c) +getOCert hotKey = do + ocertMay <- getOCertMaybe hotKey + case ocertMay of + Just ocert -> return ocert + Nothing -> error "trying to read OpCert for poisoned key" + sign :: (SL.KESignable c toSign, HasCallStack) => HotKey c m @@ -148,7 +196,7 @@ sign = sign_ -- | The actual KES key, unless it expired, in which case it is replaced by -- \"poison\". data KESKey c = - KESKey !(SL.SignKeyKES c) + KESKey !(OCert.OCert c) !(SL.SignKeyKES c) | KESKeyPoisoned deriving (Generic) @@ -156,7 +204,7 @@ instance Crypto c => NoThunks (KESKey c) kesKeyIsPoisoned :: KESKey c -> Bool kesKeyIsPoisoned KESKeyPoisoned = True -kesKeyIsPoisoned (KESKey _) = False +kesKeyIsPoisoned (KESKey _ _) = False data KESState c = KESState { kesStateInfo :: !KESInfo @@ -166,42 +214,99 @@ data KESState c = KESState { instance Crypto c => NoThunks (KESState c) +-- Create a new 'HotKey' and initialize it to the given initial KES key. The +-- initial key must be at evolution 0 (i.e., freshly generated and never +-- evolved). mkHotKey :: forall m c. (Crypto c, IOLike m) - => SL.SignKeyKES c + => OCert.OCert c + -> SL.SignKeyKES c -> Absolute.KESPeriod -- ^ Start period -> Word64 -- ^ Max KES evolutions -> m (HotKey c m) -mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do +mkHotKey ocert initKey startPeriod maxKESEvolutions = do + hotKey <- mkEmptyHotKey maxKESEvolutions (pure ()) + set hotKey ocert initKey 0 startPeriod + return hotKey + +-- Create a new 'HotKey' and initialize it to the given initial KES key. The +-- initial key should be at the given evolution. +mkHotKeyEv :: + forall m c. (Crypto c, IOLike m) + => Word + -> OCert.OCert c + -> SL.SignKeyKES c + -> Absolute.KESPeriod -- ^ Start period + -> Word64 -- ^ Max KES evolutions + -> m (HotKey c m) +mkHotKeyEv evolution ocert initKey startPeriod maxKESEvolutions = do + hotKey <- mkEmptyHotKey maxKESEvolutions (pure ()) + set hotKey ocert initKey evolution startPeriod + return hotKey + +-- | Create a new 'HotKey' and initialize it to a poisoned state (containing no +-- valid KES sign key). +mkEmptyHotKey :: + forall m c. (Crypto c, IOLike m) + => Word64 -- ^ Max KES evolutions + -> m () + -> m (HotKey c m) +mkEmptyHotKey maxKESEvolutions finalizer = do varKESState <- newMVar initKESState + return HotKey { evolve = evolveKey varKESState , getInfo = kesStateInfo <$> readMVar varKESState + , getOCertMaybe = kesStateKey <$> readMVar varKESState >>= \case + KESKeyPoisoned -> return Nothing + KESKey ocert _ -> return (Just ocert) + , isPoisoned = kesKeyIsPoisoned . kesStateKey <$> readMVar varKESState , sign_ = \toSign -> do - KESState { kesStateInfo, kesStateKey } <- readMVar varKESState - case kesStateKey of - KESKeyPoisoned -> error "trying to sign with a poisoned key" - KESKey key -> do - let evolution = kesEvolution kesStateInfo - signed = SL.signedKES () evolution toSign key - -- Force the signature to WHNF (for 'SignedKES', WHNF implies - -- NF) so that we don't have any thunks holding on to a key that - -- might be destructively updated when evolved. - evaluate signed + withMVar varKESState $ \KESState { kesStateInfo, kesStateKey } -> do + case kesStateKey of + KESKeyPoisoned -> + error "trying to sign with a poisoned key" + KESKey _ key -> do + let evolution = kesEvolution kesStateInfo + SL.signedKES () evolution toSign key + , forget = do + modifyMVar_ varKESState $ poisonState + , set = \newOCert newKey evolution startPeriod@(Absolute.KESPeriod start) -> do + modifyMVar_ varKESState $ \oldState -> do + _ <- poisonState oldState + return $ KESState { + kesStateInfo = KESInfo { + kesStartPeriod = startPeriod + , kesEndPeriod = Absolute.KESPeriod (start + fromIntegral maxKESEvolutions) + , kesEvolution = evolution + } + , kesStateKey = KESKey newOCert newKey + } + , finalize = finalizer } where initKESState :: KESState c initKESState = KESState { kesStateInfo = KESInfo { - kesStartPeriod = startPeriod - , kesEndPeriod = Absolute.KESPeriod (start + fromIntegral maxKESEvolutions) - -- We always start from 0 as the key hasn't evolved yet. + kesStartPeriod = Absolute.KESPeriod 0 + , kesEndPeriod = Absolute.KESPeriod 0 , kesEvolution = 0 } - , kesStateKey = KESKey initKey + , kesStateKey = KESKeyPoisoned } +poisonState :: forall m c. (Crypto c, IOLike m) + => KESState c -> m (KESState c) +poisonState kesState = do + case kesStateKey kesState of + KESKeyPoisoned -> do + -- already poisoned + return kesState + KESKey _ sk -> do + forgetSignKeyKES sk + return kesState { kesStateKey = KESKeyPoisoned } + -- | Evolve the 'HotKey' so that its evolution matches the given KES period. -- -- When the given KES period is after the end period of the 'HotKey', we @@ -230,7 +335,7 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do let err = KESKeyAlreadyPoisoned info targetPeriod in return (kesState, UpdateFailed err) - KESKey key -> case kesStatus info targetPeriod of + KESKey ocert key -> case kesStatus info targetPeriod of -- When the absolute period is before the start period, we can't -- update the key. 'checkCanForge' will say we can't forge because the -- key is not valid yet. @@ -239,9 +344,10 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do -- When the absolute period is after the end period, we can't evolve -- anymore and poison the expired key. - AfterKESEnd {} -> + AfterKESEnd {} -> do let err = KESCouldNotEvolve info targetPeriod - in return (poisonState kesState, UpdateFailed err) + poisonedState <- poisonState kesState + return (poisonedState, UpdateFailed err) InKESRange targetEvolution -- No evolving needed @@ -251,27 +357,27 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do -- Evolving needed | otherwise -> (\s' -> (s', Updated (kesStateInfo s'))) <$> - go targetEvolution info key + go targetEvolution info ocert key where - poisonState :: KESState c -> KESState c - poisonState kesState = kesState { kesStateKey = KESKeyPoisoned } - -- | PRECONDITION: -- -- > targetEvolution >= curEvolution - go :: KESEvolution -> KESInfo -> SL.SignKeyKES c -> m (KESState c) - go targetEvolution info key + go :: KESEvolution -> KESInfo -> OCert.OCert c -> SL.SignKeyKES c -> m (KESState c) + go targetEvolution info ocert key | targetEvolution <= curEvolution - = return $ KESState { kesStateInfo = info, kesStateKey = KESKey key } + = return $ KESState { kesStateInfo = info, kesStateKey = KESKey ocert key } | otherwise - = case SL.updateKES () key curEvolution of - -- This cannot happen - Nothing -> error "Could not update KES key" - Just !key' -> do - -- Clear the memory associated with the old key - forgetSignKeyKES key - let info' = info { kesEvolution = curEvolution + 1 } - go targetEvolution info' key' + = do + maybeKey' <- SL.updateKES () key curEvolution + case maybeKey' of + Nothing -> + -- This cannot happen + error "Could not update KES key" + Just !key' -> do + -- Clear the memory associated with the old key + forgetSignKeyKES key + let info' = info { kesEvolution = curEvolution + 1 } + go targetEvolution info' ocert key' where curEvolution = kesEvolution info diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index ce8bcdb08e..08c8f2b555 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -160,27 +160,25 @@ forgePraosFields hotKey PraosCanBeLeader { praosCanBeLeaderColdVerKey, - praosCanBeLeaderSignKeyVRF, - praosCanBeLeaderOpCert + praosCanBeLeaderSignKeyVRF } PraosIsLeader {praosIsLeaderVrfRes} mkToSign = do + ocert <- HotKey.getOCert hotKey + let signedFields = + PraosToSign + { praosToSignIssuerVK = praosCanBeLeaderColdVerKey, + praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF, + praosToSignVrfRes = praosIsLeaderVrfRes, + praosToSignOCert = ocert + } + toSign = mkToSign signedFields signature <- HotKey.sign hotKey toSign return PraosFields { praosSignature = signature, praosToSign = toSign } - where - toSign = mkToSign signedFields - - signedFields = - PraosToSign - { praosToSignIssuerVK = praosCanBeLeaderColdVerKey, - praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF, - praosToSignVrfRes = praosIsLeaderVrfRes, - praosToSignOCert = praosCanBeLeaderOpCert - } {------------------------------------------------------------------------------- Protocol proper diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 94241bc6c1..ae8137dfa1 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -15,17 +16,22 @@ module Ouroboros.Consensus.Protocol.Praos.Common ( -- * node support , PraosNonces (..) , PraosProtocolSupportsNode (..) + , PraosCredentialsSource (..) + , instantiatePraosCredentials ) where import qualified Cardano.Crypto.VRF as VRF -import Cardano.Ledger.BaseTypes (Nonce) import qualified Cardano.Ledger.BaseTypes as SL -import Cardano.Ledger.Crypto (Crypto, VRF) +import qualified Cardano.Crypto.KES.Class as KES +import Cardano.Ledger.BaseTypes (Nonce) +import Cardano.Ledger.Crypto (Crypto, VRF, KES) import Cardano.Ledger.Keys (KeyHash, KeyRole (BlockIssuer)) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Block (BlockNo) import Cardano.Slotting.Slot (SlotNo) +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadThrow) import Data.Function (on) import Data.Map.Strict (Map) import Data.Ord (Down (Down)) @@ -245,16 +251,30 @@ instance Crypto c => ChainOrder (PraosChainSelectView c) where preferCandidate cfg ours cand = comparePraos cfg ours cand == LT data PraosCanBeLeader c = PraosCanBeLeader - { -- | Certificate delegating rights from the stake pool cold key (or - -- genesis stakeholder delegate cold key) to the online KES key. - praosCanBeLeaderOpCert :: !(OCert.OCert c), - -- | Stake pool cold key or genesis stakeholder delegate cold key. + { -- | Stake pool cold key or genesis stakeholder delegate cold key. praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer c), - praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c) + praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c), + praosCanBeLeaderCredentialsSource :: !(PraosCredentialsSource c) } deriving (Generic) -instance Crypto c => NoThunks (PraosCanBeLeader c) +instance (NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) => NoThunks (PraosCanBeLeader c) + +data PraosCredentialsSource c + = PraosCredentialsUnsound (OCert.OCert c) (KES.UnsoundPureSignKeyKES (KES c)) + deriving (Generic) + +instance (NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) => NoThunks (PraosCredentialsSource c) + +instantiatePraosCredentials :: ( KES.UnsoundPureKESAlgorithm (KES c) + , MonadST m + , MonadThrow m + ) + => PraosCredentialsSource c + -> m (OCert.OCert c, SL.SignKeyKES c) +instantiatePraosCredentials (PraosCredentialsUnsound ocert skUnsound) = do + sk <- KES.unsoundPureSignKeyKESToSoundSignKeyKES skUnsound + return (ocert, sk) -- | See 'PraosProtocolSupportsNode' data PraosNonces = PraosNonces { diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs index 43529217bc..43d6026f5f 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs @@ -129,21 +129,21 @@ forgeTPraosFields :: -> (TPraosToSign c -> toSign) -> m (TPraosFields c toSign) forgeTPraosFields hotKey PraosCanBeLeader{..} TPraosIsLeader{..} mkToSign = do + ocert <- HotKey.getOCert hotKey + let signedFields = + TPraosToSign { + tpraosToSignIssuerVK = praosCanBeLeaderColdVerKey + , tpraosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF + , tpraosToSignEta = tpraosIsLeaderEta + , tpraosToSignLeader = tpraosIsLeaderProof + , tpraosToSignOCert = ocert + } + toSign = mkToSign signedFields signature <- HotKey.sign hotKey toSign return TPraosFields { tpraosSignature = signature , tpraosToSign = toSign } - where - toSign = mkToSign signedFields - - signedFields = TPraosToSign { - tpraosToSignIssuerVK = praosCanBeLeaderColdVerKey - , tpraosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF - , tpraosToSignEta = tpraosIsLeaderEta - , tpraosToSignLeader = tpraosIsLeaderProof - , tpraosToSignOCert = praosCanBeLeaderOpCert - } -- | Because we are using the executable spec, rather than implementing the -- protocol directly here, we have a fixed header type rather than an diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index 7686d00a04..4ed53ca1fc 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -6,8 +8,9 @@ -- to be semantically correct at all, only structurally correct. module Test.Consensus.Protocol.Serialisation.Generators () where -import Cardano.Crypto.KES (signedKES) +import Cardano.Crypto.KES (UnsoundPureKESAlgorithm, unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) +import Cardano.Ledger.Crypto (KES) import Cardano.Protocol.TPraos.BHeader (HashHeader, PrevHash (..)) import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod), OCert (OCert)) @@ -27,7 +30,7 @@ import Test.QuickCheck (Arbitrary (..), Gen, choose, oneof) instance Arbitrary InputVRF where arbitrary = mkInputVRF <$> arbitrary <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where +instance (Praos.PraosCrypto c, UnsoundPureKESAlgorithm (KES c)) => Arbitrary (HeaderBody c) where arbitrary = let ocert = OCert @@ -55,12 +58,12 @@ instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where <*> ocert <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (Header c) where +instance (Praos.PraosCrypto c, UnsoundPureKESAlgorithm (KES c)) => Arbitrary (Header c) where arbitrary = do hBody <- arbitrary period <- arbitrary sKey <- arbitrary - let hSig = signedKES () period hBody sKey + let hSig = unsoundPureSignedKES () period hBody sKey pure $ Header hBody hSig instance Praos.PraosCrypto c => Arbitrary (PraosState c) where diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index 09c9f65c6e..05ff3d27a6 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -27,8 +27,6 @@ import Cardano.Crypto.DSIGN import Cardano.Crypto.Hash (Blake2b_256, Hash, hashFromBytes, hashToBytes, hashWith) import qualified Cardano.Crypto.KES as KES -import Cardano.Crypto.KES.Class (genKeyKES, rawDeserialiseSignKeyKES, - rawSerialiseSignKeyKES) import Cardano.Crypto.Seed (mkSeedFromBytes) import Cardano.Crypto.VRF (deriveVerKeyVRF, hashVerKeyVRF, rawDeserialiseSignKeyVRF, rawSerialiseSignKeyVRF) @@ -115,14 +113,14 @@ mutate context header mutation = let Header body _ = header newKESSignKey <- newKESSigningKey <$> gen32Bytes KESPeriod kesPeriod <- genValidKESPeriod (hbSlotNo body) praosSlotsPerKESPeriod - let sig' = KES.signKES () kesPeriod body newKESSignKey + let sig' = KES.unsoundPureSignKES () kesPeriod body newKESSignKey pure (context, Header body (KES.SignedKES sig')) MutateColdKey -> do let Header body _ = header newColdSignKey <- genKeyDSIGN . mkSeedFromBytes <$> gen32Bytes (hbOCert, KESPeriod kesPeriod) <- genCert (hbSlotNo body) context{coldSignKey = newColdSignKey} let newBody = body{hbOCert} - let sig' = KES.signKES () kesPeriod newBody kesSignKey + let sig' = KES.unsoundPureSignKES () kesPeriod newBody kesSignKey pure (context, Header newBody (KES.SignedKES sig')) MutateKESPeriod -> do let Header body _ = header @@ -137,7 +135,7 @@ mutate context header mutation = , ocertSigma = signedDSIGN @StandardCrypto coldSignKey (OCertSignable ocertVkHot ocertN newKESPeriod) } } - let sig' = KES.signKES () kesPeriod' newBody kesSignKey + let sig' = KES.unsoundPureSignKES () kesPeriod' newBody kesSignKey pure (context, Header newBody (KES.SignedKES sig')) MutateKESPeriodBefore -> do let Header body _ = header @@ -147,7 +145,7 @@ mutate context header mutation = period' = unSlotNo newSlotNo `div` praosSlotsPerKESPeriod hbVrfRes = VRF.evalCertified () rho' vrfSignKey newBody = body{hbSlotNo = newSlotNo, hbVrfRes} - sig' = KES.signKES () (fromIntegral period' - kesPeriod) newBody kesSignKey + sig' = KES.unsoundPureSignKES () (fromIntegral period' - kesPeriod) newBody kesSignKey pure (context, Header newBody (KES.SignedKES sig')) MutateCounterOver1 -> do let poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey @@ -255,13 +253,13 @@ instance Json.FromJSON MutatedHeader where either (fail . show) pure $ decodeFullAnnotator @(Header StandardCrypto) testVersion "Header" decCBOR $ LBS.fromStrict headerBytes -- * Generators -type KESKey = KES.SignKeyKES (KES.Sum6KES Ed25519DSIGN Blake2b_256) +type KESKey = KES.UnsoundPureSignKeyKES (KES.Sum6KES Ed25519DSIGN Blake2b_256) newVRFSigningKey :: ByteString -> (VRF.SignKeyVRF VRF.PraosVRF, VRF.VerKeyVRF VRF.PraosVRF) newVRFSigningKey = VRF.genKeyPairVRF . mkSeedFromBytes newKESSigningKey :: ByteString -> KESKey -newKESSigningKey = genKeyKES . mkSeedFromBytes +newKESSigningKey = KES.unsoundPureGenKeyKES . mkSeedFromBytes data GeneratorContext = GeneratorContext { praosSlotsPerKESPeriod :: !Word64 @@ -279,7 +277,8 @@ instance Eq GeneratorContext where a == b = praosSlotsPerKESPeriod a == praosSlotsPerKESPeriod b && praosMaxKESEvo a == praosMaxKESEvo b - && serialize' testVersion (kesSignKey a) == serialize' testVersion (kesSignKey b) + && serialize' testVersion (KES.encodeUnsoundPureSignKeyKES (kesSignKey a)) == + serialize' testVersion (KES.encodeUnsoundPureSignKeyKES (kesSignKey b)) && coldSignKey a == coldSignKey b && vrfSignKey a == vrfSignKey b && nonce a == nonce b @@ -298,7 +297,7 @@ instance Json.ToJSON GeneratorContext where , "activeSlotCoeff" .= activeSlotVal activeSlotCoeff ] where - rawKesSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyKES kesSignKey + rawKesSignKey = decodeUtf8 . Base16.encode $ KES.rawSerialiseUnsoundPureSignKeyKES kesSignKey rawColdSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyDSIGN coldSignKey rawVrfSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyVRF $ skToBatchCompat vrfSignKey rawVrVKeyHash = decodeUtf8 . Base16.encode $ hashToBytes $ hashVerKeyVRF @_ @Blake2b_256 $ deriveVerKeyVRF vrfSignKey @@ -337,7 +336,7 @@ instance Json.FromJSON GeneratorContext where case Base16.decode (encodeUtf8 rawKey) of Left err -> fail err Right keyBytes -> - case rawDeserialiseSignKeyKES keyBytes of + case KES.rawDeserialiseUnsoundPureSignKeyKES keyBytes of Nothing -> fail $ "Invalid KES key bytes: " <> show rawKey Just key -> pure key parseVrfSignKey rawKey = do @@ -376,7 +375,7 @@ generated for the purpose of producing the header are returned. genHeader :: GeneratorContext -> Gen (Header StandardCrypto) genHeader context = do (body, KESPeriod kesPeriod) <- genHeaderBody context - let sign = KES.SignedKES $ KES.signKES () kesPeriod body kesSignKey + let sign = KES.SignedKES $ KES.unsoundPureSignKES () kesPeriod body kesSignKey pure $ (Header body sign) where GeneratorContext{kesSignKey} = context @@ -420,7 +419,7 @@ protocolVersionZero = ProtVer versionZero 0 genCert :: SlotNo -> GeneratorContext -> Gen (OCert StandardCrypto, KESPeriod) genCert slotNo context = do - let ocertVkHot = KES.deriveVerKeyKES kesSignKey + let ocertVkHot = KES.unsoundPureDeriveVerKeyKES kesSignKey poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey ocertN = fromMaybe 0 $ Map.lookup poolId ocertCounters ocertKESPeriod <- genValidKESPeriod slotNo praosSlotsPerKESPeriod diff --git a/ouroboros-consensus/changelog.d/20250130_093251_tdammers_mlocked_kes_rebase.md b/ouroboros-consensus/changelog.d/20250130_093251_tdammers_mlocked_kes_rebase.md new file mode 100644 index 0000000000..0aa430bf84 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250130_093251_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,8 @@ +### Breaking + +- Use new mlocked KES API to represent KES sign keys internally. This ensures + that KES keys are securely erased when replaced with a newer evolution or a + fresh key, and that they will not spill to disk or swap. See + https://github.com/IntersectMBO/cardano-base/pull/255. +- Add `finalize` method to `BlockForging`, and use it where necessary to clean + up when a block forging thread terminates (see `forkLinkedWatcherFinalize`) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 27552f9e20..06df42a0c0 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -278,7 +278,7 @@ library bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto-class, - cardano-ledger-core ^>=1.16, + cardano-ledger-core ^>=1.17, cardano-prelude, cardano-slotting, cardano-strict-containers, @@ -470,7 +470,7 @@ library unstable-mock-block bytestring, cardano-binary, cardano-crypto-class, - cardano-slotting:{cardano-slotting, testlib}, + cardano-slotting:{cardano-slotting}, cborg, containers, deepseq, @@ -542,8 +542,8 @@ test-suite consensus-test base, base-deriving-via, cardano-binary, - cardano-crypto-class, - cardano-crypto-tests, + cardano-crypto-class ^>= 2.2, + cardano-crypto-tests ^>= 2.2, cardano-slotting:{cardano-slotting, testlib}, cborg, containers, @@ -651,8 +651,8 @@ test-suite storage-test bifunctors, binary, bytestring, - cardano-crypto-class, - cardano-slotting:{cardano-slotting, testlib}, + cardano-crypto-class ^>= 2.2, + cardano-slotting:{cardano-slotting,testlib}, cborg, containers, contra-tracer, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs index 03e5682d93..3698b362ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs @@ -143,6 +143,15 @@ data BlockForging m blk = BlockForging { -> [Validated (GenTx blk)] -- Transactions to include -> IsLeader (BlockProtocol blk) -- Proof we are leader -> m blk + + -- | Clean up any unmanaged resources. + -- + -- Such resources may include KES keys that require explicit erasing + -- ("secure forgetting"), and threads that connect to a KES agent. + -- This method will be run once when the block forging thread + -- terminates, whether cleanly or due to an exception. + , finalize :: m () + } data ShouldForge blk = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index d182dbb22e..f09548067a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -417,6 +417,7 @@ instance Functor m => Isomorphic (BlockForging m) where project BlockForging {..} = BlockForging { forgeLabel = forgeLabel , canBeLeader = project' (Proxy @(WrapCanBeLeader blk)) canBeLeader + , finalize = finalize , updateForgeState = \cfg sno tickedChainDepSt -> project <$> updateForgeState @@ -464,6 +465,7 @@ instance Functor m => Isomorphic (BlockForging m) where inject BlockForging {..} = BlockForging { forgeLabel = forgeLabel , canBeLeader = inject' (Proxy @(WrapCanBeLeader blk)) canBeLeader + , finalize = finalize , updateForgeState = \cfg sno tickedChainDepSt -> inject <$> updateForgeState diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs index 5aab6219d9..6ba6aa7b3d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs @@ -15,8 +15,11 @@ module Ouroboros.Consensus.HardFork.Combinator.Forging ( , hardForkBlockForging ) where +import Control.Monad (void) import Data.Functor.Product import Data.Maybe (fromMaybe) +import Data.SOP (Top) +import Data.SOP.Constraint (All) import Data.SOP.BasicFunctors import Data.SOP.Functors (Product2 (..)) import Data.SOP.Index @@ -90,6 +93,7 @@ hardForkBlockForging label blockForging = , updateForgeState = hardForkUpdateForgeState blockForging , checkCanForge = hardForkCheckCanForge blockForging , forgeBlock = hardForkForgeBlock blockForging + , finalize = hardForkFinalize blockForging } hardForkCanBeLeader :: @@ -99,6 +103,11 @@ hardForkCanBeLeader = SomeErasCanBeLeader . hmap (WrapCanBeLeader . canBeLeader) +hardForkFinalize :: (Monad m, All Top xs) + => NonEmptyOptNP (BlockForging m) xs -> m () +hardForkFinalize blockForging = + void $ htraverse_ finalize blockForging + -- | POSTCONDITION: the returned 'ForgeStateUpdateInfo' is from the same era as -- the ticked 'ChainDepState'. hardForkUpdateForgeState :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 0ba537b87b..ea3bd3ecdb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -14,7 +14,7 @@ module Ouroboros.Consensus.Util.Orphans () where import Cardano.Crypto.DSIGN.Class import Cardano.Crypto.DSIGN.Mock (MockDSIGN) -import Cardano.Crypto.Hash (Hash) +import Cardano.Crypto.Hash (Hash, SizeHash) import Cardano.Ledger.Genesis (NoGenesis (..)) import Codec.CBOR.Decoding (Decoder) import Codec.Serialise (Serialise (..)) @@ -26,6 +26,7 @@ import qualified Data.IntPSQ as PSQ import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors +import GHC.TypeLits (KnownNat) import NoThunks.Class (InspectHeap (..), InspectHeapNamed (..), NoThunks (..), OnlyCheckWhnfNamed (..), allNoThunks, noThunksInKeysAndValues) @@ -38,7 +39,7 @@ import System.FS.CRC (CRC (CRC)) Serialise -------------------------------------------------------------------------------} -instance Serialise (Hash h a) where +instance KnownNat (SizeHash h) => Serialise (Hash h a) where instance Serialise (VerKeyDSIGN MockDSIGN) where encode = encodeVerKeyDSIGN diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs index 947ab3e927..4a38f06892 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -11,6 +11,7 @@ module Ouroboros.Consensus.Util.STM ( -- * 'Watcher' Watcher (..) , forkLinkedWatcher + , forkLinkedWatcherFinalize , withWatcher -- * Misc , Fingerprint (..) @@ -163,6 +164,19 @@ forkLinkedWatcher :: forall m a fp. (IOLike m, Eq fp, HasCallStack) forkLinkedWatcher registry label watcher = forkLinkedThread registry label $ runWatcher watcher +-- | Spawn a new thread that runs a 'Watcher', executing a finalizer when the +-- thread terminates. +-- +-- The thread will be linked to the registry. +forkLinkedWatcherFinalize :: forall m a fp. (IOLike m, Eq fp, HasCallStack) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> Watcher m a fp + -> m () + -> m (Thread m Void) +forkLinkedWatcherFinalize registry label watcher finalizer = + forkLinkedThread registry label $ runWatcher watcher `finally` finalizer + -- | Spawn a new thread that runs a 'Watcher' -- -- The thread is bracketed via 'withAsync' and 'link'ed. diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index f6db8e90cf..17933a9dcd 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -76,6 +77,7 @@ import Data.Proxy import Data.Typeable import Data.Word import GHC.Generics (Generic) +import GHC.TypeNats (KnownNat) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -162,6 +164,8 @@ instance (SimpleCrypto c, Typeable ext, Typeable ext') headerIsEBB = const Nothing +type KnownHashSize c = KnownNat (Hash.SizeHash (SimpleHash c)) + data SimpleStdHeader c ext = SimpleStdHeader { simplePrev :: ChainHash (SimpleBlock c ext) , simpleSlotNo :: SlotNo @@ -170,7 +174,10 @@ data SimpleStdHeader c ext = SimpleStdHeader { , simpleBodySize :: SizeInBytes } deriving stock (Generic, Show, Eq) - deriving anyclass (Serialise, NoThunks) + deriving anyclass (NoThunks) + +deriving anyclass instance KnownHashSize c => + Serialise (SimpleStdHeader c ext) data SimpleBody = SimpleBody { simpleTxs :: [Mock.Tx] @@ -367,7 +374,10 @@ newtype instance LedgerState (SimpleBlock c ext) = SimpleLedgerState { simpleLedgerState :: MockState (SimpleBlock c ext) } deriving stock (Generic, Show, Eq) - deriving newtype (Serialise, NoThunks) + deriving newtype (NoThunks) + +deriving anyclass instance KnownHashSize c => + Serialise (LedgerState (SimpleBlock c ext)) -- Ticking has no effect on the simple ledger state newtype instance Ticked (LedgerState (SimpleBlock c ext)) = TickedSimpleLedgerState { @@ -541,7 +551,7 @@ instance InspectLedger (SimpleBlock c ext) where Crypto needed for simple blocks -------------------------------------------------------------------------------} -class (HashAlgorithm (SimpleHash c), Typeable c) => SimpleCrypto c where +class (KnownHashSize c, HashAlgorithm (SimpleHash c), Typeable c) => SimpleCrypto c where type family SimpleHash c :: Type data SimpleStandardCrypto @@ -598,7 +608,8 @@ instance Condense ext' => Condense (SimpleBlock' c ext ext') where instance ToCBOR SimpleBody where toCBOR = encode -encodeSimpleHeader :: (ext' -> CBOR.Encoding) +encodeSimpleHeader :: KnownHashSize c + => (ext' -> CBOR.Encoding) -> Header (SimpleBlock' c ext ext') -> CBOR.Encoding encodeSimpleHeader encodeExt SimpleHeader{..} = mconcat [ diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs index dab988bc6d..317ce07382 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs @@ -102,6 +102,7 @@ simpleBlockForging aCanBeLeader aForgeExt = BlockForging { lst (map txForgetValidated txs) proof + , finalize = pure () } where _ = keepRedundantConstraint (Proxy @(ForgeStateUpdateError (SimpleBlock c ext) ~ Void)) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs index c2b22c8c40..96f58b752f 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs @@ -110,4 +110,5 @@ pbftBlockForging canBeLeader = BlockForging { lst (map txForgetValidated txs) proof + , finalize = pure () } diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs index 00d678da6d..5756154ad9 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs @@ -104,7 +104,7 @@ blockForgingPraos numCoreNodes nid = sequence [praosBlockForging nid initHotKey] initHotKey = HotKey 0 - (SignKeyMockKES + (UnsoundPureSignKeyMockKES -- key ID (fst $ verKeys Map.! nid) -- KES initial slot @@ -136,4 +136,5 @@ praosBlockForging cid initHotKey = do tickedLedgerSt (map txForgetValidated txs) isLeader + , finalize = pure () } diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs index 73407f75af..9a2c28d4fe 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs @@ -43,11 +43,12 @@ module Ouroboros.Consensus.Mock.Protocol.Praos ( ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..), serialize') -import Cardano.Crypto.DSIGN.Ed448 (Ed448DSIGN) +import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN) import Cardano.Crypto.Hash.Class (HashAlgorithm (..), hashToBytes, hashWithSerialiser, sizeHash) import Cardano.Crypto.Hash.SHA256 (SHA256) import Cardano.Crypto.KES.Class + import Cardano.Crypto.KES.Mock import Cardano.Crypto.KES.Simple import Cardano.Crypto.Util @@ -76,7 +77,6 @@ import Ouroboros.Consensus.NodeId (CoreNodeId (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Util.Condense -import Test.Cardano.Slotting.Numeric () -- The Praos paper can be located at https://ia.cr/2017/573 -- @@ -203,12 +203,15 @@ praosValidateView getFields hdr = data HotKey c = HotKey !Period -- ^ Absolute period of the KES key - !(SignKeyKES (PraosKES c)) + !(UnsoundPureSignKeyKES (PraosKES c)) | HotKeyPoisoned deriving (Generic) -instance PraosCrypto c => NoThunks (HotKey c) -deriving instance PraosCrypto c => Show (HotKey c) +instance (PraosCrypto c, NoThunks (UnsoundPureSignKeyKES (PraosKES c))) => NoThunks (HotKey c) + +instance PraosCrypto c => Show (HotKey c) where + show (HotKey p _) = "HotKey " ++ show p ++ "