diff --git a/cabal.project b/cabal.project index 6ecd7821eb..0370d02937 100644 --- a/cabal.project +++ b/cabal.project @@ -34,6 +34,11 @@ multi-repl: True import: ./asserts.cabal +allow-newer: plutus-core:cardano-crypto-class + , bytestring + , serdoc-core:tasty-quickcheck + , kes-agent:base + package ouroboros-network -- Certain ThreadNet tests rely on transactions to be submitted promptly after -- a node (re)start. Therefore, we disable this flag (see @@ -44,3 +49,46 @@ package ouroboros-network if(os(windows)) constraints: bitvec -simd + +source-repository-package + type: git + location: git@github.com:input-output-hk/kes-agent + tag: 7d3517d61004b3e0867b62f1b4cf02ae5eee5589 + --sha256: sha256-N4XRVqC+UgWej+J16RPh3EO6MSIE3wmJvmP5/nRgIuw= + subdir: + kes-agent + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-ledger + tag: 9d380ab7d6ae52ff66aae9a19dbb3036b1b13c94 + --sha256: sha256-N4XRVqC+UgWej+J16RPh3EO6MSIE3wmJvmP5/nRgIuw= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/alonzo/test-suite + eras/babbage/impl + eras/babbage/test-suite + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/crypto/test + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/byron/ledger/impl/test + eras/conway/impl + eras/conway/test-suite + eras/mary/impl + eras/shelley/impl + eras/shelley-ma/test-suite + eras/shelley/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-ledger-test + libs/cardano-protocol-tpraos + libs/constrained-generators + libs/non-integral + libs/set-algebra + libs/small-steps + libs/vector-map diff --git a/ouroboros-consensus-cardano/changelog.d/20250130_093803_tdammers_mlocked_kes_rebase.md b/ouroboros-consensus-cardano/changelog.d/20250130_093803_tdammers_mlocked_kes_rebase.md new file mode 100644 index 0000000000..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 4bcdff0c4e..ad31fbbb7b 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -129,16 +129,16 @@ library bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-crypto-wrapper, cardano-ledger-allegra ^>=1.6, cardano-ledger-alonzo ^>=1.12, cardano-ledger-api ^>=1.10, cardano-ledger-babbage ^>=1.10, - cardano-ledger-binary ^>=1.5, + cardano-ledger-binary ^>=1.6, cardano-ledger-byron ^>=1.0.1, cardano-ledger-conway ^>=1.18, - cardano-ledger-core ^>=1.16, + cardano-ledger-core ^>=1.17, cardano-ledger-mary ^>=1.7, cardano-ledger-shelley ^>=1.15, cardano-prelude, @@ -147,9 +147,10 @@ library cardano-strict-containers, cborg ^>=0.2.2, containers >=0.5 && <0.8, - cryptonite >=0.25 && <0.31, + crypton, deepseq, formatting >=6.3 && <7.3, + kes-agent, measures, microlens, mtl, @@ -159,6 +160,7 @@ library ouroboros-network-api ^>=0.12, serialise ^>=0.2, small-steps, + serdoc-core, sop-core ^>=0.5, sop-extras ^>=0.2, strict-sop-core ^>=0.1, @@ -301,7 +303,7 @@ library unstable-shelley-testlib cardano-ledger-alonzo, cardano-ledger-alonzo-test, cardano-ledger-babbage-test, - cardano-ledger-conway-test >=1.2.1, + cardano-ledger-conway-test >=1.3.0, cardano-ledger-core:{cardano-ledger-core, testlib}, cardano-ledger-mary, cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, @@ -311,6 +313,7 @@ library unstable-shelley-testlib cardano-strict-containers, containers, generic-random, + kes-agent, microlens, mtl, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, @@ -319,6 +322,7 @@ library unstable-shelley-testlib ouroboros-consensus-protocol:{ouroboros-consensus-protocol, unstable-protocol-testlib}, ouroboros-network-api, quiet ^>=0.2, + serdoc-core, small-steps, test-suite shelley-test @@ -557,6 +561,7 @@ library unstable-cardano-tools ouroboros-network-framework ^>=0.16, ouroboros-network-protocols, resource-registry, + serdoc-core, serialise ^>=0.2, singletons, sop-core, diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs index 5fe214077a..bb8fe671dd 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Crypto/DSIGN.hs @@ -92,7 +92,7 @@ instance DSIGNAlgorithm ByronDSIGN where where seedBytes = case getBytesFromSeed 32 seed of Just (x,_) -> x - Nothing -> throw $ SeedBytesExhausted (-1) -- TODO We can't get the seed size! + Nothing -> throw $ SeedBytesExhausted (-1) (-1) -- TODO We can't get the seed size! deriveVerKeyDSIGN (SignKeyByronDSIGN sk) = VerKeyByronDSIGN $ toVerification sk diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index 9fb24f382d..76082e4c4e 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -140,6 +140,7 @@ byronBlockForging creds = BlockForging { slot tickedPBftState , forgeBlock = \cfg -> return ....: forgeByronBlock cfg + , finalize = pure () } where canBeLeader = mkPBftCanBeLeader creds diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index b05dfed499..0e7c1e702e 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 @@ -57,8 +57,7 @@ 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 @@ -93,10 +92,9 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run -import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..)) -import Ouroboros.Consensus.Protocol.Praos.Common - (praosCanBeLeaderOpCert) +import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..), instantiatePraosCredentials) +import Ouroboros.Consensus.Protocol.Praos.AgentClient import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..)) import qualified Ouroboros.Consensus.Protocol.TPraos as Shelley import Ouroboros.Consensus.Shelley.HFEras () @@ -106,14 +104,13 @@ import Ouroboros.Consensus.Shelley.Ledger.Block (IsShelleyBlock, ShelleyBlockLedgerEra) import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion import Ouroboros.Consensus.Shelley.Node -import Ouroboros.Consensus.Shelley.Node.Common (ShelleyEraWithCrypto, - shelleyBlockIssuerVKey) +import Ouroboros.Consensus.Shelley.Node.Common (ShelleyEraWithCrypto, shelleyBlockIssuerVKey) import qualified Ouroboros.Consensus.Shelley.Node.Praos as Praos import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Assert -import Ouroboros.Consensus.Util.IOLike + {------------------------------------------------------------------------------- SerialiseHFC -------------------------------------------------------------------------------} @@ -464,7 +461,10 @@ data CardanoProtocolParams c = CardanoProtocolParams { -- PRECONDITION: only a single set of Shelley credentials is allowed when used -- for mainnet (check against @'SL.gNetworkId' == 'SL.Mainnet'@). protocolInfoCardano :: - forall c m. (IOLike m, CardanoHardForkConstraints c) + forall c m. + ( CardanoHardForkConstraints c + , KESAgentContext c m + ) => CardanoProtocolParams c -> ( ProtocolInfo (CardanoBlock c) , m [BlockForging m (CardanoBlock c)] @@ -479,7 +479,7 @@ protocolInfoCardano paramsCardano pInfoConfig = cfg , pInfoInitLedger = initExtLedgerStateCardano } - , blockForging + , mkBlockForgings ) where CardanoProtocolParams { @@ -826,8 +826,8 @@ protocolInfoCardano paramsCardano -- credentials. If there are multiple Shelley credentials, we merge the -- Byron credentials with the first Shelley one but still have separate -- threads for the remaining Shelley ones. - blockForging :: m [BlockForging m (CardanoBlock c)] - blockForging = do + mkBlockForgings :: m [BlockForging m (CardanoBlock c)] + mkBlockForgings = do shelleyBased <- traverse blockForgingShelleyBased credssShelleyBased let blockForgings :: [NonEmptyOptNP (BlockForging m) (CardanoEras c)] blockForgings = case (mBlockForgingByron, shelleyBased) of @@ -853,24 +853,19 @@ protocolInfoCardano paramsCardano ShelleyLeaderCredentials c -> m (NonEmptyOptNP (BlockForging m) (CardanoEras c)) blockForgingShelleyBased credentials = do - let ShelleyLeaderCredentials - { shelleyLeaderCredentialsInitSignKey = initSignKey - , shelleyLeaderCredentialsCanBeLeader = canBeLeader - } = credentials - - hotKey <- do - let maxKESEvo :: Word64 - maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo - - startPeriod :: Absolute.KESPeriod - startPeriod = Absolute.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader - - HotKey.mkHotKey @m @c initSignKey startPeriod maxKESEvo + let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials let slotToPeriod :: SlotNo -> Absolute.KESPeriod slotToPeriod (SlotNo slot) = assert (tpraosSlotsPerKESPeriod == praosSlotsPerKESPeriod) $ Absolute.KESPeriod $ fromIntegral $ slot `div` praosSlotsPerKESPeriod + maxKESEvo :: Word64 + maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo + + hotKey <- instantiatePraosCredentials + maxKESEvo + (praosCanBeLeaderCredentialsSource canBeLeader) + let tpraos :: forall era. ShelleyEraWithCrypto c (TPraos c) era => BlockForging m (ShelleyBlock (TPraos c) era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs index 572ed23a4e..9683f3a0be 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs @@ -48,12 +48,7 @@ import Ouroboros.Consensus.Storage.ImmutableDB -------------------------------------------------------------------------------} data ShelleyLeaderCredentials c = ShelleyLeaderCredentials - { -- | The unevolved signing KES key (at evolution 0). - -- - -- Note that this is not inside 'ShelleyCanBeLeader' since it gets evolved - -- automatically, whereas 'ShelleyCanBeLeader' does not change. - shelleyLeaderCredentialsInitSignKey :: SL.SignKeyKES c, - shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c, + { shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c, -- | Identifier for this set of credentials. -- -- Useful when the node is running with multiple sets of credentials. diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs index 35fcbaf0ba..626d016858 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Praos.hs @@ -28,8 +28,6 @@ import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..), praosCheckCanForge) -import Ouroboros.Consensus.Protocol.Praos.Common - (PraosCanBeLeader (praosCanBeLeaderOpCert)) import Ouroboros.Consensus.Shelley.Eras (EraCrypto) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, ShelleyCompatible, forgeShelleyBlock) @@ -51,21 +49,13 @@ praosBlockForging :: , IOLike m ) => PraosParams + -> HotKey.HotKey c m -> ShelleyLeaderCredentials (EraCrypto era) - -> m (BlockForging m (ShelleyBlock (Praos c) era)) -praosBlockForging praosParams credentials = do - hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod praosMaxKESEvo - pure $ praosSharedBlockForging hotKey slotToPeriod credentials + -> BlockForging m (ShelleyBlock (Praos c) era) +praosBlockForging praosParams hotKey credentials = + praosSharedBlockForging hotKey slotToPeriod credentials where - PraosParams {praosMaxKESEvo, praosSlotsPerKESPeriod} = praosParams - - ShelleyLeaderCredentials { - shelleyLeaderCredentialsInitSignKey = initSignKey - , shelleyLeaderCredentialsCanBeLeader = canBeLeader - } = credentials - - startPeriod :: Absolute.KESPeriod - startPeriod = SL.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader + PraosParams {praosSlotsPerKESPeriod} = praosParams slotToPeriod :: SlotNo -> Absolute.KESPeriod slotToPeriod (SlotNo slot) = @@ -90,7 +80,7 @@ praosSharedBlockForging ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = canBeLeader , shelleyLeaderCredentialsLabel = label - } = do + } = BlockForging { forgeLabel = label <> "_" <> T.pack (L.eraName @era), canBeLeader = canBeLeader, @@ -105,5 +95,6 @@ praosSharedBlockForging forgeShelleyBlock hotKey canBeLeader - cfg + cfg, + finalize = HotKey.finalize hotKey } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 82e5698885..e8654532ed 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 @@ -33,9 +33,11 @@ module Ouroboros.Consensus.Shelley.Node.TPraos ( ) where import qualified Cardano.Crypto.VRF as VRF +import qualified Cardano.Crypto.KES as KES import qualified Cardano.Ledger.Api.Era as L import qualified Cardano.Ledger.Api.Transition as L import qualified Cardano.Ledger.Shelley.API as SL +import Cardano.Ledger.Crypto (KES) import qualified Cardano.Protocol.TPraos.API as SL import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) import qualified Cardano.Protocol.TPraos.OCert as SL @@ -43,6 +45,7 @@ import Cardano.Slotting.EpochInfo import Cardano.Slotting.Time (mkSlotLength) import Control.Monad.Except (Except) import Data.Bifunctor (first) +import qualified Data.SerDoc.Class as SerDoc import qualified Data.Text as T import qualified Data.Text as Text import Lens.Micro ((^.)) @@ -59,17 +62,20 @@ import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos.Common import Ouroboros.Consensus.Protocol.TPraos +import Ouroboros.Consensus.Protocol.Praos.AgentClient import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Inspect () import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () import Ouroboros.Consensus.Shelley.Node.Common (ProtocolParamsShelleyBased (..), ShelleyEraWithCrypto, - ShelleyLeaderCredentials (..), shelleyBlockIssuerVKey) + ShelleyLeaderCredentials (..), + shelleyBlockIssuerVKey) import Ouroboros.Consensus.Shelley.Node.Serialisation () import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Consensus.Util.Assert import Ouroboros.Consensus.Util.IOLike +import qualified Cardano.KESAgent.Serialization.DirectCodec as Agent {------------------------------------------------------------------------------- BlockForging @@ -88,21 +94,13 @@ shelleyBlockForging :: , IOLike m ) => TPraosParams + -> HotKey c m -> ShelleyLeaderCredentials (EraCrypto era) - -> m (BlockForging m (ShelleyBlock (TPraos c) era)) -shelleyBlockForging tpraosParams credentials = do - hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod tpraosMaxKESEvo - pure $ shelleySharedBlockForging hotKey slotToPeriod credentials + -> BlockForging m (ShelleyBlock (TPraos c) era) +shelleyBlockForging tpraosParams hotKey credentials = do + shelleySharedBlockForging hotKey slotToPeriod credentials where - TPraosParams {tpraosMaxKESEvo, tpraosSlotsPerKESPeriod} = tpraosParams - - ShelleyLeaderCredentials { - shelleyLeaderCredentialsInitSignKey = initSignKey - , shelleyLeaderCredentialsCanBeLeader = canBeLeader - } = credentials - - startPeriod :: Absolute.KESPeriod - startPeriod = SL.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader + TPraosParams {tpraosSlotsPerKESPeriod} = tpraosParams slotToPeriod :: SlotNo -> Absolute.KESPeriod slotToPeriod (SlotNo slot) = @@ -139,6 +137,7 @@ shelleySharedBlockForging hotKey slotToPeriod credentials = hotKey canBeLeader cfg + , finalize = HotKey.finalize hotKey } where ShelleyLeaderCredentials { @@ -173,8 +172,12 @@ protocolInfoShelley :: forall m c. ( IOLike m , PraosCrypto c + , AgentCrypto c , ShelleyCompatible (TPraos c) (ShelleyEra c) , TxLimits (ShelleyBlock (TPraos c) (ShelleyEra c)) + , MonadKESAgent m + , SerDoc.HasInfo (Agent.DirectCodec m) (KES.VerKeyKES (KES c)) + , SerDoc.HasInfo (Agent.DirectCodec m) (KES.SignKeyKES (KES c)) ) => SL.ShelleyGenesis c -> ProtocolParamsShelleyBased c @@ -192,11 +195,11 @@ protocolInfoShelley shelleyGenesis protocolInfoTPraosShelleyBased :: forall m era c. - ( IOLike m - , PraosCrypto c + ( PraosCrypto c , ShelleyCompatible (TPraos c) era , TxLimits (ShelleyBlock (TPraos c) era) , c ~ EraCrypto era + , KESAgentContext c m ) => ProtocolParamsShelleyBased c -> L.TransitionConfig era @@ -216,11 +219,20 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased { pInfoConfig = topLevelConfig , pInfoInitLedger = initExtLedgerState } - , traverse - (shelleyBlockForging tpraosParams) - credentialss + , traverse mkBlockForging credentialss ) where + mkBlockForging :: ShelleyLeaderCredentials c -> m (BlockForging m (ShelleyBlock (TPraos c) era)) + mkBlockForging credentials = do + let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials + + hotKey :: HotKey c m <- + instantiatePraosCredentials + (tpraosMaxKESEvo tpraosParams) + (praosCanBeLeaderCredentialsSource canBeLeader) + + return $ shelleyBlockForging tpraosParams hotKey credentials + genesis :: SL.ShelleyGenesis c genesis = transitionCfg ^. L.tcShelleyGenesisL diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 0b2045dd7c..c6f81b9aa0 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -66,6 +66,7 @@ dualByronBlockForging creds = BlockForging { fmap castForgeStateUpdateInfo .: updateForgeState (dualTopLevelConfigMain cfg) , checkCanForge = checkCanForge . dualTopLevelConfigMain , forgeBlock = return .....: forgeDualByronBlock + , finalize = return () } where BlockForging {..} = byronBlockForging creds diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs index e3943da9f6..53eaa9ca97 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 @@ -21,6 +21,7 @@ module Test.Consensus.Cardano.ProtocolInfo ( , protocolVersionZero ) where +import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentContext) import qualified Cardano.Chain.Genesis as CC.Genesis import qualified Cardano.Chain.Update as CC.Update import Cardano.Ledger.Api.Era (StandardCrypto) @@ -50,7 +51,6 @@ import Ouroboros.Consensus.Protocol.PBFT (PBftParams, import Ouroboros.Consensus.Shelley.Node (ProtocolParamsShelleyBased (..), ShelleyGenesis, ShelleyLeaderCredentials) -import Ouroboros.Consensus.Util.IOLike (IOLike) import qualified Test.Cardano.Ledger.Alonzo.Examples.Consensus as SL import qualified Test.Cardano.Ledger.Conway.Examples.Consensus as SL import qualified Test.ThreadNet.Infra.Byron as Byron @@ -214,7 +214,10 @@ mkSimpleTestProtocolInfo -- mkTestProtocolInfo :: forall m c - . (CardanoHardForkConstraints c, IOLike m, c ~ StandardCrypto) + . ( CardanoHardForkConstraints c + , KESAgentContext c m + , c ~ StandardCrypto + ) => (CoreNodeId, Shelley.CoreNode c) -- ^ Id of the node for which the protocol info will be elaborated. -> ShelleyGenesis c 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 6f12f3d9b6..aa8ac2e578 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 @@ -56,13 +56,14 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Node import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentContext) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Node +import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (eitherToMaybe) -import Ouroboros.Consensus.Util.IOLike (IOLike) import Test.ThreadNet.TxGen import Test.ThreadNet.TxGen.Shelley () @@ -265,7 +266,9 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 protocolInfoShelleyBasedHardFork :: forall m proto1 era1 proto2 era2. - (IOLike m, ShelleyBasedHardForkConstraints proto1 era1 proto2 era2) + ( KESAgentContext (ProtoCrypto proto2) m + , ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 + ) => ProtocolParamsShelleyBased (EraCrypto era1) -> SL.ProtVer -> SL.ProtVer diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs index 6322d3aa3d..559035aebc 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs @@ -9,7 +9,6 @@ module Cardano.Api.Key ( , CastSigningKeyRole (..) , CastVerificationKeyRole (..) , Key (..) - , generateSigningKey ) where import Cardano.Api.Any @@ -51,16 +50,17 @@ class (Eq (VerificationKey keyrole), verificationKeyHash :: VerificationKey keyrole -> Hash keyrole --- TODO: We should move this into the Key type class, with the existing impl as the default impl. --- For KES we can then override it to keep the seed and key in mlocked memory at all times. --- | Generate a 'SigningKey' using a seed from operating system entropy. --- -generateSigningKey :: Key keyrole => AsType keyrole -> IO (SigningKey keyrole) -generateSigningKey keytype = do - seed <- Crypto.readSeedFromSystemEntropy seedSize - return $! deterministicSigningKey keytype seed - where - seedSize = deterministicSigningKeySeedSize keytype + -- | Generate a 'SigningKey' using a seed from operating system entropy. + generateSigningKey :: AsType keyrole -> IO (SigningKey keyrole) + generateSigningKey keytype = do + -- + -- For KES we can override this to keep the seed and key in mlocked memory + -- at all times. + -- + seed <- Crypto.readSeedFromSystemEntropy seedSize + return $! deterministicSigningKey keytype seed + where + seedSize = deterministicSigningKeySeedSize keytype instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs index 153f0a3cd5..e852db11aa 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs @@ -14,7 +14,7 @@ -- module Cardano.Api.KeysPraos ( -- * Key types - KesKey + UnsoundPureKesKey , VrfKey -- * Data family instances , AsType (..) @@ -31,7 +31,7 @@ import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.KES.Class as Crypto import qualified Cardano.Crypto.VRF.Class as Crypto -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (Crypto(..), StandardCrypto) import qualified Cardano.Ledger.Crypto as Shelley (KES, VRF) import qualified Cardano.Ledger.Keys as Shelley import Data.String (IsString (..)) @@ -40,95 +40,95 @@ import Data.String (IsString (..)) -- KES keys -- -data KesKey +data UnsoundPureKesKey -instance HasTypeProxy KesKey where - data AsType KesKey = AsKesKey - proxyToAsType _ = AsKesKey +instance HasTypeProxy UnsoundPureKesKey where + data AsType UnsoundPureKesKey = AsUnsoundPureKesKey + proxyToAsType _ = AsUnsoundPureKesKey -instance Key KesKey where +instance Key UnsoundPureKesKey where - newtype VerificationKey KesKey = + newtype VerificationKey UnsoundPureKesKey = KesVerificationKey (Shelley.VerKeyKES StandardCrypto) deriving stock (Eq) - deriving (Show, IsString) via UsingRawBytesHex (VerificationKey KesKey) + deriving (Show, IsString) via UsingRawBytesHex (VerificationKey UnsoundPureKesKey) deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) deriving anyclass SerialiseAsCBOR - newtype SigningKey KesKey = - KesSigningKey (Shelley.SignKeyKES StandardCrypto) - deriving (Show, IsString) via UsingRawBytesHex (SigningKey KesKey) - deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) - deriving anyclass SerialiseAsCBOR + newtype SigningKey UnsoundPureKesKey = + KesSigningKey (Crypto.UnsoundPureSignKeyKES (KES StandardCrypto)) + deriving (Show, IsString) via UsingRawBytesHex (SigningKey UnsoundPureKesKey) + deriving newtype (ToCBOR, FromCBOR) + deriving anyclass (EncCBOR, DecCBOR, SerialiseAsCBOR) --This loses the mlock safety of the seed, since it starts from a normal in-memory seed. - deterministicSigningKey :: AsType KesKey -> Crypto.Seed -> SigningKey KesKey - deterministicSigningKey AsKesKey = - KesSigningKey . Crypto.genKeyKES + deterministicSigningKey :: AsType UnsoundPureKesKey -> Crypto.Seed -> SigningKey UnsoundPureKesKey + deterministicSigningKey AsUnsoundPureKesKey = + KesSigningKey . Crypto.unsoundPureGenKeyKES - deterministicSigningKeySeedSize :: AsType KesKey -> Word - deterministicSigningKeySeedSize AsKesKey = + deterministicSigningKeySeedSize :: AsType UnsoundPureKesKey -> Word + deterministicSigningKeySeedSize AsUnsoundPureKesKey = Crypto.seedSizeKES proxy where proxy :: Proxy (Shelley.KES StandardCrypto) proxy = Proxy - getVerificationKey :: SigningKey KesKey -> VerificationKey KesKey + getVerificationKey :: SigningKey UnsoundPureKesKey -> VerificationKey UnsoundPureKesKey getVerificationKey (KesSigningKey sk) = - KesVerificationKey (Crypto.deriveVerKeyKES sk) + KesVerificationKey (Crypto.unsoundPureDeriveVerKeyKES sk) - verificationKeyHash :: VerificationKey KesKey -> Hash KesKey + verificationKeyHash :: VerificationKey UnsoundPureKesKey -> Hash UnsoundPureKesKey verificationKeyHash (KesVerificationKey vkey) = - KesKeyHash (Crypto.hashVerKeyKES vkey) + UnsoundPureKesKeyHash (Crypto.hashVerKeyKES vkey) -instance SerialiseAsRawBytes (VerificationKey KesKey) where +instance SerialiseAsRawBytes (VerificationKey UnsoundPureKesKey) where serialiseToRawBytes (KesVerificationKey vk) = Crypto.rawSerialiseVerKeyKES vk - deserialiseFromRawBytes (AsVerificationKey AsKesKey) bs = + deserialiseFromRawBytes (AsVerificationKey AsUnsoundPureKesKey) bs = KesVerificationKey <$> Crypto.rawDeserialiseVerKeyKES bs -instance SerialiseAsRawBytes (SigningKey KesKey) where +instance SerialiseAsRawBytes (SigningKey UnsoundPureKesKey) where serialiseToRawBytes (KesSigningKey sk) = - Crypto.rawSerialiseSignKeyKES sk + Crypto.rawSerialiseUnsoundPureSignKeyKES sk - deserialiseFromRawBytes (AsSigningKey AsKesKey) bs = - KesSigningKey <$> Crypto.rawDeserialiseSignKeyKES bs + deserialiseFromRawBytes (AsSigningKey AsUnsoundPureKesKey) bs = + KesSigningKey <$> Crypto.rawDeserialiseUnsoundPureSignKeyKES bs -instance SerialiseAsBech32 (VerificationKey KesKey) where +instance SerialiseAsBech32 (VerificationKey UnsoundPureKesKey) where bech32PrefixFor _ = "kes_vk" bech32PrefixesPermitted _ = ["kes_vk"] -instance SerialiseAsBech32 (SigningKey KesKey) where +instance SerialiseAsBech32 (SigningKey UnsoundPureKesKey) where bech32PrefixFor _ = "kes_sk" bech32PrefixesPermitted _ = ["kes_sk"] -newtype instance Hash KesKey = - KesKeyHash (Shelley.Hash StandardCrypto +newtype instance Hash UnsoundPureKesKey = + UnsoundPureKesKeyHash (Shelley.Hash StandardCrypto (Shelley.VerKeyKES StandardCrypto)) deriving stock (Eq, Ord) - deriving (Show, IsString) via UsingRawBytesHex (Hash KesKey) - deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash KesKey) + deriving (Show, IsString) via UsingRawBytesHex (Hash UnsoundPureKesKey) + deriving (ToCBOR, FromCBOR) via UsingRawBytes (Hash UnsoundPureKesKey) deriving anyclass SerialiseAsCBOR -instance SerialiseAsRawBytes (Hash KesKey) where - serialiseToRawBytes (KesKeyHash vkh) = +instance SerialiseAsRawBytes (Hash UnsoundPureKesKey) where + serialiseToRawBytes (UnsoundPureKesKeyHash vkh) = Crypto.hashToBytes vkh - deserialiseFromRawBytes (AsHash AsKesKey) bs = - KesKeyHash <$> Crypto.hashFromBytes bs + deserialiseFromRawBytes (AsHash AsUnsoundPureKesKey) bs = + UnsoundPureKesKeyHash <$> Crypto.hashFromBytes bs -instance HasTextEnvelope (VerificationKey KesKey) where +instance HasTextEnvelope (VerificationKey UnsoundPureKesKey) where textEnvelopeType _ = "KesVerificationKey_" <> fromString (Crypto.algorithmNameKES proxy) where proxy :: Proxy (Shelley.KES StandardCrypto) proxy = Proxy -instance HasTextEnvelope (SigningKey KesKey) where +instance HasTextEnvelope (SigningKey UnsoundPureKesKey) where textEnvelopeType _ = "KesSigningKey_" <> fromString (Crypto.algorithmNameKES proxy) where diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs index 9570a3175b..be6f1c9222 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs @@ -94,7 +94,7 @@ instance HasTypeProxy OperationalCertificateIssueCounter where instance HasTextEnvelope OperationalCertificate where textEnvelopeType _ = "NodeOperationalCertificate" -getHotKey :: OperationalCertificate -> VerificationKey KesKey +getHotKey :: OperationalCertificate -> VerificationKey UnsoundPureKesKey getHotKey (OperationalCertificate cert _) = KesVerificationKey $ Shelley.ocertVkHot cert getKesPeriod :: OperationalCertificate -> Word diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs index 60aa1de618..2c442cac17 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 @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Protocol/Types.hs @@ -30,13 +31,14 @@ import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo (..), 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 qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus (ShelleyBlock) 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 @@ -62,7 +64,11 @@ instance IOLike m => Protocol m ByronBlockHFC where , 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) @@ -83,6 +89,7 @@ instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlo protocolClientInfoCardano epochSlots instance ( IOLike m + , MonadKESAgent m , Consensus.LedgerSupportsProtocol (Consensus.ShelleyBlock (Consensus.TPraos StandardCrypto) (ShelleyEra StandardCrypto)) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs index fd58263650..743517cba9 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs @@ -45,7 +45,7 @@ import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Ouroboros.Consensus.Cardano as Consensus import Ouroboros.Consensus.Protocol.Praos.Common - (PraosCanBeLeader (..)) + (PraosCanBeLeader (..), PraosCredentialsSource (..)) import Ouroboros.Consensus.Shelley.Node (Nonce (..), ProtocolParamsShelleyBased (..), ShelleyGenesis (..), ShelleyLeaderCredentials (..)) @@ -170,12 +170,12 @@ opCertKesKeyCheck :: -- ^ KES key -> FilePath -- ^ Operational certificate - -> ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey KesKey) + -> ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey UnsoundPureKesKey) opCertKesKeyCheck kesFile certFile = do opCert <- firstExceptT FileError (newExceptT $ readFileTextEnvelope AsOperationalCertificate certFile) kesSKey <- - firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsKesKey) kesFile) + firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsUnsoundPureKesKey) kesFile) let opCertSpecifiedKesKeyhash = verificationKeyHash $ getHotKey opCert suppliedKesKeyHash = verificationKeyHash $ getVerificationKey kesSKey -- Specified KES key in operational certificate should match the one @@ -200,11 +200,11 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = parseShelleyCredentials :: ShelleyCredentials -> ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto) - parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = do + parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = mkPraosLeaderCredentials - <$> parseEnvelope AsOperationalCertificate scCert - <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf - <*> parseEnvelope (AsSigningKey AsKesKey) scKes + <$> parseEnvelope AsOperationalCertificate scCert + <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf + <*> parseEnvelope (AsSigningKey AsUnsoundPureKesKey) scKes readBulkFile :: Maybe FilePath @@ -228,7 +228,7 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = mkPraosLeaderCredentials :: OperationalCertificate -> SigningKey VrfKey - -> SigningKey KesKey + -> SigningKey UnsoundPureKesKey -> ShelleyLeaderCredentials StandardCrypto mkPraosLeaderCredentials (OperationalCertificate opcert (StakePoolVerificationKey vkey)) @@ -237,11 +237,10 @@ mkPraosLeaderCredentials ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { - praosCanBeLeaderOpCert = opcert, praosCanBeLeaderColdVerKey = coerceKeyRole vkey, - praosCanBeLeaderSignKeyVRF = vrfKey + praosCanBeLeaderSignKeyVRF = vrfKey, + praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound opcert kesKey }, - shelleyLeaderCredentialsInitSignKey = kesKey, shelleyLeaderCredentialsLabel = "Shelley" } diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index cc88fbd694..1a7e18addd 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -23,6 +23,7 @@ import Data.Aeson as Aeson (FromJSON, Result (..), Value, import Data.Bool (bool) import Data.ByteString as BS (ByteString, readFile) import qualified Data.Set as Set +import qualified Ouroboros.Consensus.Block.Forging as BlockForging import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.Config (TopLevelConfig, configStorage) @@ -134,7 +135,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir (Node.stdMkChainDbHasFS confDbDir) $ ChainDB.defaultArgs - forgers <- blockForging + (_, forgers) <- allocate registry (const $ mkForgers) (mapM_ BlockForging.finalize) let fCount = length forgers putStrLn $ "--> forger count: " ++ show fCount if fCount > 0 @@ -163,9 +164,10 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir { pInfoConfig , pInfoInitLedger } - , blockForging + , mkForgers ) = protocolInfoCardano runP + preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () preOpenChainDB mode db = doesDirectoryExist db >>= bool create checkMode diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs index c438a4f38e..9489f662ac 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 @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -27,12 +28,16 @@ import Control.State.Transition.Extended (PredicateFailure) 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 (EraCrypto, ShelleyEra) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, ShelleyCompatible) import qualified Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes as SL (Mock) import Test.QuickCheck (Arbitrary) +import qualified Cardano.KESAgent.KES.Crypto as Agent +import qualified Cardano.KESAgent.Protocols.VersionedProtocol as Agent +import qualified Cardano.KESAgent.Processes.ServiceClient as Agent -- | A mock replacement for 'StandardCrypto' -- @@ -76,3 +81,16 @@ type CanMock proto era = , Arbitrary (StashedAVVMAddresses era) , Arbitrary (Core.GovState era) ) + +instance Agent.NamedCrypto (MockCrypto h) where + cryptoName _ = Agent.CryptoName "Mock" + +instance Agent.ServiceClientDrivers (MockCrypto h) where + availableServiceClientDrivers = [] + +instance Agent.Crypto (MockCrypto h) where + type KES (MockCrypto h) = MockKES 10 + type DSIGN (MockCrypto h) = MockDSIGN + +instance HashAlgorithm h => AgentCrypto (MockCrypto h) where + type ACrypto (MockCrypto h) = MockCrypto h diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index b67594b964..ac524d06fa 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs @@ -37,7 +37,9 @@ module Test.ThreadNet.Infra.Shelley ( import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), seedSizeDSIGN) import Cardano.Crypto.Hash (HashAlgorithm) -import Cardano.Crypto.KES (KESAlgorithm (..)) +import Cardano.Crypto.KES (UnsoundPureSignKeyKES, KESAlgorithm (..), + UnsoundPureKESAlgorithm (..), + seedSizeKES, unsoundPureGenKeyKES, unsoundPureDeriveVerKeyKES) import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Cardano.Crypto.Seed as Cardano.Crypto import Cardano.Crypto.VRF (SignKeyVRF, deriveVerKeyVRF, genKeyVRF, @@ -78,8 +80,10 @@ import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (PraosCanBeLeader), - praosCanBeLeaderColdVerKey, praosCanBeLeaderOpCert, - praosCanBeLeaderSignKeyVRF) + praosCanBeLeaderColdVerKey, + praosCanBeLeaderSignKeyVRF, + praosCanBeLeaderCredentialsSource, + PraosCredentialsSource (..)) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyEra) import Ouroboros.Consensus.Shelley.Ledger (GenTx (..), @@ -87,7 +91,6 @@ import Ouroboros.Consensus.Shelley.Ledger (GenTx (..), mkShelleyTx) import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Util.Assert -import Ouroboros.Consensus.Util.IOLike import Quiet (Quiet (..)) import qualified Test.Cardano.Ledger.Core.KeyPair as TL (KeyPair (..), mkWitnessesVKey) @@ -97,6 +100,7 @@ import Test.QuickCheck import Test.Util.Orphans.Arbitrary () import Test.Util.Slots (NumSlots (..)) import Test.Util.Time (dawnOfTime) +import Ouroboros.Consensus.Protocol.Praos.AgentClient (KESAgentContext) {------------------------------------------------------------------------------- The decentralization parameter @@ -138,7 +142,7 @@ data CoreNode c = CoreNode { -- ^ The hash of the corresponding verification (public) key will be -- used as the staking credential. , cnVRF :: !(SL.SignKeyVRF c) - , cnKES :: !(SL.SignKeyKES c) + , cnKES :: !(UnsoundPureSignKeyKES (KES c)) , cnOCert :: !(SL.OCert c) } @@ -180,8 +184,8 @@ genCoreNode startKESPeriod = do delKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN c))) stkKey <- genKeyDSIGN <$> genSeed (seedSizeDSIGN (Proxy @(DSIGN c))) vrfKey <- genKeyVRF <$> genSeed (seedSizeVRF (Proxy @(VRF c))) - kesKey <- genKeyKES <$> genSeed (seedSizeKES (Proxy @(KES c))) - let kesPub = deriveVerKeyKES kesKey + kesKey <- unsoundPureGenKeyKES <$> genSeed (seedSizeKES (Proxy @(KES c))) + let kesPub = unsoundPureDeriveVerKeyKES kesKey sigma = LK.signedDSIGN @c delKey @@ -212,9 +216,8 @@ genCoreNode startKESPeriod = do mkLeaderCredentials :: PraosCrypto c => CoreNode c -> ShelleyLeaderCredentials c mkLeaderCredentials CoreNode { cnDelegateKey, cnVRF, cnKES, cnOCert } = ShelleyLeaderCredentials { - shelleyLeaderCredentialsInitSignKey = cnKES - , shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { - praosCanBeLeaderOpCert = cnOCert + shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { + praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound cnOCert cnKES , praosCanBeLeaderColdVerKey = SL.VKey $ deriveVerKeyDSIGN cnDelegateKey , praosCanBeLeaderSignKeyVRF = cnVRF } @@ -405,7 +408,10 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = mkProtocolShelley :: forall m c. - (IOLike m, PraosCrypto c, ShelleyCompatible (TPraos c) (ShelleyEra c)) + ( KESAgentContext c m + , PraosCrypto c + , ShelleyCompatible (TPraos c) (ShelleyEra c) + ) => ShelleyGenesis c -> SL.Nonce -> ProtVer @@ -421,6 +427,7 @@ mkProtocolShelley genesis initialNonce protVer coreNode = , shelleyBasedLeaderCredentials = [mkLeaderCredentials coreNode] } protVer + {------------------------------------------------------------------------------- Necessary transactions for updating the 'DecentralizationParam' -------------------------------------------------------------------------------} 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 f0dccc8304..58ca2487cb 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs @@ -51,9 +51,9 @@ 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 (KESAgentContext) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.Node -import Ouroboros.Consensus.Util.IOLike (IOLike) import Test.Consensus.Cardano.ProtocolInfo (hardForkOnDefaultProtocolVersions, mkTestProtocolInfo) import Test.QuickCheck @@ -434,7 +434,7 @@ prop_simple_cardano_convergence TestSetup property $ maxRollbacks setupK >= finalIntersectionDepth mkProtocolCardanoAndHardForkTxs :: - forall c m. (IOLike m, c ~ StandardCrypto) + forall c m. (KESAgentContext c m, c ~ StandardCrypto) -- Byron => PBftParams -> CoreNodeId 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..44c5f98e69 --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20250130_100651_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,3 @@ +### Non-Breaking + +- Ensure that block forging threads finalize their keys when shutting down. diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index a765dfacc7..022c6b776e 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -91,6 +91,7 @@ library mtl, network-mux ^>=0.6, ouroboros-consensus ^>=0.22, + ouroboros-consensus-protocol ^>=0.10, ouroboros-network ^>=0.19.0.2, ouroboros-network-api ^>=0.12, ouroboros-network-framework ^>=0.16, @@ -143,6 +144,7 @@ library unstable-diffusion-testlib io-sim, mtl, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, + ouroboros-consensus-protocol, ouroboros-consensus-diffusion, ouroboros-network, ouroboros-network-api, @@ -174,8 +176,8 @@ library unstable-mock-testlib QuickCheck, base, bytestring, - cardano-crypto-class, - cardano-crypto-tests, + cardano-crypto-class ^>= 2.2, + cardano-crypto-tests ^>= 2.2, containers, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib, unstable-mock-block}, ouroboros-network-protocols:testlib, @@ -281,7 +283,7 @@ test-suite consensus-test base, binary, bytestring, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-slotting:{cardano-slotting, testlib}, cardano-strict-containers, containers, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index 9b5a6eb8db..31da10d2b8 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 @@ -38,6 +38,7 @@ import Ouroboros.Consensus.MiniProtocol.ChainSync.Server 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, TraceLabelPeer) @@ -74,6 +75,7 @@ data Tracers' remotePeer localPeer blk f = Tracers , gddTracer :: f (TraceGDDEvent remotePeer blk) , csjTracer :: f (TraceLabelPeer remotePeer (CSJumping.TraceEventCsj remotePeer blk)) , dbfTracer :: f (CSJumping.TraceEventDbf remotePeer) + , kesAgentTracer :: f KESAgentClientTrace } instance (forall a. Semigroup (f a)) @@ -99,6 +101,7 @@ instance (forall a. Semigroup (f a)) , gddTracer = f gddTracer , csjTracer = f csjTracer , dbfTracer = f dbfTracer + , kesAgentTracer = f kesAgentTracer } where f :: forall a. Semigroup a @@ -132,6 +135,7 @@ nullTracers = Tracers , gddTracer = nullTracer , csjTracer = nullTracer , dbfTracer = nullTracer + , kesAgentTracer = nullTracer } showTracers :: ( Show blk @@ -168,6 +172,7 @@ showTracers tr = Tracers , 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 7f1396e82a..f9a4b96c39 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -435,10 +435,13 @@ forkBlockForging :: -> BlockForging m blk -> m (Thread m Void) forkBlockForging IS{..} blockForging = - forkLinkedWatcher registry threadLabel - $ knownSlotWatcher btime - $ withEarlyExit_ . go + forkLinkedWatcherFinalize registry threadLabel + watcher + (finalize blockForging) where + watcher :: Watcher m SlotNo SlotNo + watcher = knownSlotWatcher btime $ withEarlyExit_ . go + threadLabel :: String threadLabel = "NodeKernel.blockForging." <> Text.unpack (forgeLabel blockForging) diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs index 95008ef9ef..0b5f3ff783 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 @@ -52,13 +52,14 @@ 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 import Ouroboros.Consensus.Util.Enclose (pattern FallingEdge) -import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.RedundantConstraints +import Ouroboros.Consensus.Util.IOLike import qualified Ouroboros.Network.Mock.Chain as MockChain import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS (MockFS) @@ -206,7 +207,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 { numCoreNodes diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index d7dd9e75cc..0e39141e9b 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -63,6 +63,7 @@ import Network.TypedProtocol.Codec (AnyMessage (..), CodecFailure, mapFailureCodec) import qualified Network.TypedProtocol.Codec as Codec import Ouroboros.Consensus.Block +import qualified Ouroboros.Consensus.Block.Forging as BlockForging import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract @@ -802,7 +803,7 @@ runThreadNetwork systemTime ThreadNetworkArgs -> m ( NodeKernel m NodeId Void blk , LimitedApp m NodeId blk ) - forkNode coreNodeId clock joinSlot registry pInfo blockForging nodeInfo txs0 = do + forkNode coreNodeId clock joinSlot registry pInfo mkBlockForging nodeInfo txs0 = do let ProtocolInfo{..} = pInfo let NodeInfo @@ -1042,9 +1043,9 @@ runThreadNetwork systemTime ThreadNetworkArgs nodeKernel <- initNodeKernel nodeKernelArgs - blockForging' <- - map (\bf -> bf { forgeBlock = customForgeBlock bf }) - <$> blockForging + (_, blockForging) <- allocate registry (const mkBlockForging) (mapM_ BlockForging.finalize) + let blockForging' = + map (\bf -> bf { forgeBlock = customForgeBlock bf }) blockForging setBlockForging nodeKernel blockForging' let mempool = getMempool nodeKernel diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 4aa3b65074..6155b3fcb5 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -292,6 +292,7 @@ blockForgingA = BlockForging { , checkCanForge = \_ _ _ _ _ -> return () , forgeBlock = \cfg bno slot st txs proof -> return $ forgeBlockA cfg bno slot st (fmap txForgetValidated txs) proof + , finalize = return () } -- | See 'Ouroboros.Consensus.HardFork.History.EraParams.safeFromTip' diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 7c45c64137..e58145554a 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -240,6 +240,7 @@ blockForgingB = BlockForging { , checkCanForge = \_ _ _ _ _ -> return () , forgeBlock = \cfg bno slot st txs proof -> return $ forgeBlockB cfg bno slot st (fmap txForgetValidated txs) proof + , finalize = return () } -- | A basic 'History.SafeZone' diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs index d65cddcc3a..35b3883722 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs @@ -49,7 +49,7 @@ data TestSetup = TestSetup genEvolvingStake :: EpochSize -> TestConfig -> Gen PraosEvolvingStake genEvolvingStake epochSize TestConfig {numSlots, numCoreNodes} = do - chosenEpochs <- sublistOf [0..EpochNo $ max 1 maxEpochs - 1] + chosenEpochs <- sublistOf [EpochNo 0..EpochNo $ max 1 maxEpochs - 1] let l = fromIntegral maxEpochs stakeDists <- replicateM l genStakeDist return . PraosEvolvingStake . Map.fromList $ zip chosenEpochs stakeDists diff --git a/ouroboros-consensus-protocol/changelog.d/20250130_101128_tdammers_mlocked_kes_rebase.md b/ouroboros-consensus-protocol/changelog.d/20250130_101128_tdammers_mlocked_kes_rebase.md new file mode 100644 index 0000000000..804067168e --- /dev/null +++ b/ouroboros-consensus-protocol/changelog.d/20250130_101128_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,18 @@ +### Breaking + +- Use new mlocked KES API for all internal KES sign key handling. +- Add finalizers to all block forgings (required by `ouroboros-consensus`). +- Change `HotKey` to manage not only KES sign keys, but also the corresponding + OpCerts. This is in preparation for KES agent connectivity: with the new + design, the KES agent will provide both KES sign keys and matching OpCerts + together, and we need to be able to dynamically replace them both together. +- Add finalizer to `HotKey`. This takes care of securely forgetting any KES + keys the HotKey may still hold, and will be called automatically when the + owning block forging terminates. +- Change `PraosCanBeLeader` to not contain the KES sign key itself anymore. + Instead, it now contains a `PraosCredentialsSource` field, which + specifies how to obtain the actual credentials (OpCert and KES SignKey). For + now, the only supported method is passing an OpCert and an + UnsoundPureSignKeyKES, presumably loaded from disk + (`PraosCredentialsUnsound`); future iterations will add support for + connecting to a KES agent. diff --git a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal index 9725c76e0b..e7a1be7396 100644 --- a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal +++ b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal @@ -57,6 +57,7 @@ library Ouroboros.Consensus.Protocol.Ledger.Util Ouroboros.Consensus.Protocol.Praos Ouroboros.Consensus.Protocol.Praos.Common + Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Header Ouroboros.Consensus.Protocol.Praos.VRF Ouroboros.Consensus.Protocol.Praos.Views @@ -66,7 +67,7 @@ library base >=4.14 && <4.21, bytestring, cardano-binary, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-ledger-binary, cardano-ledger-core, cardano-ledger-shelley, @@ -74,11 +75,20 @@ library cardano-slotting, cborg, containers, + contra-tracer ^>=0.1.0, + io-classes ^>=1.5.0, + io-sim, + kes-agent, mtl, + network ^>=3.1.4.0, nothunks, ouroboros-consensus ^>=0.22, + ouroboros-network-framework ^>=0.16, + ouroboros-network-testing ^>=0.8, serialise, + serdoc-core, text, + Win32-network ^>=0.2, library unstable-protocol-testlib import: common-lib @@ -94,9 +104,9 @@ library unstable-protocol-testlib base, base16-bytestring, bytestring, - cardano-crypto-class, - cardano-crypto-praos, - cardano-crypto-tests, + cardano-crypto-class ^>= 2.2, + cardano-crypto-praos ^>= 2.2, + cardano-crypto-tests ^>= 2.2, cardano-ledger-binary, cardano-ledger-core, cardano-ledger-shelley-test, @@ -117,9 +127,9 @@ test-suite protocol-test build-depends: QuickCheck, base, - cardano-crypto-class, + cardano-crypto-class ^>= 2.2, cardano-ledger-binary:testlib, - cardano-ledger-core ^>=1.16, + cardano-ledger-core ^>=1.17, containers, ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib}, ouroboros-consensus-protocol, diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs index 8a46088450..3878dfb826 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Ledger/HotKey.hs @@ -1,9 +1,13 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -- | Hot key -- @@ -18,21 +22,29 @@ module Ouroboros.Consensus.Protocol.Ledger.HotKey ( , kesStatus -- * Hot Key , HotKey (..) + , finalize + , getOCert , KESEvolutionError (..) , KESEvolutionInfo , mkHotKey + , mkHotKeyAtEvolution + , mkEmptyHotKey + , mkDynamicHotKey , sign ) where import qualified Cardano.Crypto.KES as Relative (Period) -import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Crypto (Crypto (..)) import qualified Cardano.Ledger.Keys as SL +import qualified Cardano.Protocol.TPraos.OCert as OCert import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block.Forging (UpdateInfo (..)) import Ouroboros.Consensus.Util.IOLike +import NoThunks.Class (OnlyCheckWhnfNamed (..)) +import Control.Monad (forM_) {------------------------------------------------------------------------------- KES Info @@ -126,19 +138,52 @@ data HotKey c m = HotKey { -- -- When the key cannot evolve anymore, we poison it. evolve :: Absolute.KESPeriod -> m KESEvolutionInfo + -- | Return 'KESInfo' of the signing key. , getInfo :: m KESInfo - -- | Return 'True' when the signing key is poisoned because it expired. + + -- | Return the 'OCert' corresponding to the KES signing key, if any. + , getOCertMaybe :: m (Maybe (OCert.OCert c)) + + -- | Check whether a valid KES signing key exists. "Poisoned" means no + -- key exists; reasons for this could be: + -- - no signing key has been set yet + -- - the signing key has been explicitly erased ('forget') + -- - the signing key has been evolved past the end of the available + -- evolutions , isPoisoned :: m Bool + -- | Sign the given @toSign@ with the current signing key. -- -- PRECONDITION: the key is not poisoned. -- -- POSTCONDITION: the signature is in normal form. , sign_ :: forall toSign. (SL.KESignable c toSign, HasCallStack) - => toSign -> m (SL.SignedKES c toSign) + => toSign + -> m (SL.SignedKES c toSign) + + -- | Securely erase the key and release its memory. + , forget :: m () + + -- | Release any resources held by the 'HotKey', except for the signing + -- key itself. User code should use 'finalize' instead. + , finalize_ :: m () } +-- | 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 :: (SL.KESignable c toSign, HasCallStack) => HotKey c m @@ -148,7 +193,7 @@ sign = sign_ -- | The actual KES key, unless it expired, in which case it is replaced by -- \"poison\". data KESKey c = - KESKey !(SL.SignKeyKES c) + KESKey !(OCert.OCert c) !(SL.SignKeyKES c) | KESKeyPoisoned deriving (Generic) @@ -156,7 +201,7 @@ instance Crypto c => NoThunks (KESKey c) kesKeyIsPoisoned :: KESKey c -> Bool kesKeyIsPoisoned KESKeyPoisoned = True -kesKeyIsPoisoned (KESKey _) = False +kesKeyIsPoisoned (KESKey _ _) = False data KESState c = KESState { kesStateInfo :: !KESInfo @@ -166,42 +211,145 @@ data KESState c = KESState { instance Crypto c => NoThunks (KESState c) +-- Create a new 'HotKey' and initialize it to the given initial KES key. The +-- initial key must be at evolution 0 (i.e., freshly generated and never +-- evolved). mkHotKey :: forall m c. (Crypto c, IOLike m) - => SL.SignKeyKES c + => OCert.OCert c + -> SL.SignKeyKES c -> Absolute.KESPeriod -- ^ Start period -> Word64 -- ^ Max KES evolutions -> m (HotKey c m) -mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do +mkHotKey = 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 + -> SL.SignKeyKES c + -> Absolute.KESPeriod -- ^ Start period + -> Word64 -- ^ Max KES evolutions + -> m (HotKey c m) +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) + => Word64 -- ^ Max KES evolutions + -> m () + -> m (HotKey c m) +mkEmptyHotKey maxKESEvolutions = + mkDynamicHotKey maxKESEvolutions Nothing + +mkKESState :: Word64 -> OCert.OCert c -> SL.SignKeyKES 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 + } + +-- | 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) + => Word64 -- ^ Max KES evolutions + -> Maybe ( + (OCert.OCert c -> SL.SignKeyKES c -> Word -> Absolute.KESPeriod -> m ()) + -> 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, SL.SignKeyKES c, Word, Absolute.KESPeriod) + -> Word64 -- ^ Max KES evolutions + -> Maybe ( + (OCert.OCert c -> SL.SignKeyKES c -> Word -> Absolute.KESPeriod -> m ()) + -> 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 + + 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 + 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 = SL.signedKES () evolution toSign key - -- Force the signature to WHNF (for 'SignedKES', WHNF implies - -- NF) so that we don't have any thunks holding on to a key that - -- might be destructively updated when evolved. - evaluate signed + withMVar varKESState $ \KESState { kesStateInfo, kesStateKey } -> do + case kesStateKey of + KESKeyPoisoned -> + error "trying to sign with a poisoned key" + KESKey _ key -> do + let evolution = kesEvolution kesStateInfo + SL.signedKES () evolution toSign key + , forget = do + modifyMVar_ varKESState $ poisonState + , finalize_ = finalizer' } where initKESState :: KESState c initKESState = KESState { kesStateInfo = KESInfo { - kesStartPeriod = startPeriod - , kesEndPeriod = Absolute.KESPeriod (start + fromIntegral maxKESEvolutions) - -- We always start from 0 as the key hasn't evolved yet. + kesStartPeriod = Absolute.KESPeriod 0 + , kesEndPeriod = Absolute.KESPeriod 0 , kesEvolution = 0 } - , kesStateKey = KESKey initKey + , kesStateKey = KESKeyPoisoned } +poisonState :: forall m c. (Crypto c, IOLike m) + => KESState c -> m (KESState c) +poisonState kesState = do + case kesStateKey kesState of + KESKeyPoisoned -> do + -- already poisoned + return kesState + KESKey _ sk -> do + forgetSignKeyKES sk + return kesState { kesStateKey = KESKeyPoisoned } + -- | Evolve the 'HotKey' so that its evolution matches the given KES period. -- -- When the given KES period is after the end period of the 'HotKey', we @@ -230,7 +378,7 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do let err = KESKeyAlreadyPoisoned info targetPeriod in return (kesState, UpdateFailed err) - KESKey key -> case kesStatus info targetPeriod of + KESKey ocert key -> case kesStatus info targetPeriod of -- When the absolute period is before the start period, we can't -- update the key. 'checkCanForge' will say we can't forge because the -- key is not valid yet. @@ -239,9 +387,10 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do -- When the absolute period is after the end period, we can't evolve -- anymore and poison the expired key. - AfterKESEnd {} -> + AfterKESEnd {} -> do let err = KESCouldNotEvolve info targetPeriod - in return (poisonState kesState, UpdateFailed err) + poisonedState <- poisonState kesState + return (poisonedState, UpdateFailed err) InKESRange targetEvolution -- No evolving needed @@ -251,27 +400,27 @@ evolveKey varKESState targetPeriod = modifyMVar varKESState $ \kesState -> do -- Evolving needed | otherwise -> (\s' -> (s', Updated (kesStateInfo s'))) <$> - go targetEvolution info key + go targetEvolution info ocert key where - poisonState :: KESState c -> KESState c - poisonState kesState = kesState { kesStateKey = KESKeyPoisoned } - -- | PRECONDITION: -- -- > targetEvolution >= curEvolution - go :: KESEvolution -> KESInfo -> SL.SignKeyKES c -> m (KESState c) - go targetEvolution info key + go :: KESEvolution -> KESInfo -> OCert.OCert c -> SL.SignKeyKES c -> m (KESState c) + go targetEvolution info ocert key | targetEvolution <= curEvolution - = return $ KESState { kesStateInfo = info, kesStateKey = KESKey key } + = return $ KESState { kesStateInfo = info, kesStateKey = KESKey ocert key } | otherwise - = case SL.updateKES () key curEvolution of - -- This cannot happen - Nothing -> error "Could not update KES key" - Just !key' -> do - -- Clear the memory associated with the old key - forgetSignKeyKES key - let info' = info { kesEvolution = curEvolution + 1 } - go targetEvolution info' key' + = do + maybeKey' <- SL.updateKES () key curEvolution + case maybeKey' of + Nothing -> + -- This cannot happen + error "Could not update KES key" + Just !key' -> do + -- Clear the memory associated with the old key + forgetSignKeyKES key + let info' = info { kesEvolution = curEvolution + 1 } + go targetEvolution info' ocert key' where curEvolution = kesEvolution info diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index ce8bcdb08e..08c8f2b555 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -160,27 +160,25 @@ forgePraosFields hotKey PraosCanBeLeader { praosCanBeLeaderColdVerKey, - praosCanBeLeaderSignKeyVRF, - praosCanBeLeaderOpCert + praosCanBeLeaderSignKeyVRF } PraosIsLeader {praosIsLeaderVrfRes} mkToSign = do + ocert <- HotKey.getOCert hotKey + let signedFields = + PraosToSign + { praosToSignIssuerVK = praosCanBeLeaderColdVerKey, + praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF, + praosToSignVrfRes = praosIsLeaderVrfRes, + praosToSignOCert = ocert + } + toSign = mkToSign signedFields signature <- HotKey.sign hotKey toSign return PraosFields { praosSignature = signature, praosToSign = toSign } - where - toSign = mkToSign signedFields - - signedFields = - PraosToSign - { praosToSignIssuerVK = praosCanBeLeaderColdVerKey, - praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF, - praosToSignVrfRes = praosIsLeaderVrfRes, - praosToSignOCert = praosCanBeLeaderOpCert - } {------------------------------------------------------------------------------- Protocol proper diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/AgentClient.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/AgentClient.hs new file mode 100644 index 0000000000..8451d6aaaa --- /dev/null +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/AgentClient.hs @@ -0,0 +1,183 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +module Ouroboros.Consensus.Protocol.Praos.AgentClient ( + runKESAgentClient, + AgentCrypto (..), + MonadKESAgent (..), + KESAgentContext, + KESAgentClientTrace (..), +) +where + +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.VersionedProtocol as Agent +import qualified Cardano.KESAgent.Protocols.StandardCrypto as Agent +import qualified Cardano.KESAgent.Serialization.DirectCodec as Agent +import Cardano.KESAgent.Util.RefCounting +import qualified Cardano.Protocol.TPraos.OCert as OCert +import Cardano.Ledger.Crypto (Crypto, KES, DSIGN, VRF, StandardCrypto) + +import Cardano.Crypto.KES.Class +import Cardano.Crypto.VRF.Class +import Cardano.Crypto.DirectSerialise (DirectSerialise, DirectDeserialise) + +import Ouroboros.Network.RawBearer +import Ouroboros.Network.Snocket +import Ouroboros.Consensus.Util.IOLike + +import Control.Monad (forever) +import Control.Monad.Class.MonadAsync +import Control.Tracer +import Data.Coerce (coerce) +import Network.Socket +import System.IOManager +import Data.Typeable +import Data.Kind +import Data.SerDoc.Class as SerDoc +import Control.Monad.IOSim +import qualified Simulation.Network.Snocket as SimSnocket +import Test.Ouroboros.Network.Data.AbsBearerInfo as ABI + +type KESAgentContext c m = + ( AgentCrypto c + , MonadKESAgent m + , SerDoc.HasInfo (Agent.DirectCodec m) (VerKeyKES (KES c)) + , SerDoc.HasInfo (Agent.DirectCodec m) (SignKeyKES (KES c)) + , 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 + , Agent.DSIGN (ACrypto c) ~ DSIGN 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.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) + } + +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 + ) + => Tracer m KESAgentClientTrace + -> FilePath + -> (OCert.OCert c -> SignKeyKES (KES c) -> Word -> m ()) + -> m () +runKESAgentClient tracer path handleKey = 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.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 + 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 94241bc6c1..ff408bb582 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,9 +2,13 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Various things common to iterations of the Praos protocol. module Ouroboros.Consensus.Protocol.Praos.Common ( @@ -15,24 +19,30 @@ module Ouroboros.Consensus.Protocol.Praos.Common ( -- * node support , PraosNonces (..) , PraosProtocolSupportsNode (..) + , PraosCredentialsSource (..) + , instantiatePraosCredentials ) where import qualified Cardano.Crypto.VRF as VRF -import Cardano.Ledger.BaseTypes (Nonce) import qualified Cardano.Ledger.BaseTypes as SL -import Cardano.Ledger.Crypto (Crypto, VRF) +import qualified Cardano.Crypto.KES.Class as KES +import Cardano.Ledger.BaseTypes (Nonce) +import Cardano.Ledger.Crypto (Crypto, VRF, KES) import Cardano.Ledger.Keys (KeyHash, KeyRole (BlockIssuer)) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Block (BlockNo) import Cardano.Slotting.Slot (SlotNo) +import Control.Tracer (nullTracer) import Data.Function (on) import Data.Map.Strict (Map) import Data.Ord (Down (Down)) import Data.Word (Word64) import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Protocol.Abstract +import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey +import Ouroboros.Consensus.Protocol.Praos.AgentClient +import Ouroboros.Consensus.Util.IOLike -- | The maximum major protocol version. -- @@ -245,16 +255,57 @@ instance Crypto c => ChainOrder (PraosChainSelectView c) where preferCandidate cfg ours cand = comparePraos cfg ours cand == LT data PraosCanBeLeader c = PraosCanBeLeader - { -- | Certificate delegating rights from the stake pool cold key (or - -- genesis stakeholder delegate cold key) to the online KES key. - praosCanBeLeaderOpCert :: !(OCert.OCert c), - -- | Stake pool cold key or genesis stakeholder delegate cold key. + { -- | Stake pool cold key or genesis stakeholder delegate cold key. praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer c), - praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c) + praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c), + -- | How to obtain KES credentials (ocert + sign key) + praosCanBeLeaderCredentialsSource :: !(PraosCredentialsSource c) } deriving (Generic) -instance Crypto c => NoThunks (PraosCanBeLeader c) +instance (NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) => NoThunks (PraosCanBeLeader c) + +-- | Defines a method for obtaining Praos credentials (opcert + KES signing +-- key). +data PraosCredentialsSource c + = -- | 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)) + | -- | Connect to a KES agent listening on a service socket at the given path. + PraosCredentialsAgent FilePath + deriving (Generic) + +instance (NoThunks (KES.UnsoundPureSignKeyKES (KES c)), Crypto c) => NoThunks (PraosCredentialsSource c) + +instantiatePraosCredentials :: forall m c. + ( KESAgentContext c m + ) + => Word64 + -> 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 (PraosCredentialsAgent path) = do + HotKey.mkDynamicHotKey + maxKESEvolutions + (Just $ \send -> do + let handleKey ocert sk p = do + send ocert sk p (OCert.ocertKESPeriod ocert) + runKESAgentClient nullTracer path handleKey + ) + (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 43529217bc..43d6026f5f 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs @@ -129,21 +129,21 @@ forgeTPraosFields :: -> (TPraosToSign c -> toSign) -> m (TPraosFields c toSign) forgeTPraosFields hotKey PraosCanBeLeader{..} TPraosIsLeader{..} mkToSign = do + ocert <- HotKey.getOCert hotKey + let signedFields = + TPraosToSign { + tpraosToSignIssuerVK = praosCanBeLeaderColdVerKey + , tpraosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF + , tpraosToSignEta = tpraosIsLeaderEta + , tpraosToSignLeader = tpraosIsLeaderProof + , tpraosToSignOCert = ocert + } + toSign = mkToSign signedFields signature <- HotKey.sign hotKey toSign return TPraosFields { tpraosSignature = signature , tpraosToSign = toSign } - where - toSign = mkToSign signedFields - - signedFields = TPraosToSign { - tpraosToSignIssuerVK = praosCanBeLeaderColdVerKey - , tpraosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF - , tpraosToSignEta = tpraosIsLeaderEta - , tpraosToSignLeader = tpraosIsLeaderProof - , tpraosToSignOCert = praosCanBeLeaderOpCert - } -- | Because we are using the executable spec, rather than implementing the -- protocol directly here, we have a fixed header type rather than an diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index 7686d00a04..a17d958b84 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -6,7 +8,7 @@ -- to be semantically correct at all, only structurally correct. module Test.Consensus.Protocol.Serialisation.Generators () where -import Cardano.Crypto.KES (signedKES) +import Cardano.Crypto.KES (unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) import Cardano.Protocol.TPraos.BHeader (HashHeader, PrevHash (..)) import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod), @@ -27,7 +29,7 @@ import Test.QuickCheck (Arbitrary (..), Gen, choose, oneof) instance Arbitrary InputVRF where arbitrary = mkInputVRF <$> arbitrary <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where +instance (Praos.PraosCrypto c) => Arbitrary (HeaderBody c) where arbitrary = let ocert = OCert @@ -55,12 +57,12 @@ instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where <*> ocert <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (Header c) where +instance (Praos.PraosCrypto c) => Arbitrary (Header c) where arbitrary = do hBody <- arbitrary period <- arbitrary sKey <- arbitrary - let hSig = signedKES () period hBody sKey + let hSig = unsoundPureSignedKES () period hBody sKey pure $ Header hBody hSig instance Praos.PraosCrypto c => Arbitrary (PraosState c) where diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index 09c9f65c6e..05ff3d27a6 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -27,8 +27,6 @@ import Cardano.Crypto.DSIGN import Cardano.Crypto.Hash (Blake2b_256, Hash, hashFromBytes, hashToBytes, hashWith) import qualified Cardano.Crypto.KES as KES -import Cardano.Crypto.KES.Class (genKeyKES, rawDeserialiseSignKeyKES, - rawSerialiseSignKeyKES) import Cardano.Crypto.Seed (mkSeedFromBytes) import Cardano.Crypto.VRF (deriveVerKeyVRF, hashVerKeyVRF, rawDeserialiseSignKeyVRF, rawSerialiseSignKeyVRF) @@ -115,14 +113,14 @@ mutate context header mutation = let Header body _ = header newKESSignKey <- newKESSigningKey <$> gen32Bytes KESPeriod kesPeriod <- genValidKESPeriod (hbSlotNo body) praosSlotsPerKESPeriod - let sig' = KES.signKES () kesPeriod body newKESSignKey + let sig' = KES.unsoundPureSignKES () kesPeriod body newKESSignKey pure (context, Header body (KES.SignedKES sig')) MutateColdKey -> do let Header body _ = header newColdSignKey <- genKeyDSIGN . mkSeedFromBytes <$> gen32Bytes (hbOCert, KESPeriod kesPeriod) <- genCert (hbSlotNo body) context{coldSignKey = newColdSignKey} let newBody = body{hbOCert} - let sig' = KES.signKES () kesPeriod newBody kesSignKey + let sig' = KES.unsoundPureSignKES () kesPeriod newBody kesSignKey pure (context, Header newBody (KES.SignedKES sig')) MutateKESPeriod -> do let Header body _ = header @@ -137,7 +135,7 @@ mutate context header mutation = , ocertSigma = signedDSIGN @StandardCrypto coldSignKey (OCertSignable ocertVkHot ocertN newKESPeriod) } } - let sig' = KES.signKES () kesPeriod' newBody kesSignKey + let sig' = KES.unsoundPureSignKES () kesPeriod' newBody kesSignKey pure (context, Header newBody (KES.SignedKES sig')) MutateKESPeriodBefore -> do let Header body _ = header @@ -147,7 +145,7 @@ mutate context header mutation = period' = unSlotNo newSlotNo `div` praosSlotsPerKESPeriod hbVrfRes = VRF.evalCertified () rho' vrfSignKey newBody = body{hbSlotNo = newSlotNo, hbVrfRes} - sig' = KES.signKES () (fromIntegral period' - kesPeriod) newBody kesSignKey + sig' = KES.unsoundPureSignKES () (fromIntegral period' - kesPeriod) newBody kesSignKey pure (context, Header newBody (KES.SignedKES sig')) MutateCounterOver1 -> do let poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey @@ -255,13 +253,13 @@ instance Json.FromJSON MutatedHeader where either (fail . show) pure $ decodeFullAnnotator @(Header StandardCrypto) testVersion "Header" decCBOR $ LBS.fromStrict headerBytes -- * Generators -type KESKey = KES.SignKeyKES (KES.Sum6KES Ed25519DSIGN Blake2b_256) +type KESKey = KES.UnsoundPureSignKeyKES (KES.Sum6KES Ed25519DSIGN Blake2b_256) newVRFSigningKey :: ByteString -> (VRF.SignKeyVRF VRF.PraosVRF, VRF.VerKeyVRF VRF.PraosVRF) newVRFSigningKey = VRF.genKeyPairVRF . mkSeedFromBytes newKESSigningKey :: ByteString -> KESKey -newKESSigningKey = genKeyKES . mkSeedFromBytes +newKESSigningKey = KES.unsoundPureGenKeyKES . mkSeedFromBytes data GeneratorContext = GeneratorContext { praosSlotsPerKESPeriod :: !Word64 @@ -279,7 +277,8 @@ instance Eq GeneratorContext where a == b = praosSlotsPerKESPeriod a == praosSlotsPerKESPeriod b && praosMaxKESEvo a == praosMaxKESEvo b - && serialize' testVersion (kesSignKey a) == serialize' testVersion (kesSignKey b) + && serialize' testVersion (KES.encodeUnsoundPureSignKeyKES (kesSignKey a)) == + serialize' testVersion (KES.encodeUnsoundPureSignKeyKES (kesSignKey b)) && coldSignKey a == coldSignKey b && vrfSignKey a == vrfSignKey b && nonce a == nonce b @@ -298,7 +297,7 @@ instance Json.ToJSON GeneratorContext where , "activeSlotCoeff" .= activeSlotVal activeSlotCoeff ] where - rawKesSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyKES kesSignKey + rawKesSignKey = decodeUtf8 . Base16.encode $ KES.rawSerialiseUnsoundPureSignKeyKES kesSignKey rawColdSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyDSIGN coldSignKey rawVrfSignKey = decodeUtf8 . Base16.encode $ rawSerialiseSignKeyVRF $ skToBatchCompat vrfSignKey rawVrVKeyHash = decodeUtf8 . Base16.encode $ hashToBytes $ hashVerKeyVRF @_ @Blake2b_256 $ deriveVerKeyVRF vrfSignKey @@ -337,7 +336,7 @@ instance Json.FromJSON GeneratorContext where case Base16.decode (encodeUtf8 rawKey) of Left err -> fail err Right keyBytes -> - case rawDeserialiseSignKeyKES keyBytes of + case KES.rawDeserialiseUnsoundPureSignKeyKES keyBytes of Nothing -> fail $ "Invalid KES key bytes: " <> show rawKey Just key -> pure key parseVrfSignKey rawKey = do @@ -376,7 +375,7 @@ generated for the purpose of producing the header are returned. genHeader :: GeneratorContext -> Gen (Header StandardCrypto) genHeader context = do (body, KESPeriod kesPeriod) <- genHeaderBody context - let sign = KES.SignedKES $ KES.signKES () kesPeriod body kesSignKey + let sign = KES.SignedKES $ KES.unsoundPureSignKES () kesPeriod body kesSignKey pure $ (Header body sign) where GeneratorContext{kesSignKey} = context @@ -420,7 +419,7 @@ protocolVersionZero = ProtVer versionZero 0 genCert :: SlotNo -> GeneratorContext -> Gen (OCert StandardCrypto, KESPeriod) genCert slotNo context = do - let ocertVkHot = KES.deriveVerKeyKES kesSignKey + let ocertVkHot = KES.unsoundPureDeriveVerKeyKES kesSignKey poolId = coerce $ hashKey $ VKey $ deriveVerKeyDSIGN coldSignKey ocertN = fromMaybe 0 $ Map.lookup poolId ocertCounters ocertKESPeriod <- genValidKESPeriod slotNo praosSlotsPerKESPeriod diff --git a/ouroboros-consensus/changelog.d/20250130_093251_tdammers_mlocked_kes_rebase.md b/ouroboros-consensus/changelog.d/20250130_093251_tdammers_mlocked_kes_rebase.md new file mode 100644 index 0000000000..0aa430bf84 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250130_093251_tdammers_mlocked_kes_rebase.md @@ -0,0 +1,8 @@ +### Breaking + +- Use new mlocked KES API to represent KES sign keys internally. This ensures + that KES keys are securely erased when replaced with a newer evolution or a + fresh key, and that they will not spill to disk or swap. See + https://github.com/IntersectMBO/cardano-base/pull/255. +- Add `finalize` method to `BlockForging`, and use it where necessary to clean + up when a block forging thread terminates (see `forkLinkedWatcherFinalize`) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 749b54b134..b5f1dcd2a6 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -278,7 +278,7 @@ library bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto-class, - cardano-ledger-core ^>=1.16, + cardano-ledger-core ^>=1.17, cardano-prelude, cardano-slotting, cardano-strict-containers, @@ -471,7 +471,7 @@ library unstable-mock-block bytestring, cardano-binary, cardano-crypto-class, - cardano-slotting:{cardano-slotting, testlib}, + cardano-slotting:{cardano-slotting}, cborg, containers, deepseq, @@ -543,8 +543,8 @@ test-suite consensus-test base, base-deriving-via, cardano-binary, - cardano-crypto-class, - cardano-crypto-tests, + cardano-crypto-class ^>= 2.2, + cardano-crypto-tests ^>= 2.2, cardano-slotting:{cardano-slotting, testlib}, cborg, containers, @@ -652,8 +652,8 @@ test-suite storage-test bifunctors, binary, bytestring, - cardano-crypto-class, - cardano-slotting:{cardano-slotting, testlib}, + cardano-crypto-class ^>= 2.2, + cardano-slotting:{cardano-slotting,testlib}, cborg, containers, contra-tracer, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs index 03e5682d93..3698b362ec 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Forging.hs @@ -143,6 +143,15 @@ data BlockForging m blk = BlockForging { -> [Validated (GenTx blk)] -- Transactions to include -> IsLeader (BlockProtocol blk) -- Proof we are leader -> m blk + + -- | Clean up any unmanaged resources. + -- + -- Such resources may include KES keys that require explicit erasing + -- ("secure forgetting"), and threads that connect to a KES agent. + -- This method will be run once when the block forging thread + -- terminates, whether cleanly or due to an exception. + , finalize :: m () + } data ShouldForge blk = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index d182dbb22e..f09548067a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -417,6 +417,7 @@ instance Functor m => Isomorphic (BlockForging m) where project BlockForging {..} = BlockForging { forgeLabel = forgeLabel , canBeLeader = project' (Proxy @(WrapCanBeLeader blk)) canBeLeader + , finalize = finalize , updateForgeState = \cfg sno tickedChainDepSt -> project <$> updateForgeState @@ -464,6 +465,7 @@ instance Functor m => Isomorphic (BlockForging m) where inject BlockForging {..} = BlockForging { forgeLabel = forgeLabel , canBeLeader = inject' (Proxy @(WrapCanBeLeader blk)) canBeLeader + , finalize = finalize , updateForgeState = \cfg sno tickedChainDepSt -> inject <$> updateForgeState diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs index 5aab6219d9..6ba6aa7b3d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Forging.hs @@ -15,8 +15,11 @@ module Ouroboros.Consensus.HardFork.Combinator.Forging ( , hardForkBlockForging ) where +import Control.Monad (void) import Data.Functor.Product import Data.Maybe (fromMaybe) +import Data.SOP (Top) +import Data.SOP.Constraint (All) import Data.SOP.BasicFunctors import Data.SOP.Functors (Product2 (..)) import Data.SOP.Index @@ -90,6 +93,7 @@ hardForkBlockForging label blockForging = , updateForgeState = hardForkUpdateForgeState blockForging , checkCanForge = hardForkCheckCanForge blockForging , forgeBlock = hardForkForgeBlock blockForging + , finalize = hardForkFinalize blockForging } hardForkCanBeLeader :: @@ -99,6 +103,11 @@ hardForkCanBeLeader = SomeErasCanBeLeader . hmap (WrapCanBeLeader . canBeLeader) +hardForkFinalize :: (Monad m, All Top xs) + => NonEmptyOptNP (BlockForging m) xs -> m () +hardForkFinalize blockForging = + void $ htraverse_ finalize blockForging + -- | POSTCONDITION: the returned 'ForgeStateUpdateInfo' is from the same era as -- the ticked 'ChainDepState'. hardForkUpdateForgeState :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs index 1e951a0a37..680dbe56be 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/Jumping.hs @@ -360,9 +360,7 @@ data Instruction blk deriving instance (HasHeader (Header blk), Eq (Header blk)) => Eq (Instruction blk) deriving instance (HasHeader (Header blk), Show (Header blk)) => Show (Instruction blk) deriving anyclass instance - ( HasHeader blk, - LedgerSupportsProtocol blk, - NoThunks (Header blk) + ( LedgerSupportsProtocol blk ) => NoThunks (Instruction blk) data JumpInstruction blk @@ -382,9 +380,7 @@ instance (HasHeader (Header blk), Show (Header blk)) => Show (JumpInstruction bl showParen (p > 10) $ showString "JumpToGoodPoint " . shows (AF.headPoint $ jTheirFragment jumpInfo) deriving anyclass instance - ( HasHeader blk, - LedgerSupportsProtocol blk, - NoThunks (Header blk) + ( LedgerSupportsProtocol blk ) => NoThunks (JumpInstruction blk) -- | The result of a jump request, either accepted or rejected. @@ -397,9 +393,7 @@ deriving instance (HasHeader (Header blk), Eq (Header blk)) => Eq (JumpResult bl deriving instance (HasHeader (Header blk), Show (Header blk)) => Show (JumpResult blk) deriving anyclass instance - ( HasHeader blk, - LedgerSupportsProtocol blk, - NoThunks (Header blk) + ( LedgerSupportsProtocol blk ) => NoThunks (JumpResult blk) -- | Compute the next instruction for the given peer. In the majority of cases, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs index 6faef18cff..b9d22d8465 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs @@ -97,9 +97,7 @@ data ChainSyncClientHandle m blk = ChainSyncClientHandle { deriving anyclass instance ( IOLike m, - HasHeader blk, - LedgerSupportsProtocol blk, - NoThunks (Header blk) + LedgerSupportsProtocol blk ) => NoThunks (ChainSyncClientHandle m blk) -- | A collection of ChainSync client handles for the peers of this node. @@ -125,10 +123,8 @@ data ChainSyncClientHandleCollection peer m blk = ChainSyncClientHandleCollectio deriving anyclass instance ( IOLike m, - HasHeader blk, LedgerSupportsProtocol blk, NoThunks (STM m ()), - NoThunks (Header blk), NoThunks (STM m (Map peer (ChainSyncClientHandle m blk))), NoThunks (STM m (StrictSeq (peer, ChainSyncClientHandle m blk))) ) => NoThunks (ChainSyncClientHandleCollection peer m blk) @@ -175,9 +171,7 @@ data DynamoInitState blk deriving (Generic) deriving anyclass instance - ( HasHeader blk, - LedgerSupportsProtocol blk, - NoThunks (Header blk) + ( LedgerSupportsProtocol blk ) => NoThunks (DynamoInitState blk) data ObjectorInitState @@ -241,9 +235,7 @@ data ChainSyncJumpingState m blk deriving anyclass instance ( IOLike m, - HasHeader blk, - LedgerSupportsProtocol blk, - NoThunks (Header blk) + LedgerSupportsProtocol blk ) => NoThunks (ChainSyncJumpingState m blk) -- | The ChainSync state required for jumps @@ -295,7 +287,5 @@ data ChainSyncJumpingJumperState blk deriving (Generic) deriving anyclass instance - ( HasHeader blk, - LedgerSupportsProtocol blk, - NoThunks (Header blk) + ( LedgerSupportsProtocol blk ) => NoThunks (ChainSyncJumpingJumperState blk) 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 d132bec59c..34cba81e82 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -329,7 +329,7 @@ instance MonadLabelledSTM m => MonadLabelledSTM (WithEarlyExit m) where instance MonadSay m => MonadSay (WithEarlyExit m) where say = lift . say -instance (MonadInspectSTM m, Monad (InspectMonad m)) => MonadInspectSTM (WithEarlyExit m) where +instance (MonadInspectSTM m) => MonadInspectSTM (WithEarlyExit m) where type InspectMonad (WithEarlyExit m) = InspectMonad m inspectTVar _ = inspectTVar (Proxy @m) inspectTMVar _ = inspectTMVar (Proxy @m) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 0ba537b87b..ea3bd3ecdb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -14,7 +14,7 @@ module Ouroboros.Consensus.Util.Orphans () where import Cardano.Crypto.DSIGN.Class import Cardano.Crypto.DSIGN.Mock (MockDSIGN) -import Cardano.Crypto.Hash (Hash) +import Cardano.Crypto.Hash (Hash, SizeHash) import Cardano.Ledger.Genesis (NoGenesis (..)) import Codec.CBOR.Decoding (Decoder) import Codec.Serialise (Serialise (..)) @@ -26,6 +26,7 @@ import qualified Data.IntPSQ as PSQ import Data.MultiSet (MultiSet) import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors +import GHC.TypeLits (KnownNat) import NoThunks.Class (InspectHeap (..), InspectHeapNamed (..), NoThunks (..), OnlyCheckWhnfNamed (..), allNoThunks, noThunksInKeysAndValues) @@ -38,7 +39,7 @@ import System.FS.CRC (CRC (CRC)) Serialise -------------------------------------------------------------------------------} -instance Serialise (Hash h a) where +instance KnownNat (SizeHash h) => Serialise (Hash h a) where instance Serialise (VerKeyDSIGN MockDSIGN) where encode = encodeVerKeyDSIGN diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs index 947ab3e927..4a38f06892 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -11,6 +11,7 @@ module Ouroboros.Consensus.Util.STM ( -- * 'Watcher' Watcher (..) , forkLinkedWatcher + , forkLinkedWatcherFinalize , withWatcher -- * Misc , Fingerprint (..) @@ -163,6 +164,19 @@ forkLinkedWatcher :: forall m a fp. (IOLike m, Eq fp, HasCallStack) forkLinkedWatcher registry label watcher = forkLinkedThread registry label $ runWatcher watcher +-- | Spawn a new thread that runs a 'Watcher', executing a finalizer when the +-- thread terminates. +-- +-- The thread will be linked to the registry. +forkLinkedWatcherFinalize :: forall m a fp. (IOLike m, Eq fp, HasCallStack) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> Watcher m a fp + -> m () + -> m (Thread m Void) +forkLinkedWatcherFinalize registry label watcher finalizer = + forkLinkedThread registry label $ runWatcher watcher `finally` finalizer + -- | Spawn a new thread that runs a 'Watcher' -- -- The thread is bracketed via 'withAsync' and 'link'ed. diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index f6db8e90cf..17933a9dcd 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -76,6 +77,7 @@ import Data.Proxy import Data.Typeable import Data.Word import GHC.Generics (Generic) +import GHC.TypeNats (KnownNat) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -162,6 +164,8 @@ instance (SimpleCrypto c, Typeable ext, Typeable ext') headerIsEBB = const Nothing +type KnownHashSize c = KnownNat (Hash.SizeHash (SimpleHash c)) + data SimpleStdHeader c ext = SimpleStdHeader { simplePrev :: ChainHash (SimpleBlock c ext) , simpleSlotNo :: SlotNo @@ -170,7 +174,10 @@ data SimpleStdHeader c ext = SimpleStdHeader { , simpleBodySize :: SizeInBytes } deriving stock (Generic, Show, Eq) - deriving anyclass (Serialise, NoThunks) + deriving anyclass (NoThunks) + +deriving anyclass instance KnownHashSize c => + Serialise (SimpleStdHeader c ext) data SimpleBody = SimpleBody { simpleTxs :: [Mock.Tx] @@ -367,7 +374,10 @@ newtype instance LedgerState (SimpleBlock c ext) = SimpleLedgerState { simpleLedgerState :: MockState (SimpleBlock c ext) } deriving stock (Generic, Show, Eq) - deriving newtype (Serialise, NoThunks) + deriving newtype (NoThunks) + +deriving anyclass instance KnownHashSize c => + Serialise (LedgerState (SimpleBlock c ext)) -- Ticking has no effect on the simple ledger state newtype instance Ticked (LedgerState (SimpleBlock c ext)) = TickedSimpleLedgerState { @@ -541,7 +551,7 @@ instance InspectLedger (SimpleBlock c ext) where Crypto needed for simple blocks -------------------------------------------------------------------------------} -class (HashAlgorithm (SimpleHash c), Typeable c) => SimpleCrypto c where +class (KnownHashSize c, HashAlgorithm (SimpleHash c), Typeable c) => SimpleCrypto c where type family SimpleHash c :: Type data SimpleStandardCrypto @@ -598,7 +608,8 @@ instance Condense ext' => Condense (SimpleBlock' c ext ext') where instance ToCBOR SimpleBody where toCBOR = encode -encodeSimpleHeader :: (ext' -> CBOR.Encoding) +encodeSimpleHeader :: KnownHashSize c + => (ext' -> CBOR.Encoding) -> Header (SimpleBlock' c ext ext') -> CBOR.Encoding encodeSimpleHeader encodeExt SimpleHeader{..} = mconcat [ diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs index dab988bc6d..317ce07382 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node.hs @@ -102,6 +102,7 @@ simpleBlockForging aCanBeLeader aForgeExt = BlockForging { lst (map txForgetValidated txs) proof + , finalize = pure () } where _ = keepRedundantConstraint (Proxy @(ForgeStateUpdateError (SimpleBlock c ext) ~ Void)) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs index c2b22c8c40..96f58b752f 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/PBFT.hs @@ -110,4 +110,5 @@ pbftBlockForging canBeLeader = BlockForging { lst (map txForgetValidated txs) proof + , finalize = pure () } diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs index 00d678da6d..5756154ad9 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Node/Praos.hs @@ -104,7 +104,7 @@ blockForgingPraos numCoreNodes nid = sequence [praosBlockForging nid initHotKey] initHotKey = HotKey 0 - (SignKeyMockKES + (UnsoundPureSignKeyMockKES -- key ID (fst $ verKeys Map.! nid) -- KES initial slot @@ -136,4 +136,5 @@ praosBlockForging cid initHotKey = do tickedLedgerSt (map txForgetValidated txs) isLeader + , finalize = pure () } diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs index 73407f75af..9a2c28d4fe 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/Praos.hs @@ -43,11 +43,12 @@ module Ouroboros.Consensus.Mock.Protocol.Praos ( ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..), serialize') -import Cardano.Crypto.DSIGN.Ed448 (Ed448DSIGN) +import Cardano.Crypto.DSIGN.Ed25519 (Ed25519DSIGN) import Cardano.Crypto.Hash.Class (HashAlgorithm (..), hashToBytes, hashWithSerialiser, sizeHash) import Cardano.Crypto.Hash.SHA256 (SHA256) import Cardano.Crypto.KES.Class + import Cardano.Crypto.KES.Mock import Cardano.Crypto.KES.Simple import Cardano.Crypto.Util @@ -76,7 +77,6 @@ import Ouroboros.Consensus.NodeId (CoreNodeId (..)) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Util.Condense -import Test.Cardano.Slotting.Numeric () -- The Praos paper can be located at https://ia.cr/2017/573 -- @@ -203,12 +203,15 @@ praosValidateView getFields hdr = data HotKey c = HotKey !Period -- ^ Absolute period of the KES key - !(SignKeyKES (PraosKES c)) + !(UnsoundPureSignKeyKES (PraosKES c)) | HotKeyPoisoned deriving (Generic) -instance PraosCrypto c => NoThunks (HotKey c) -deriving instance PraosCrypto c => Show (HotKey c) +instance (PraosCrypto c, NoThunks (UnsoundPureSignKeyKES (PraosKES c))) => NoThunks (HotKey c) + +instance PraosCrypto c => Show (HotKey c) where + show (HotKey p _) = "HotKey " ++ show p ++ "