diff --git a/cabal.project b/cabal.project index e2c18aa305..bb3734014a 100644 --- a/cabal.project +++ b/cabal.project @@ -14,9 +14,9 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2025-07-22T09:13:54Z + , hackage.haskell.org 2025-08-05T11:23:47Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2025-08-06T10:58:15Z + , cardano-haskell-packages 2025-08-21T00:00:00Z packages: ouroboros-consensus @@ -59,8 +59,8 @@ allow-newer: source-repository-package type: git location: https://github.com/IntersectMBO/cardano-ledger - tag: 640fb66d27ac202764de0dda76621c6d57852ba9 - --sha256: sha256-2vOUUvY19Emx5UpHNHZnIaWoqI5g3kPgjFQJGm9mVmk= + tag: 4edd7fd8b7101d24625c88d45c31f15e6345998e + --sha256: sha256-cJQIEmKeGDOkvNMm4Gmhp3l0Ikhpu/PQD9WqzSZWB68= subdir: eras/allegra/impl eras/alonzo/impl @@ -85,8 +85,3 @@ source-repository-package libs/set-algebra libs/small-steps libs/vector-map - -constraints: - plutus-core < 1.51, - plutus-ledger-api < 1.51, - plutus-tx < 1.51, diff --git a/flake.lock b/flake.lock index 282b5306b4..005913cac7 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1754478832, - "narHash": "sha256-iJ0g2vuGh2f9Y9USYdaZnhBK3zz4zAE0IKh3Li2HQSM=", + "lastModified": 1755770112, + "narHash": "sha256-BE9+swBBPBi9iRQNqsUNUjS02nyRF+OwfCkhIjted6I=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "71cbaa8ebe4514ea5292f48018b54a083768bea8", + "rev": "7af503772adf627cd23be5431440a0ffae74de52", "type": "github" }, "original": { 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..073423d539 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20250130_093803_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,8 @@ +### Breaking + +- Use new mlocked KES API for all internal KES sign key handling. +- Add finalizers to all block forgings (required by `ouroboros-consensus`). +- Change `ShelleyLeaderCredentials` to not contain the KES sign key itself + anymore. Instead, the `CanBeLeader` data structure now contains a + `praosCanBeLeaderCredentialsSource` field, which specifies how to obtain the + actual credentials (OpCert and KES SignKey). diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index e9a6eaa9c9..1d63a05f38 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -156,6 +156,7 @@ library cardano-strict-containers, cborg ^>=0.2.2, containers >=0.5 && <0.8, + contra-tracer, crypton, deepseq, formatting >=6.3 && <7.3, @@ -326,6 +327,8 @@ library unstable-shelley-testlib cardano-slotting, cardano-strict-containers, containers, + contra-tracer, + kes-agent, microlens, mtl, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, @@ -365,6 +368,7 @@ test-suite shelley-test cborg, constraints, containers, + contra-tracer, filepath, measures, microlens, @@ -416,6 +420,7 @@ library unstable-cardano-testlib cardano-strict-containers, cborg, containers, + contra-tracer, mempack, microlens, mtl, 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 f1080e2367..58b7587dc5 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -143,6 +143,7 @@ byronBlockForging creds = slot tickedPBftState , forgeBlock = \cfg -> return ....: forgeByronBlock cfg + , finalize = pure () } where canBeLeader = mkPBftCanBeLeader creds 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 0edeb83eb6..b185b5700b 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 @@ -55,14 +55,12 @@ import qualified Cardano.Ledger.Api.Transition as L import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Prelude (cborError) -import qualified Cardano.Protocol.TPraos.OCert as Absolute - ( KESPeriod (..) - , ocertKESPeriod - ) +import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR import Control.Exception (assert) +import qualified Control.Tracer as Tracer import qualified Data.ByteString.Short as Short import Data.Functor.These (These1 (..)) import qualified Data.Map.Strict as Map @@ -97,10 +95,11 @@ import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run -import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..)) +import Ouroboros.Consensus.Protocol.Praos.AgentClient import Ouroboros.Consensus.Protocol.Praos.Common - ( praosCanBeLeaderOpCert + ( PraosCanBeLeader (..) + , instantiatePraosCredentials ) import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..)) import qualified Ouroboros.Consensus.Protocol.TPraos as Shelley @@ -122,7 +121,6 @@ import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Assert -import Ouroboros.Consensus.Util.IOLike {------------------------------------------------------------------------------- SerialiseHFC @@ -569,10 +567,12 @@ data CardanoProtocolParams c = CardanoProtocolParams -- for mainnet (check against @'SL.gNetworkId' == 'SL.Mainnet'@). protocolInfoCardano :: forall c m. - (IOLike m, CardanoHardForkConstraints c) => + ( CardanoHardForkConstraints c + , KESAgentContext c m + ) => CardanoProtocolParams c -> ( ProtocolInfo (CardanoBlock c) - , m [BlockForging m (CardanoBlock c)] + , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (CardanoBlock c)] ) protocolInfoCardano paramsCardano | SL.Mainnet <- SL.sgNetworkId genesisShelley @@ -585,7 +585,7 @@ protocolInfoCardano paramsCardano { pInfoConfig = cfg , pInfoInitLedger = initExtLedgerStateCardano } - , blockForging + , mkBlockForgings ) where CardanoProtocolParams @@ -980,9 +980,9 @@ protocolInfoCardano paramsCardano -- credentials. If there are multiple Shelley credentials, we merge the -- Byron credentials with the first Shelley one but still have separate -- threads for the remaining Shelley ones. - blockForging :: m [BlockForging m (CardanoBlock c)] - blockForging = do - shelleyBased <- traverse blockForgingShelleyBased credssShelleyBased + mkBlockForgings :: Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (CardanoBlock c)] + mkBlockForgings tr = do + shelleyBased <- traverse (blockForgingShelleyBased tr) credssShelleyBased let blockForgings :: [NonEmptyOptNP (BlockForging m) (CardanoEras c)] blockForgings = case (mBlockForgingByron, shelleyBased) of (Nothing, shelleys) -> shelleys @@ -1004,22 +1004,11 @@ protocolInfoCardano paramsCardano return $ byronBlockForging creds `OptNP.at` IZ blockForgingShelleyBased :: + Tracer.Tracer m KESAgentClientTrace -> ShelleyLeaderCredentials c -> m (NonEmptyOptNP (BlockForging m) (CardanoEras c)) - blockForgingShelleyBased credentials = do - let ShelleyLeaderCredentials - { shelleyLeaderCredentialsInitSignKey = initSignKey - , shelleyLeaderCredentialsCanBeLeader = canBeLeader - } = credentials - - hotKey <- do - let maxKESEvo :: Word64 - maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo - - startPeriod :: Absolute.KESPeriod - startPeriod = Absolute.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader - - HotKey.mkHotKey @m @c initSignKey startPeriod maxKESEvo + blockForgingShelleyBased tr credentials = do + let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials let slotToPeriod :: SlotNo -> Absolute.KESPeriod slotToPeriod (SlotNo slot) = @@ -1028,6 +1017,15 @@ protocolInfoCardano paramsCardano fromIntegral $ slot `div` praosSlotsPerKESPeriod + maxKESEvo :: Word64 + maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo + + hotKey <- + instantiatePraosCredentials + maxKESEvo + tr + (praosCanBeLeaderCredentialsSource canBeLeader) + let tpraos :: forall era. ShelleyEraWithCrypto c (TPraos c) era => diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index 1118b3b86e..23a78ea1a6 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -18,9 +18,10 @@ module Ouroboros.Consensus.Shelley.HFEras , StandardShelleyBlock ) where +import Cardano.Protocol.Crypto import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto, TPraos) +import Ouroboros.Consensus.Protocol.TPraos (TPraos) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.Eras ( AllegraEra diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index fae846a943..9b6db91ff4 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -25,6 +25,7 @@ import Lens.Micro.Extras (view) import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger +import qualified Cardano.Ledger.State as SL instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto era) where getPeers ShelleyLedgerState{shelleyLedgerState} = @@ -48,9 +49,9 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto futurePoolParams , poolParams :: - Map (SL.KeyHash 'SL.StakePool) SL.PoolParams + Map (SL.KeyHash 'SL.StakePool) SL.StakePoolState (futurePoolParams, poolParams) = - (SL.psFutureStakePoolParams pstate, SL.psStakePoolParams pstate) + (SL.psFutureStakePools pstate, SL.psStakePools pstate) where pstate :: SL.PState era pstate = @@ -85,14 +86,14 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto -- \| Note that a stake pool can have multiple registered relays pparamsLedgerRelayAccessPoints :: (LedgerRelayAccessPoint -> StakePoolRelay) -> - SL.PoolParams -> + SL.StakePoolState -> Maybe (NonEmpty StakePoolRelay) pparamsLedgerRelayAccessPoints injStakePoolRelay = NE.nonEmpty . force . mapMaybe (fmap injStakePoolRelay . relayToLedgerRelayAccessPoint) . toList - . SL.ppRelays + . SL.spsRelays -- \| Combine the stake pools registered in the future and the current pool -- parameters, and remove duplicates. diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index 22068447d9..a27538af0b 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -228,7 +228,7 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where BlockQuery (ShelleyBlock proto era) QFNoTables - (Map (SL.KeyHash 'SL.StakePool) SL.PoolParams) + (Map (SL.KeyHash 'SL.StakePool) SL.StakePoolState) GetRewardInfoPools :: BlockQuery (ShelleyBlock proto era) @@ -425,7 +425,7 @@ instance GetStakePools -> SL.getPools st GetStakePoolParams poolids -> - SL.getPoolParameters st poolids + SL.getStakePools st poolids GetRewardInfoPools -> SL.getRewardInfoPools globals st GetPoolState mPoolIds -> @@ -433,10 +433,10 @@ instance in case mPoolIds of Just poolIds -> SL.PState - { SL.psStakePoolParams = - Map.restrictKeys (SL.psStakePoolParams certPState) poolIds - , SL.psFutureStakePoolParams = - Map.restrictKeys (SL.psFutureStakePoolParams certPState) poolIds + { SL.psStakePools = + Map.restrictKeys (SL.psStakePools certPState) poolIds + , SL.psFutureStakePools = + Map.restrictKeys (SL.psFutureStakePools certPState) poolIds , SL.psRetiring = Map.restrictKeys (SL.psRetiring certPState) poolIds , SL.psDeposits = Map.restrictKeys (SL.psDeposits certPState) poolIds } 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 dcfbed49c9..0627992c1a 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 @@ -19,12 +19,10 @@ module Ouroboros.Consensus.Shelley.Node.Common , shelleyBlockIssuerVKey ) where -import Cardano.Crypto.KES (UnsoundPureSignKeyKES) import Cardano.Ledger.BaseTypes (unNonZero) import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.Slot -import Cardano.Protocol.Crypto import Data.Text (Text) import Ouroboros.Consensus.Block ( CannotForge @@ -59,12 +57,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB -------------------------------------------------------------------------------} data ShelleyLeaderCredentials c = ShelleyLeaderCredentials - { shelleyLeaderCredentialsInitSignKey :: UnsoundPureSignKeyKES (KES c) - -- ^ The unevolved signing KES key (at evolution 0). - -- - -- Note that this is not inside 'ShelleyCanBeLeader' since it gets evolved - -- automatically, whereas 'ShelleyCanBeLeader' does not change. - , shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c + { shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c , shelleyLeaderCredentialsLabel :: Text -- ^ Identifier for this set of credentials. -- 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 be72ed901e..f5c00fa5c8 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 @@ -29,9 +29,6 @@ import Ouroboros.Consensus.Protocol.Praos , PraosParams (..) , praosCheckCanForge ) -import Ouroboros.Consensus.Protocol.Praos.Common - ( PraosCanBeLeader (praosCanBeLeaderOpCert) - ) import Ouroboros.Consensus.Shelley.Ledger ( ShelleyBlock , ShelleyCompatible @@ -56,21 +53,13 @@ praosBlockForging :: , IOLike m ) => PraosParams -> + HotKey.HotKey c m -> ShelleyLeaderCredentials c -> - m (BlockForging m (ShelleyBlock (Praos c) era)) -praosBlockForging praosParams credentials = do - hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod praosMaxKESEvo - pure $ praosSharedBlockForging hotKey slotToPeriod credentials + BlockForging m (ShelleyBlock (Praos c) era) +praosBlockForging praosParams hotKey credentials = + praosSharedBlockForging hotKey slotToPeriod credentials where - PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} = praosParams - - ShelleyLeaderCredentials - { shelleyLeaderCredentialsInitSignKey = initSignKey - , shelleyLeaderCredentialsCanBeLeader = canBeLeader - } = credentials - - startPeriod :: Absolute.KESPeriod - startPeriod = SL.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader + PraosParams{praosSlotsPerKESPeriod} = praosParams slotToPeriod :: SlotNo -> Absolute.KESPeriod slotToPeriod (SlotNo slot) = @@ -95,7 +84,7 @@ praosSharedBlockForging ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = canBeLeader , shelleyLeaderCredentialsLabel = label - } = do + } = BlockForging { forgeLabel = label <> "_" <> T.pack (L.eraName @era) , canBeLeader = canBeLeader @@ -111,4 +100,5 @@ praosSharedBlockForging hotKey canBeLeader cfg + , finalize = HotKey.finalize hotKey } 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 f0316ba9d4..b728f96ffe 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 @@ -43,6 +43,7 @@ import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.EpochInfo import Cardano.Slotting.Time (mkSlotLength) import Control.Monad.Except (Except) +import qualified Control.Tracer as Tracer import Data.Bifunctor (first) import qualified Data.Text as T import qualified Data.Text as Text @@ -59,6 +60,7 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Protocol.Praos.AgentClient import Ouroboros.Consensus.Protocol.Praos.Common import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras @@ -91,21 +93,13 @@ shelleyBlockForging :: , IOLike m ) => TPraosParams -> + HotKey c m -> ShelleyLeaderCredentials c -> - m (BlockForging m (ShelleyBlock (TPraos c) era)) -shelleyBlockForging tpraosParams credentials = do - hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod tpraosMaxKESEvo - pure $ shelleySharedBlockForging hotKey slotToPeriod credentials + BlockForging m (ShelleyBlock (TPraos c) era) +shelleyBlockForging tpraosParams hotKey credentials = do + shelleySharedBlockForging hotKey slotToPeriod credentials where - TPraosParams{tpraosMaxKESEvo, tpraosSlotsPerKESPeriod} = tpraosParams - - ShelleyLeaderCredentials - { shelleyLeaderCredentialsInitSignKey = initSignKey - , shelleyLeaderCredentialsCanBeLeader = canBeLeader - } = credentials - - startPeriod :: Absolute.KESPeriod - startPeriod = SL.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader + TPraosParams{tpraosSlotsPerKESPeriod} = tpraosParams slotToPeriod :: SlotNo -> Absolute.KESPeriod slotToPeriod (SlotNo slot) = @@ -141,6 +135,7 @@ shelleySharedBlockForging hotKey slotToPeriod credentials = hotKey canBeLeader cfg + , finalize = HotKey.finalize hotKey } where ShelleyLeaderCredentials @@ -173,14 +168,16 @@ validateGenesis = first errsToString . SL.validateGenesis protocolInfoShelley :: forall m c. ( IOLike m + , AgentCrypto c , ShelleyCompatible (TPraos c) ShelleyEra , TxLimits (ShelleyBlock (TPraos c) ShelleyEra) + , MonadKESAgent m ) => SL.ShelleyGenesis -> ProtocolParamsShelleyBased c -> SL.ProtVer -> ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) - , m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] + , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] ) protocolInfoShelley shelleyGenesis @@ -193,16 +190,16 @@ protocolInfoShelley protocolInfoTPraosShelleyBased :: forall m era c. - ( IOLike m - , ShelleyCompatible (TPraos c) era + ( ShelleyCompatible (TPraos c) era , TxLimits (ShelleyBlock (TPraos c) era) + , KESAgentContext c m ) => ProtocolParamsShelleyBased c -> L.TransitionConfig era -> -- | see 'shelleyProtVer', mutatis mutandi SL.ProtVer -> ( ProtocolInfo (ShelleyBlock (TPraos c) era) - , m [BlockForging m (ShelleyBlock (TPraos c) era)] + , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (ShelleyBlock (TPraos c) era)] ) protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased @@ -216,11 +213,24 @@ protocolInfoTPraosShelleyBased { pInfoConfig = topLevelConfig , pInfoInitLedger = initExtLedgerState } - , traverse - (shelleyBlockForging tpraosParams) - credentialss + , \tr -> traverse (mkBlockForging tr) credentialss ) where + mkBlockForging :: + Tracer.Tracer m KESAgentClientTrace -> + ShelleyLeaderCredentials c -> + m (BlockForging m (ShelleyBlock (TPraos c) era)) + mkBlockForging tr credentials = do + let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials + + hotKey :: HotKey c m <- + instantiatePraosCredentials + (tpraosMaxKESEvo tpraosParams) + tr + (praosCanBeLeaderCredentialsSource canBeLeader) + + return $ shelleyBlockForging tpraosParams hotKey credentials + genesis :: SL.ShelleyGenesis genesis = transitionCfg ^. L.tcShelleyGenesisL 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 8f8255cc07..38d2cc7222 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 = 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-testlib/Test/Consensus/Cardano/ProtocolInfo.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs index a583d98f5d..4c8bccfdb4 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs @@ -29,6 +29,7 @@ import qualified Cardano.Ledger.BaseTypes as SL import Cardano.Protocol.Crypto (StandardCrypto) import qualified Cardano.Protocol.TPraos.OCert as SL import qualified Cardano.Slotting.Time as Time +import qualified Control.Tracer as Tracer import Data.Proxy (Proxy (..)) import Data.SOP.Strict import Data.Word (Word64) @@ -60,12 +61,15 @@ import Ouroboros.Consensus.Protocol.PBFT ( PBftParams , PBftSignatureThreshold (..) ) +import Ouroboros.Consensus.Protocol.Praos.AgentClient + ( KESAgentClientTrace + , KESAgentContext + ) import Ouroboros.Consensus.Shelley.Node ( ProtocolParamsShelleyBased (..) , ShelleyGenesis , ShelleyLeaderCredentials ) -import Ouroboros.Consensus.Util.IOLike (IOLike) import qualified Test.Cardano.Ledger.Alonzo.Examples as Alonzo import qualified Test.Cardano.Ledger.Conway.Examples as Conway import qualified Test.Cardano.Ledger.Dijkstra.Examples as Dijkstra @@ -167,7 +171,7 @@ hardForkInto Conway = -- more details on how to specify a value of this type. mkSimpleTestProtocolInfo :: forall c. - CardanoHardForkConstraints c => + (CardanoHardForkConstraints c, KESAgentContext c IO) => -- | Network decentralization parameter. Shelley.DecentralizationParam -> SecurityParam -> @@ -236,7 +240,9 @@ mkSimpleTestProtocolInfo -- | A more generalized version of 'mkSimpleTestProtocolInfo'. mkTestProtocolInfo :: forall m c. - (CardanoHardForkConstraints c, IOLike m) => + ( CardanoHardForkConstraints c + , KESAgentContext c m + ) => -- | Id of the node for which the protocol info will be elaborated. (CoreNodeId, Shelley.CoreNode c) -> -- | These nodes will be part of the initial delegation mapping, and funds @@ -254,7 +260,9 @@ mkTestProtocolInfo :: SL.ProtVer -> -- | Specification of the era to which the initial state should hard-fork to. CardanoHardForkTriggers -> - (ProtocolInfo (CardanoBlock c), m [BlockForging m (CardanoBlock c)]) + ( ProtocolInfo (CardanoBlock c) + , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (CardanoBlock c)] + ) mkTestProtocolInfo (coreNodeId, coreNode) shelleyGenesis diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index 07b5f4b5cf..96e4eb9ee4 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -55,6 +55,7 @@ import qualified Cardano.Ledger.Shelley.LedgerState as SL import Codec.CBOR.Decoding import Codec.CBOR.Encoding import Control.Monad.Except (runExcept) +import qualified Control.Tracer as Tracer import Data.Coerce import qualified Data.Map.Strict as Map import Data.MemPack @@ -89,6 +90,10 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Node import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Protocol.Praos.AgentClient + ( KESAgentClientTrace + , KESAgentContext + ) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node @@ -96,7 +101,6 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (eitherToMaybe) -import Ouroboros.Consensus.Util.IOLike (IOLike) import Ouroboros.Consensus.Util.IndexedMemPack import Test.ThreadNet.TxGen import Test.ThreadNet.TxGen.Shelley () @@ -384,14 +388,17 @@ instance protocolInfoShelleyBasedHardFork :: forall m proto1 era1 proto2 era2. - (IOLike m, ShelleyBasedHardForkConstraints proto1 era1 proto2 era2) => + ( KESAgentContext (ProtoCrypto proto2) m + , ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 + ) => ProtocolParamsShelleyBased (ProtoCrypto proto1) -> SL.ProtVer -> SL.ProtVer -> L.TransitionConfig era2 -> TriggerHardFork -> ( ProtocolInfo (ShelleyBasedHardForkBlock proto1 era1 proto2 era2) - , m [BlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)] + , Tracer.Tracer m KESAgentClientTrace -> + m [BlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)] ) protocolInfoShelleyBasedHardFork protocolParamsShelleyBased @@ -424,7 +431,8 @@ protocolInfoShelleyBasedHardFork genesis = transCfg2 ^. L.tcShelleyGenesisL protocolInfo1 :: ProtocolInfo (ShelleyBlock proto1 era1) - blockForging1 :: m [BlockForging m (ShelleyBlock proto1 era1)] + blockForging1 :: + Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (ShelleyBlock proto1 era1)] (protocolInfo1, blockForging1) = protocolInfoTPraosShelleyBased protocolParamsShelleyBased @@ -446,7 +454,8 @@ protocolInfoShelleyBasedHardFork -- Era 2 protocolInfo2 :: ProtocolInfo (ShelleyBlock proto2 era2) - blockForging2 :: m [BlockForging m (ShelleyBlock proto2 era2)] + blockForging2 :: + Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (ShelleyBlock proto2 era2)] (protocolInfo2, blockForging2) = protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased 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 9f1ba5c367..d80a781a2c 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 @@ -50,16 +49,17 @@ class 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 data AsType (VerificationKey a) = AsVerificationKey (AsType a) 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 6a45a0341b..98eb4efa1e 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 @@ -13,7 +13,7 @@ -- | Praos consensus key types and their 'Key' class instances module Cardano.Api.KeysPraos ( -- * Key types - KesKey + UnsoundPureKesKey , VrfKey -- * Data family instances @@ -39,88 +39,88 @@ 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 - newtype VerificationKey KesKey +instance Key UnsoundPureKesKey where + newtype VerificationKey UnsoundPureKesKey = KesVerificationKey (Crypto.VerKeyKES (KES 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 + newtype SigningKey UnsoundPureKesKey = KesSigningKey (Crypto.UnsoundPureSignKeyKES (KES StandardCrypto)) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey KesKey) + 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 = + 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 (KES StandardCrypto) proxy = Proxy - getVerificationKey :: SigningKey KesKey -> VerificationKey KesKey + getVerificationKey :: SigningKey UnsoundPureKesKey -> VerificationKey UnsoundPureKesKey getVerificationKey (KesSigningKey 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.rawSerialiseUnsoundPureSignKeyKES sk - deserialiseFromRawBytes (AsSigningKey AsKesKey) 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 +newtype instance Hash UnsoundPureKesKey + = UnsoundPureKesKeyHash ( Crypto.Hash HASH (Crypto.VerKeyKES (KES 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) @@ -128,7 +128,7 @@ instance HasTextEnvelope (VerificationKey KesKey) where proxy :: Proxy (KES StandardCrypto) proxy = Proxy -instance HasTextEnvelope (SigningKey KesKey) where +instance HasTextEnvelope (SigningKey UnsoundPureKesKey) where textEnvelopeType _ = "KesSigningKey_" <> fromString (Crypto.algorithmNameKES proxy) 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 7be79132f2..979cefa97c 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 @@ -96,7 +96,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/Api/Protocol/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs index 2cb542220c..d3d95ac84a 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs @@ -4,8 +4,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Protocol/Types.hs @@ -18,6 +20,7 @@ module Cardano.Api.Protocol.Types ) where import Cardano.Chain.Slotting (EpochSlots) +import qualified Control.Tracer as Tracer import Data.Bifunctor (bimap) import Ouroboros.Consensus.Block.Forging (BlockForging) import Ouroboros.Consensus.Byron.ByronHFC (ByronBlockHFC) @@ -33,6 +36,7 @@ import Ouroboros.Consensus.Node.ProtocolInfo , ProtocolInfo (..) ) import Ouroboros.Consensus.Node.Run (RunNode) +import Ouroboros.Consensus.Protocol.Praos.AgentClient import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus import qualified Ouroboros.Consensus.Shelley.Eras as Consensus (ShelleyEra) import Ouroboros.Consensus.Shelley.HFEras () @@ -41,14 +45,14 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus ) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) -import Ouroboros.Consensus.Util.IOLike (IOLike) +import Ouroboros.Consensus.Util.IOLike class (RunNode blk, IOLike m) => Protocol m blk where data ProtocolInfoArgs m blk protocolInfo :: ProtocolInfoArgs m blk -> ( ProtocolInfo blk - , m [BlockForging m blk] + , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m blk] ) -- | Node client support for each consensus protocol. @@ -64,10 +68,16 @@ instance IOLike m => Protocol m ByronBlockHFC where data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron protocolInfo (ProtocolInfoArgsByron params) = ( inject $ protocolInfoByron params - , pure . map inject $ blockForgingByron params + , \_ -> pure . map inject $ blockForgingByron params ) -instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where +instance + ( CardanoHardForkConstraints StandardCrypto + , IOLike m + , MonadKESAgent m + ) => + Protocol m (CardanoBlock StandardCrypto) + where data ProtocolInfoArgs m (CardanoBlock StandardCrypto) = ProtocolInfoArgsCardano (CardanoProtocolParams StandardCrypto) @@ -89,6 +99,7 @@ instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlo instance ( IOLike m + , MonadKESAgent m , Consensus.LedgerSupportsProtocol ( Consensus.ShelleyBlock (Consensus.TPraos StandardCrypto) @@ -103,7 +114,9 @@ instance (ProtocolParamsShelleyBased StandardCrypto) ProtVer protocolInfo (ProtocolInfoArgsShelley genesis shelleyBasedProtocolParams' protVer) = - bimap inject (fmap $ map inject) $ protocolInfoShelley genesis shelleyBasedProtocolParams' protVer + bimap inject injectBlockForging $ protocolInfoShelley genesis shelleyBasedProtocolParams' protVer + where + injectBlockForging bf tr = fmap (map inject) $ bf tr instance Consensus.LedgerSupportsProtocol 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 86cea0bf79..62ab969a00 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 @@ -53,6 +53,7 @@ import qualified Data.Text as T import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.Protocol.Praos.Common ( PraosCanBeLeader (..) + , PraosCredentialsSource (..) ) import Ouroboros.Consensus.Shelley.Node ( Nonce (..) @@ -201,12 +202,14 @@ opCertKesKeyCheck :: FilePath -> -- | Operational certificate FilePath -> - 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 @@ -231,11 +234,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 (AsSigningKey AsUnsoundPureKesKey) scKes readBulkFile :: Maybe FilePath -> @@ -265,7 +268,7 @@ readLeaderCredentialsBulk ProtocolFilepaths{shelleyBulkCredsFile = mfp} = mkPraosLeaderCredentials :: OperationalCertificate -> SigningKey VrfKey -> - SigningKey KesKey -> + SigningKey UnsoundPureKesKey -> ShelleyLeaderCredentials StandardCrypto mkPraosLeaderCredentials (OperationalCertificate opcert (StakePoolVerificationKey vkey)) @@ -274,11 +277,10 @@ mkPraosLeaderCredentials ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader - { praosCanBeLeaderOpCert = opcert - , praosCanBeLeaderColdVerKey = coerceKeyRole vkey + { praosCanBeLeaderColdVerKey = coerceKeyRole vkey , 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 c327c8ab9a..2d1a7a1557 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 @@ -33,6 +33,7 @@ import Data.Aeson as Aeson 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) @@ -158,7 +159,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir flavargs $ ChainDB.defaultArgs - forgers <- blockForging + (_, forgers) <- allocate registry (const $ mkForgers nullTracer) (mapM_ BlockForging.finalize) let fCount = length forgers putStrLn $ "--> forger count: " ++ show fCount if fCount > 0 @@ -187,7 +188,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir { pInfoConfig , pInfoInitLedger } - , blockForging + , mkForgers ) = protocolInfoCardano runP preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs index 116683086c..60007eecda 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -13,10 +14,14 @@ module Test.Consensus.Shelley.MockCrypto , MockCrypto ) where +import Cardano.Crypto.DSIGN (MockDSIGN) import Cardano.Crypto.KES (MockKES) import qualified Cardano.Crypto.KES as KES (Signable) import Cardano.Crypto.Util (SignableRepresentation) import Cardano.Crypto.VRF (MockVRF) +import qualified Cardano.KESAgent.KES.Crypto as Agent +import qualified Cardano.KESAgent.Processes.ServiceClient as Agent +import qualified Cardano.KESAgent.Protocols.VersionedProtocol as Agent import Cardano.Ledger.BaseTypes (Seed) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Core as Core @@ -29,6 +34,9 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol ) import qualified Ouroboros.Consensus.Protocol.Praos as Praos +import Ouroboros.Consensus.Protocol.Praos.AgentClient + ( AgentCrypto (..) + ) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras (ShelleyEra) import Ouroboros.Consensus.Shelley.Ledger @@ -82,3 +90,16 @@ type CanMock proto era = , Arbitrary (SL.CertState era) , Arbitrary (Core.BlockBody era) ) + +instance Agent.NamedCrypto MockCrypto where + cryptoName _ = Agent.CryptoName "Mock" + +instance Agent.ServiceClientDrivers MockCrypto where + availableServiceClientDrivers = [] + +instance Agent.Crypto MockCrypto where + type KES MockCrypto = MockKES 10 + type DSIGN MockCrypto = MockDSIGN + +instance AgentCrypto MockCrypto where + type ACrypto MockCrypto = MockCrypto 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 2749ee44e7..c6b5169c87 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 @@ -43,6 +43,7 @@ import Cardano.Crypto.DSIGN ) import Cardano.Crypto.KES ( KESAlgorithm (..) + , UnsoundPureKESAlgorithm (..) , UnsoundPureSignKeyKES , seedSizeKES , unsoundPureDeriveVerKeyKES @@ -79,6 +80,7 @@ import qualified Cardano.Protocol.TPraos.OCert as SL , OCertSignable (..) ) import Control.Monad.Except (throwError) +import qualified Control.Tracer as Tracer import qualified Data.ByteString as BS import Data.Coerce (coerce) import Data.ListMap (ListMap (ListMap)) @@ -97,10 +99,15 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Protocol.Praos.AgentClient + ( KESAgentClientTrace + , KESAgentContext + ) import Ouroboros.Consensus.Protocol.Praos.Common ( PraosCanBeLeader (PraosCanBeLeader) + , PraosCredentialsSource (..) , praosCanBeLeaderColdVerKey - , praosCanBeLeaderOpCert + , praosCanBeLeaderCredentialsSource , praosCanBeLeaderSignKeyVRF ) import Ouroboros.Consensus.Protocol.TPraos @@ -115,7 +122,6 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.Util.Assert -import Ouroboros.Consensus.Util.IOLike import Quiet (Quiet (..)) import qualified Test.Cardano.Ledger.Core.KeyPair as TL ( KeyPair (..) @@ -245,10 +251,9 @@ genCoreNode startKESPeriod = do mkLeaderCredentials :: CoreNode c -> ShelleyLeaderCredentials c mkLeaderCredentials CoreNode{cnDelegateKey, cnVRF, cnKES, cnOCert} = ShelleyLeaderCredentials - { shelleyLeaderCredentialsInitSignKey = cnKES - , shelleyLeaderCredentialsCanBeLeader = + { shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader - { praosCanBeLeaderOpCert = cnOCert + { praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound cnOCert cnKES , praosCanBeLeaderColdVerKey = SL.VKey $ deriveVerKeyDSIGN cnDelegateKey , praosCanBeLeaderSignKeyVRF = cnVRF } @@ -457,13 +462,15 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = mkProtocolShelley :: forall m c. - (IOLike m, ShelleyCompatible (TPraos c) ShelleyEra) => + ( KESAgentContext c m + , ShelleyCompatible (TPraos c) ShelleyEra + ) => ShelleyGenesis -> SL.Nonce -> ProtVer -> CoreNode c -> ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) - , m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] + , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] ) mkProtocolShelley genesis initialNonce protVer coreNode = protocolInfoShelley diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs index 4c04c2d53f..b6d2a37778 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs @@ -20,6 +20,7 @@ import qualified Cardano.Ledger.Shelley.Core as SL import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..)) import Control.Monad (replicateM) +import Control.Tracer (nullTracer) import qualified Data.Map.Strict as Map import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) @@ -273,7 +274,7 @@ prop_simple_allegraMary_convergence (SlotNo $ unNumSlots numSlots) -- never expire setupD -- unchanged , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging + , tniBlockForging = blockForging nullTracer } , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs index bab06f0282..cc609d1582 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs @@ -26,6 +26,7 @@ import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..)) import Control.Exception (assert) import Control.Monad (replicateM) +import qualified Control.Tracer as Tracer import qualified Data.Map.Strict as Map import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) @@ -41,6 +42,7 @@ import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) import Ouroboros.Consensus.Byron.Ledger.Conversions import Ouroboros.Consensus.Byron.Node import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.CanHardFork import Ouroboros.Consensus.Cardano.Condense () import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.HardFork.Combinator @@ -54,10 +56,13 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.PBFT +import Ouroboros.Consensus.Protocol.Praos.AgentClient + ( KESAgentClientTrace + , KESAgentContext + ) import Ouroboros.Consensus.Shelley.HFEras () import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.Node -import Ouroboros.Consensus.Util.IOLike (IOLike) import Test.Consensus.Cardano.ProtocolInfo ( hardForkOnDefaultProtocolVersions , mkTestProtocolInfo @@ -471,7 +476,7 @@ prop_simple_cardano_convergence mkProtocolCardanoAndHardForkTxs :: forall c m. - (IOLike m, c ~ StandardCrypto) => + (CardanoHardForkConstraints c, KESAgentContext c m) => -- Byron PBftParams -> CoreNodeId -> @@ -495,7 +500,7 @@ mkProtocolCardanoAndHardForkTxs TestNodeInitialization { tniCrucialTxs = crucialTxs , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging + , tniBlockForging = blockForging Tracer.nullTracer } where crucialTxs :: [GenTx (CardanoBlock c)] @@ -514,7 +519,7 @@ mkProtocolCardanoAndHardForkTxs propPV protocolInfo :: ProtocolInfo (CardanoBlock c) - blockForging :: m [BlockForging m (CardanoBlock c)] + blockForging :: Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m (CardanoBlock c)] (setByronProtVer -> protocolInfo, blockForging) = mkTestProtocolInfo (coreNodeId, coreNodeShelley) diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs index 7c8d818c87..f8041f6926 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs @@ -25,6 +25,7 @@ import qualified Cardano.Ledger.Shelley.Core as SL import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..)) import Control.Monad (replicateM) +import Control.Tracer (nullTracer) import qualified Data.Map.Strict as Map import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) @@ -283,7 +284,7 @@ prop_simple_allegraAlonzo_convergence (SlotNo $ unNumSlots numSlots) -- never expire setupD -- unchanged , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging + , tniBlockForging = blockForging nullTracer } , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs index 712268d12d..783ea08dc3 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs @@ -20,6 +20,7 @@ import qualified Cardano.Ledger.Shelley.Core as SL import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Slot (EpochSize (..), SlotNo (..)) import Control.Monad (replicateM) +import Control.Tracer (nullTracer) import qualified Data.Map.Strict as Map import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) @@ -282,7 +283,7 @@ prop_simple_shelleyAllegra_convergence (SlotNo $ unNumSlots numSlots) -- never expire setupD -- unchanged , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging + , tniBlockForging = blockForging nullTracer } , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs index f3b75f4dfe..a795b26671 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs @@ -21,6 +21,7 @@ import qualified Cardano.Ledger.Shelley.Translation as SL import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.EpochInfo (fixedEpochInfo) import Control.Monad (replicateM) +import Control.Tracer (nullTracer) import qualified Data.Map.Strict as Map import Data.Word (Word64) import Lens.Micro ((^.)) @@ -296,7 +297,7 @@ prop_simple_real_tpraos_convergence nextProtVer sentinel -- Does not expire during test setupD2 - , tniBlockForging = blockForging + , tniBlockForging = blockForging nullTracer } , mkRekeyM = Nothing } 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..aa089e5cc9 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20250130_100651_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,4 @@ +### Non-Breaking + +- Ensure that block forging threads finalize their keys when shutting down. +- Adds a `kesAgentClientTracer` for tracing `KESAgentClientTrace` events diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 1ffccbe235..c17425b27a 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -89,6 +89,7 @@ library mtl, network-mux ^>=0.9, ouroboros-consensus ^>=0.27, + ouroboros-consensus-protocol ^>=0.12, ouroboros-network:{cardano-diffusion, ouroboros-network} ^>=0.22.1, ouroboros-network-api ^>=0.16, ouroboros-network-framework ^>=0.19, @@ -137,6 +138,7 @@ library unstable-diffusion-testlib mtl, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, ouroboros-consensus-diffusion, + ouroboros-consensus-protocol, ouroboros-network, ouroboros-network-api, ouroboros-network-framework, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index 24b82c331d..3d025ea91d 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -43,6 +43,9 @@ import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server ( TraceLocalTxSubmissionServerEvent (..) ) import Ouroboros.Consensus.Node.GSM (TraceGsmEvent) +import Ouroboros.Consensus.Protocol.Praos.AgentClient + ( KESAgentClientTrace (..) + ) import Ouroboros.Network.Block (Tip) import Ouroboros.Network.BlockFetch ( TraceFetchClientState @@ -87,6 +90,7 @@ data Tracers' remotePeer localPeer blk f = Tracers , csjTracer :: f (TraceLabelPeer remotePeer (CSJumping.TraceEventCsj remotePeer blk)) , dbfTracer :: f (CSJumping.TraceEventDbf remotePeer) + , kesAgentTracer :: f KESAgentClientTrace } instance @@ -115,6 +119,7 @@ instance , gddTracer = f gddTracer , csjTracer = f csjTracer , dbfTracer = f dbfTracer + , kesAgentTracer = f kesAgentTracer } where f :: @@ -151,6 +156,7 @@ nullTracers = , gddTracer = nullTracer , csjTracer = nullTracer , dbfTracer = nullTracer + , kesAgentTracer = nullTracer } showTracers :: @@ -189,6 +195,7 @@ showTracers tr = , gddTracer = showTracing tr , csjTracer = showTracing tr , dbfTracer = showTracing tr + , kesAgentTracer = showTracing tr } {------------------------------------------------------------------------------- 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 b9c53da498..2a35c8140d 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 @@ -496,9 +496,13 @@ forkBlockForging :: BlockForging m blk -> m (Thread m Void) forkBlockForging IS{..} blockForging = - forkLinkedWatcher registry label $ - knownSlotWatcher btime $ - \currentSlot -> withRegistry (\rr -> withEarlyExit_ $ go rr currentSlot) + forkLinkedWatcherFinalize + registry + label + ( knownSlotWatcher btime $ + \currentSlot -> withRegistry (\rr -> withEarlyExit_ $ go rr currentSlot) + ) + (finalize blockForging) where label :: String label = diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs index cb20051897..afa90db0e7 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs @@ -55,6 +55,7 @@ import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.Abstract (LedgerView) import Ouroboros.Consensus.Protocol.LeaderSchedule +import Ouroboros.Consensus.Protocol.Praos.AgentClient (MonadKESAgent) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense @@ -214,7 +215,7 @@ runTestNetwork :: ) => TestConfig -> TestConfigB blk -> - (forall m. IOLike m => TestConfigMB m blk) -> + (forall m. (IOLike m, MonadKESAgent m) => TestConfigMB m blk) -> TestOutput blk runTestNetwork TestConfig 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 3b3d472a38..0c7c6188c1 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 @@ -71,6 +71,7 @@ import Network.TypedProtocol.Codec ) 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 @@ -830,7 +831,7 @@ runThreadNetwork ( 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 @@ -1097,9 +1098,9 @@ runThreadNetwork 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 d30d71dc7f..50adf203bc 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 @@ -358,6 +358,7 @@ blockForgingA = , 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 caf7d9bb3c..4f74a9a422 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 @@ -300,6 +300,7 @@ blockForgingB = , 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 27b0976ea5..ca1f30f43c 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs @@ -55,7 +55,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 dffbcc571e..a8b9604124 100644 --- a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal +++ b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal @@ -56,6 +56,7 @@ library Ouroboros.Consensus.Protocol.Ledger.HotKey Ouroboros.Consensus.Protocol.Ledger.Util Ouroboros.Consensus.Protocol.Praos + Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common Ouroboros.Consensus.Protocol.Praos.Header Ouroboros.Consensus.Protocol.Praos.VRF @@ -63,6 +64,7 @@ library Ouroboros.Consensus.Protocol.TPraos build-depends: + Win32-network ^>=0.2, base >=4.14 && <4.22, bytestring, cardano-binary, @@ -74,9 +76,16 @@ library cardano-slotting, cborg, containers, + contra-tracer ^>=0.1.0, + io-classes ^>=1.8.0, + io-sim, + kes-agent, mtl, + network ^>=3.2.7, nothunks, ouroboros-consensus >=0.23 && <0.28, + ouroboros-network-framework ^>=0.19, + ouroboros-network-testing ^>=0.8, serialise, text, 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 cbaec8a8b6..37f0c7c09a 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,16 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | Hot key -- @@ -22,7 +29,12 @@ module Ouroboros.Consensus.Protocol.Ledger.HotKey , HotKey (..) , KESEvolutionError (..) , KESEvolutionInfo + , finalize + , getOCert + , mkDynamicHotKey + , mkEmptyHotKey , mkHotKey + , mkHotKeyAtEvolution , sign ) where @@ -30,9 +42,12 @@ import qualified Cardano.Crypto.KES as KES import qualified Cardano.Crypto.KES as Relative (Period) import Cardano.Protocol.Crypto (Crypto (..)) import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) +import qualified Cardano.Protocol.TPraos.OCert as OCert +import Control.Monad (forM_) import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) +import NoThunks.Class (OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.Block.Forging (UpdateInfo (..)) import Ouroboros.Consensus.Util.IOLike @@ -134,19 +149,47 @@ data HotKey c m = HotKey -- When the key cannot evolve anymore, we poison it. , getInfo :: m KESInfo -- ^ Return 'KESInfo' of the signing key. + , getOCertMaybe :: m (Maybe (OCert.OCert c)) + -- ^ Return the 'OCert' corresponding to the KES signing key, if any. , isPoisoned :: m Bool - -- ^ Return 'True' when the signing key is poisoned because it expired. + -- ^ 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 , sign_ :: forall toSign. (KES.Signable (KES c) toSign, HasCallStack) => - toSign -> m (KES.SignedKES (KES c) toSign) + toSign -> + m (KES.SignedKES (KES c) toSign) -- ^ Sign the given @toSign@ with the current signing key. -- -- PRECONDITION: the key is not poisoned. -- -- POSTCONDITION: the signature is in normal form. + , forget_ :: m () + -- ^ Securely erase the key and release its memory. User code should use + -- 'finalize' instead (which forgets and then finalizes the 'HotKey'). + , finalize_ :: m () + -- ^ Release any resources held by the 'HotKey', except for the signing + -- key itself. User code should use 'finalize' instead. } +-- | Release all resources held by the 'HotKey', including the signing key +-- itself. Use this exactly once per 'HotKey' instance. +finalize :: Monad m => HotKey c m -> m () +finalize hotKey = forget_ hotKey >> finalize_ hotKey + +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 :: (KES.Signable (KES c) toSign, HasCallStack) => HotKey c m -> @@ -157,15 +200,15 @@ sign = sign_ -- | The actual KES key, unless it expired, in which case it is replaced by -- \"poison\". data KESKey c - = KESKey !(KES.UnsoundPureSignKeyKES (KES c)) + = KESKey !(OCert.OCert c) !(KES.SignKeyKES (KES c)) | KESKeyPoisoned deriving Generic -instance Crypto c => NoThunks (KESKey c) +instance (NoThunks (KES.SignKeyKES (KES c)), Crypto c) => NoThunks (KESKey c) kesKeyIsPoisoned :: KESKey c -> Bool kesKeyIsPoisoned KESKeyPoisoned = True -kesKeyIsPoisoned (KESKey _) = False +kesKeyIsPoisoned (KESKey _ _) = False data KESState c = KESState { kesStateInfo :: !KESInfo @@ -173,35 +216,141 @@ data KESState c = KESState } deriving Generic -instance Crypto c => NoThunks (KESState c) +instance (NoThunks (KES.SignKeyKES (KES c)), 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) => - KES.UnsoundPureSignKeyKES (KES c) -> + OCert.OCert c -> + KES.SignKeyKES (KES c) -> + -- | Start period + Absolute.KESPeriod -> + -- | Max KES evolutions + Word64 -> + m (HotKey c m) +mkHotKey = mkHotKeyAtEvolution 0 + +-- Create a new 'HotKey' and initialize it to the given initial KES key. The +-- initial key should be at the given evolution. +mkHotKeyAtEvolution :: + forall m c. + (Crypto c, IOLike m) => + Word -> + OCert.OCert c -> + KES.SignKeyKES (KES c) -> -- | Start period Absolute.KESPeriod -> -- | Max KES evolutions Word64 -> m (HotKey c m) -mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do +mkHotKeyAtEvolution evolution ocert initKey startPeriod maxKESEvolutions = + mkHotKeyWith + (Just (ocert, initKey, evolution, startPeriod)) + maxKESEvolutions + Nothing + (pure ()) + +-- | 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) => + -- | Max KES evolutions + Word64 -> + m () -> + m (HotKey c m) +mkEmptyHotKey maxKESEvolutions = + mkDynamicHotKey maxKESEvolutions Nothing + +mkKESState :: + Word64 -> OCert.OCert c -> KES.SignKeyKES (KES c) -> Word -> Absolute.KESPeriod -> KESState c +mkKESState maxKESEvolutions newOCert newKey evolution startPeriod@(Absolute.KESPeriod start) = + KESState + { kesStateInfo = + KESInfo + { kesStartPeriod = startPeriod + , kesEndPeriod = Absolute.KESPeriod (start + fromIntegral maxKESEvolutions) + , kesEvolution = evolution + } + , kesStateKey = KESKey newOCert newKey + } + +type KeyProducer c m = + -- | Callback that will be invoked when a new key has been received + (OCert.OCert c -> KES.SignKeyKES (KES c) -> Word -> Absolute.KESPeriod -> m ()) -> + -- | Callback that will be invoked when a key deletion has been received + m () -> + m () + +-- | Create a new 'HotKey' that runs a key-producer action on a separate thread. +-- The key producer action will receive a callback that can be used to pass +-- keys into the HotKey; the HotKey will dynamically update its internal state +-- to reflect new keys as they arrive. +mkDynamicHotKey :: + forall m c. + (Crypto c, IOLike m) => + -- | Max KES evolutions + Word64 -> + Maybe (KeyProducer c m) -> + m () -> + m (HotKey c m) +mkDynamicHotKey = mkHotKeyWith Nothing + +-- | The most general function for creating a new 'HotKey', accepting an initial +-- set of credentials, a key producer action, and a custom finalizer. +mkHotKeyWith :: + forall m c. + (Crypto c, IOLike m) => + Maybe (OCert.OCert c, KES.SignKeyKES (KES c), Word, Absolute.KESPeriod) -> + -- | Max KES evolutions + Word64 -> + Maybe (KeyProducer c m) -> + m () -> + m (HotKey c m) +mkHotKeyWith initialStateMay maxKESEvolutions keyThreadMay finalizer = do varKESState <- newMVar initKESState + + let set newOCert newKey evolution startPeriod = + modifyMVar_ varKESState $ \oldState -> do + _ <- poisonState oldState + return $ mkKESState maxKESEvolutions newOCert newKey evolution startPeriod + unset = + modifyMVar_ varKESState poisonState + + forM_ initialStateMay $ \(newOCert, newKey, evolution, startPeriod) -> + set newOCert newKey evolution startPeriod + + finalizer' <- case keyThreadMay of + Just keyThread -> do + keyThreadAsync <- async $ do + labelThisThread "HotKey receiver" + keyThread set unset + return (cancel keyThreadAsync >> finalizer) + Nothing -> + return finalizer + 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 = KES.unsoundPureSignedKES () 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 + KES.signedKES () evolution toSign key + , forget_ = unset + , finalize_ = finalizer' } where initKESState :: KESState c @@ -209,14 +358,26 @@ mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do KESState { kesStateInfo = KESInfo - { kesStartPeriod = startPeriod - , kesEndPeriod = Absolute.KESPeriod (start + fromIntegral maxKESEvolutions) - , -- We always start from 0 as the key hasn't evolved yet. - kesEvolution = 0 + { kesStartPeriod = Absolute.KESPeriod 0 + , kesEndPeriod = Absolute.KESPeriod 0 + , kesEvolution = 0 } - , kesStateKey = KESKey initKey + , kesStateKey = KESKeyPoisoned } +poisonState :: + forall m c. + (KES.KESAlgorithm (KES 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 @@ -232,7 +393,7 @@ mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do -- When the key is poisoned, we always return 'UpdateFailed'. evolveKey :: forall m c. - (Crypto c, IOLike m) => + (IOLike m, KES.ContextKES (KES c) ~ (), KES.KESAlgorithm (KES c)) => StrictMVar m (KESState c) -> Absolute.KESPeriod -> m KESEvolutionInfo evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do let info = kesStateInfo kesState @@ -244,7 +405,7 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do KESKeyPoisoned -> 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. @@ -252,9 +413,10 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do return (kesState, Updated info) -- 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 | targetEvolution <= kesEvolution info -> @@ -262,29 +424,26 @@ 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 -> KES.UnsoundPureSignKeyKES (KES c) -> m (KESState c) - go targetEvolution info key + go :: KESEvolution -> KESInfo -> OCert.OCert c -> KES.SignKeyKES (KES 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 KES.unsoundPureUpdateKES () key curEvolution of - -- This cannot happen - Nothing -> error "Could not update KES key" - Just !key' -> do - -- Clear the memory associated with the old key - -- FIXME: Secure forgetting is not available through the unsound KES API, - -- but we must restore this invocation when moving to the new mlocked KES - -- API. - -- forgetSignKeyKES key - let info' = info{kesEvolution = curEvolution + 1} - go targetEvolution info' key' + do + maybeKey' <- KES.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 96b896886f..91965499ea 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 @@ -187,26 +187,24 @@ forgePraosFields PraosCanBeLeader { praosCanBeLeaderColdVerKey , praosCanBeLeaderSignKeyVRF - , praosCanBeLeaderOpCert } 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/AgentClient.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/AgentClient.hs new file mode 100644 index 0000000000..00e6b79be4 --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/AgentClient.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Ouroboros.Consensus.Protocol.Praos.AgentClient + ( AgentCrypto (..) + , KESAgentClientTrace (..) + , KESAgentContext + , MonadKESAgent (..) + , runKESAgentClient + ) where + +import Cardano.Crypto.DirectSerialise + ( DirectDeserialise + , DirectSerialise + ) +import Cardano.Crypto.KES.Class +import Cardano.Crypto.VRF.Class +import qualified Cardano.KESAgent.KES.Bundle as Agent +import qualified Cardano.KESAgent.KES.Crypto as Agent +import qualified Cardano.KESAgent.KES.OCert as Agent +import qualified Cardano.KESAgent.Processes.ServiceClient as Agent +import qualified Cardano.KESAgent.Protocols.RecvResult as Agent +import qualified Cardano.KESAgent.Protocols.StandardCrypto as Agent +import qualified Cardano.KESAgent.Protocols.VersionedProtocol as Agent +import Cardano.KESAgent.Util.RefCounting +import Cardano.Ledger.Keys (DSIGN) +import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF) +import qualified Cardano.Protocol.TPraos.OCert as OCert +import Control.Monad (forever) +import Control.Monad.Class.MonadAsync +import Control.Monad.IOSim +import Control.Tracer +import Data.Coerce (coerce) +import Data.Kind +import Data.Typeable +import Network.Socket +import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Network.RawBearer +import Ouroboros.Network.Snocket +import qualified Simulation.Network.Snocket as SimSnocket +import System.IOManager +import Test.Ouroboros.Network.Data.AbsBearerInfo as ABI + +type KESAgentContext c m = + ( AgentCrypto c + , MonadKESAgent m + , IOLike m + ) + +data KESAgentClientTrace + = KESAgentClientException SomeException + | KESAgentClientTrace Agent.ServiceClientTrace + deriving Show + +class + ( Crypto c + , Agent.Crypto (ACrypto c) + , Agent.NamedCrypto (ACrypto c) + , Agent.KES (ACrypto c) ~ KES c + , ContextKES (KES c) ~ () + , ContextVRF (VRF c) ~ () + , Typeable (ACrypto c) + , Agent.ServiceClientDrivers (ACrypto c) + , DirectSerialise (SignKeyKES (KES c)) + , DirectDeserialise (SignKeyKES (KES c)) + ) => + AgentCrypto c + where + type ACrypto c :: Type + +instance AgentCrypto StandardCrypto where + type ACrypto StandardCrypto = Agent.StandardCrypto + +convertOCert :: + (AgentCrypto c, Agent.DSIGN (ACrypto c) ~ DSIGN) => Agent.OCert (ACrypto c) -> OCert.OCert c +convertOCert oca = + OCert.OCert + { OCert.ocertVkHot = Agent.ocertVkHot oca + , OCert.ocertN = Agent.ocertN oca + , OCert.ocertKESPeriod = OCert.KESPeriod (Agent.unKESPeriod $ Agent.ocertKESPeriod oca) + , OCert.ocertSigma = coerce (Agent.ocertSigma oca) + } + +convertPeriod :: Agent.KESPeriod -> OCert.KESPeriod +convertPeriod (Agent.KESPeriod p) = OCert.KESPeriod p + +class (MonadFail m, Show (Addr m)) => MonadKESAgent m where + type FD m :: Type + type Addr m :: Type + withAgentContext :: (Snocket m (FD m) (Addr m) -> m a) -> m a + makeRawBearer :: MakeRawBearer m (FD m) + makeAddress :: Proxy m -> FilePath -> Addr m + +instance MonadKESAgent IO where + type FD IO = Socket + type Addr IO = SockAddr + withAgentContext inner = + withIOManager $ \ioManager -> + inner (socketSnocket ioManager) + makeRawBearer = makeSocketRawBearer + makeAddress _ = SockAddrUnix + +instance MonadKESAgent (IOSim s) where + type FD (IOSim s) = SimSnocket.FD (IOSim s) (TestAddress FilePath) + type Addr (IOSim s) = TestAddress FilePath + withAgentContext inner = do + SimSnocket.withSnocket + nullTracer + (toBearerInfo $ absNoAttenuation{abiConnectionDelay = SmallDelay}) + mempty + $ \snocket _observe -> inner snocket + makeRawBearer = SimSnocket.makeFDRawBearer nullTracer + makeAddress _ = TestAddress + +instance SimSnocket.GlobalAddressScheme FilePath where + getAddressType = const SimSnocket.IPv4Address + ephemeralAddress _ty num = TestAddress $ "simSnocket_" <> show num + +runKESAgentClient :: + forall m c. + ( KESAgentContext c m + , Agent.DSIGN (ACrypto c) ~ DSIGN + ) => + Tracer m KESAgentClientTrace -> + FilePath -> + (OCert.OCert c -> SignKeyKES (KES c) -> Word -> OCert.KESPeriod -> m ()) -> + m () -> + m () +runKESAgentClient tracer path handleKey handleDropKey = do + withAgentContext $ \snocket -> do + forever $ do + Agent.runServiceClient + (Proxy @(ACrypto c)) + makeRawBearer + ( Agent.ServiceClientOptions + { Agent.serviceClientSnocket = snocket + , Agent.serviceClientAddress = makeAddress (Proxy @m) path + } :: + Agent.ServiceClientOptions m (FD m) (Addr m) + ) + ( \(Agent.TaggedBundle mBundle _) -> do + case mBundle of + Just (Agent.Bundle skpRef ocert) -> do + -- We take ownership of the key, so we acquire one extra reference, + -- preventing the key from being discarded after `handleKey` + -- finishes. + _ <- acquireCRef skpRef + withCRefValue skpRef $ \(SignKeyWithPeriodKES sk p) -> + handleKey (convertOCert ocert) sk p (convertPeriod $ Agent.ocertKESPeriod ocert) + return Agent.RecvOK + _ -> do + handleDropKey + return Agent.RecvOK + ) + (contramap KESAgentClientTrace tracer) + `catch` ( \(_e :: AsyncCancelled) -> + return () + ) + `catch` ( \(e :: SomeException) -> + traceWith tracer (KESAgentClientException e) + ) + threadDelay 10000000 + +toBearerInfo :: ABI.AbsBearerInfo -> SimSnocket.BearerInfo +toBearerInfo abi = + SimSnocket.BearerInfo + { SimSnocket.biConnectionDelay = ABI.delay (ABI.abiConnectionDelay abi) + , SimSnocket.biInboundAttenuation = attenuation (ABI.abiInboundAttenuation abi) + , SimSnocket.biOutboundAttenuation = attenuation (ABI.abiOutboundAttenuation abi) + , SimSnocket.biInboundWriteFailure = ABI.abiInboundWriteFailure abi + , SimSnocket.biOutboundWriteFailure = ABI.abiOutboundWriteFailure abi + , SimSnocket.biAcceptFailures = + ( \(errDelay, errType) -> + ( ABI.delay errDelay + , errType + ) + ) + <$> abiAcceptFailure abi + , SimSnocket.biSDUSize = toSduSize (ABI.abiSDUSize abi) + } 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 be09911058..16888448e2 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,8 +2,13 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Various things common to iterations of the Praos protocol. @@ -15,26 +20,35 @@ module Ouroboros.Consensus.Protocol.Praos.Common , VRFTiebreakerFlavor (..) -- * node support + , PraosCredentialsSource (..) , PraosNonces (..) , PraosProtocolSupportsNode (..) + , instantiatePraosCredentials ) where +import qualified Cardano.Crypto.KES.Class as KES +import Cardano.Crypto.VRF import qualified Cardano.Crypto.VRF as VRF +import qualified Cardano.KESAgent.KES.Crypto as Agent import Cardano.Ledger.BaseTypes (Nonce) import qualified Cardano.Ledger.BaseTypes as SL import Cardano.Ledger.Binary (FromCBOR, ToCBOR) -import Cardano.Ledger.Keys (KeyHash, KeyRole (BlockIssuer)) +import Cardano.Ledger.Keys (DSIGN, KeyHash, KeyRole (BlockIssuer)) import qualified Cardano.Ledger.Shelley.API as SL -import Cardano.Protocol.Crypto (Crypto, VRF) +import Cardano.Protocol.Crypto (Crypto, KES, VRF) import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Slot (SlotNo) +import qualified Control.Tracer as Tracer import Data.Function (on) import Data.Map.Strict (Map) import Data.Ord (Down (Down)) +import Data.Void import Data.Word (Word64) import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) +import NoThunks.Class import Ouroboros.Consensus.Protocol.Abstract +import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Protocol.Praos.AgentClient -- | The maximum major protocol version. -- @@ -240,16 +254,65 @@ instance Crypto c => ChainOrder (PraosTiebreakerView c) where preferCandidate cfg ours cand = comparePraos cfg ours cand == LT data PraosCanBeLeader c = PraosCanBeLeader - { praosCanBeLeaderOpCert :: !(OCert.OCert c) - -- ^ Certificate delegating rights from the stake pool cold key (or - -- genesis stakeholder delegate cold key) to the online KES key. - , praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer) + { praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer) -- ^ Stake pool cold key or genesis stakeholder delegate cold key. - , praosCanBeLeaderSignKeyVRF :: !(VRF.SignKeyVRF (VRF c)) + , praosCanBeLeaderSignKeyVRF :: !(SignKeyVRF (VRF c)) + , praosCanBeLeaderCredentialsSource :: !(PraosCredentialsSource c) + -- ^ How to obtain KES credentials (ocert + sign key) } deriving Generic -instance Crypto c => NoThunks (PraosCanBeLeader c) +instance + (NoThunks (SignKeyVRF (VRF c)), NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) => + NoThunks (PraosCanBeLeader c) + +-- | Defines a method for obtaining Praos credentials (opcert + KES signing +-- key). +data PraosCredentialsSource c where + -- | Pass an opcert and sign key directly. This uses + -- 'KES.UnsoundPureSignKeyKES', which does not provide mlocking guarantees, + -- violating the rule that KES secrets must never be stored on disk, but + -- allows the sign key to be loaded from a local file. This method is + -- provided for backwards compatibility. + PraosCredentialsUnsound :: + OCert.OCert c -> KES.UnsoundPureSignKeyKES (KES c) -> PraosCredentialsSource c + -- | Connect to a KES agent listening on a service socket at the given path. + PraosCredentialsAgent :: + Agent.DSIGN (ACrypto c) ~ DSIGN => Void -> FilePath -> PraosCredentialsSource c + +instance (NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) => NoThunks (PraosCredentialsSource c) where + wNoThunks ctxt = \case + PraosCredentialsUnsound oca k -> + allNoThunks + [ noThunks ctxt oca + , noThunks ctxt k + ] + PraosCredentialsAgent _ fp -> noThunks ctxt fp + + showTypeOf _ = "PraosCredentialsSource" + +instantiatePraosCredentials :: + forall m c. + KESAgentContext c m => + Word64 -> + Tracer.Tracer m KESAgentClientTrace -> + PraosCredentialsSource c -> + m (HotKey.HotKey c m) +instantiatePraosCredentials maxKESEvolutions _ (PraosCredentialsUnsound ocert skUnsound) = do + sk <- KES.unsoundPureSignKeyKESToSoundSignKeyKES skUnsound + let startPeriod :: OCert.KESPeriod + startPeriod = OCert.ocertKESPeriod ocert + + HotKey.mkHotKey + ocert + sk + startPeriod + maxKESEvolutions +instantiatePraosCredentials maxKESEvolutions tr (PraosCredentialsAgent _ path) = do + HotKey.mkDynamicHotKey + maxKESEvolutions + (Just $ runKESAgentClient tr path) + (pure ()) -- | 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 103dcad8ec..478ce19b18 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 @@ -142,23 +142,22 @@ 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/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 e92be3db64..ebea9ceb80 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -516,7 +516,7 @@ library unstable-mock-block cardano-binary, cardano-crypto-class, cardano-ledger-core, - cardano-slotting:{cardano-slotting, testlib}, + cardano-slotting, cborg, containers, deepseq, 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 ec05ba26a4..e186a52c44 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs @@ -141,6 +141,13 @@ data BlockForging m blk = BlockForging -- even when used as part of the hard fork combinator. -- -- PRECONDITION: 'checkCanForge' returned @Right ()@. + , finalize :: m () + -- ^ 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. } data ShouldForge blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs index 48c66660cb..bb349ab78d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs @@ -3,10 +3,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Ouroboros.Consensus.HardFork.Combinator.Embed.Binary (protocolInfoBinary) where import Control.Exception (assert) +import qualified Control.Tracer as Tracer import Data.Align (alignWith) import Data.SOP.Counting (exactlyTwo) import Data.SOP.Functors (Flip (..)) @@ -29,22 +31,22 @@ import Ouroboros.Consensus.TypeFamilyWrappers -------------------------------------------------------------------------------} protocolInfoBinary :: - forall m blk1 blk2. + forall m kesAgentTrace blk1 blk2. (CanHardFork '[blk1, blk2], Monad m) => -- First era ProtocolInfo blk1 -> - m [BlockForging m blk1] -> + (Tracer.Tracer m kesAgentTrace -> m [BlockForging m blk1]) -> History.EraParams -> (ConsensusConfig (BlockProtocol blk1) -> PartialConsensusConfig (BlockProtocol blk1)) -> (LedgerConfig blk1 -> PartialLedgerConfig blk1) -> -- Second era ProtocolInfo blk2 -> - m [BlockForging m blk2] -> + (Tracer.Tracer m kesAgentTrace -> m [BlockForging m blk2]) -> History.EraParams -> (ConsensusConfig (BlockProtocol blk2) -> PartialConsensusConfig (BlockProtocol blk2)) -> (LedgerConfig blk2 -> PartialLedgerConfig blk2) -> ( ProtocolInfo (HardForkBlock '[blk1, blk2]) - , m [BlockForging m (HardForkBlock '[blk1, blk2])] + , Tracer.Tracer m kesAgentTrace -> m [BlockForging m (HardForkBlock '[blk1, blk2])] ) protocolInfoBinary protocolInfo1 @@ -107,7 +109,7 @@ protocolInfoBinary headerStateChainDep initHeaderState1 } } - , alignWith alignBlockForging <$> blockForging1 <*> blockForging2 + , \tr -> alignWith alignBlockForging <$> blockForging1 tr <*> blockForging2 tr ) where ProtocolInfo 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 f720673d5a..f730ea282d 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 @@ -434,6 +434,7 @@ instance Functor m => Isomorphic (BlockForging m) where BlockForging { forgeLabel = forgeLabel , canBeLeader = project' (Proxy @(WrapCanBeLeader blk)) canBeLeader + , finalize = finalize , updateForgeState = \cfg sno tickedChainDepSt -> project <$> updateForgeState @@ -485,6 +486,7 @@ instance Functor m => Isomorphic (BlockForging m) where 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 a8f60c3556..61d5c002e4 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 @@ -14,9 +14,12 @@ 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.BasicFunctors +import Data.SOP.Constraint (All) import Data.SOP.Functors (Product2 (..)) import Data.SOP.InPairs (InPairs) import qualified Data.SOP.InPairs as InPairs @@ -89,6 +92,7 @@ hardForkBlockForging label blockForging = , updateForgeState = hardForkUpdateForgeState blockForging , checkCanForge = hardForkCheckCanForge blockForging , forgeBlock = hardForkForgeBlock blockForging + , finalize = hardForkFinalize blockForging } hardForkCanBeLeader :: @@ -98,6 +102,12 @@ 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/EarlyExit.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs index 4eba0f7c8a..7f9b5905e1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -374,6 +374,7 @@ instance MonadSay m => MonadSay (WithEarlyExit m) where instance (MonadInspectSTM m, Monad (InspectMonadSTM m)) => MonadInspectSTM (WithEarlyExit m) where type InspectMonadSTM (WithEarlyExit m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) 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 9130e3bee1..11519e3d2f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -12,6 +12,7 @@ module Ouroboros.Consensus.Util.STM ( -- * 'Watcher' Watcher (..) , forkLinkedWatcher + , forkLinkedWatcherFinalize , withWatcher -- * Misc @@ -181,6 +182,22 @@ forkLinkedWatcher :: 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 -> + -- | Label for the thread + String -> + 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 a57d6d4d8b..b5abe5b2c7 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 #-} @@ -183,6 +184,8 @@ instance headerIsEBB = const Nothing +type KnownHashSize c = KnownNat (Hash.SizeHash (SimpleHash c)) + data SimpleStdHeader c ext = SimpleStdHeader { simplePrev :: ChainHash (SimpleBlock c ext) , simpleSlotNo :: SlotNo @@ -194,7 +197,7 @@ data SimpleStdHeader c ext = SimpleStdHeader deriving anyclass NoThunks deriving anyclass instance - KnownNat (Hash.SizeHash (SimpleHash c)) => + KnownHashSize c => Serialise (SimpleStdHeader c ext) data SimpleBody = SimpleBody @@ -728,10 +731,7 @@ instance InspectLedger (SimpleBlock c ext) Crypto needed for simple blocks -------------------------------------------------------------------------------} -class - (KnownNat (Hash.SizeHash (SimpleHash c)), HashAlgorithm (SimpleHash c), Typeable c) => - SimpleCrypto c - where +class (KnownHashSize c, HashAlgorithm (SimpleHash c), Typeable c) => SimpleCrypto c where type SimpleHash c :: Type data SimpleStandardCrypto @@ -791,7 +791,7 @@ instance ToCBOR SimpleBody where toCBOR = encode encodeSimpleHeader :: - KnownNat (Hash.SizeHash (SimpleHash c)) => + KnownHashSize c => (ext' -> CBOR.Encoding) -> Header (SimpleBlock' c ext ext') -> CBOR.Encoding 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 ee5928b299..9eccd4e07e 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 @@ -110,6 +110,7 @@ simpleBlockForging aCanBeLeader aForgeExt = 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 5b97a5b447..497d232b3f 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 @@ -118,4 +118,5 @@ pbftBlockForging canBeLeader = 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 97c533f689..09a33db862 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 @@ -145,4 +145,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 7865770fd8..53164edf6d 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 @@ -82,7 +82,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 -- @@ -216,7 +215,8 @@ data HotKey c | HotKeyPoisoned deriving Generic -instance PraosCrypto c => NoThunks (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 ++ "