diff --git a/cabal.project b/cabal.project index 2a2057d2d8..f6fd6c2a38 100644 --- a/cabal.project +++ b/cabal.project @@ -44,3 +44,82 @@ package ouroboros-network if(os(windows)) constraints: bitvec -simd + +-- For the time being, we need to override some dependency bounds +allow-newer: plutus-core:cardano-crypto-class + , cardano-slotting + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-base + tag: 890eec1bbb17068ee7df84c468e1c6bc39643d3a + --sha256: 0944wg2nqazmhlmsynwgdwxxj6ay0hb9qig9l128isb2cjia0hlp + subdir: + -- cardano-binary + cardano-crypto-class + cardano-crypto-tests + cardano-crypto-praos + cardano-mempool + -- cardano-slotting + +source-repository-package + type: git + location: https://github.com/IntersectMBO/formal-ledger-specifications.git + -- !WARNING!: + -- MAKE SURE THIS POINTS TO A COMMIT IN `MAlonzo-code` BEFORE MERGE! + subdir: generated + tag: 544ab20985e3374a1d672354e25d8ca0ca89e7e4 + --sha256: sha256-bhh09OZkHazXCPjsiU/50Hrmfg52i+6UORTZ6/bAx6c= +-- NOTE: If you would like to update the above, look for the `MAlonzo-code` +-- branch in the `formal-ledger-specifications` repo and copy the SHA of +-- the commit you need. The `MAlonzo-code` branch functions like an alternative +-- `master / main` branch for the generated code, see the details here: +-- https://github.com/IntersectMBO/formal-ledger-specifications/pull/530 +-- If you are working on something in `formal-ledger-specifications` +-- and would like to see how they reflect here, just open a PR / draft PR +-- in `formal-ledger-specifications` for your branch and that will +-- automatically create a branch for the generated code that you can try here +-- by editing the above SRP. +-- Once your changes are merged in `formal-ledger-specifications`, the branch +-- for the generated code will be merged into `MAlonzo-code` automatically. +-- Before merging a PR in `cardano-ledger`, make sure that the above SRP +-- points to a commit in `MAlonzo-code` if you were fiddling with the SRP +-- as part of your PR. + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-ledger + tag: ebba3fb4554a04ddaa4734f9083afebd64c81099 + --sha256: 0944wg2nqazmhlmsynwgdwxxj6ay0hb9qig9l128isb2cjia0hlp + 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-conformance + libs/cardano-ledger-core + libs/cardano-ledger-test + libs/cardano-protocol-tpraos + libs/constrained-generators + libs/ledger-state + libs/non-integral + libs/plutus-preprocessor + libs/set-algebra + libs/small-steps + libs/vector-map diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index b4d678998d..44b7e62232 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -135,15 +135,15 @@ library cardano-crypto-class, cardano-crypto-wrapper, cardano-ledger-allegra ^>=1.6, - cardano-ledger-alonzo ^>=1.10.2, + cardano-ledger-alonzo ^>=1.11.0, cardano-ledger-api ^>=1.9.3, - cardano-ledger-babbage ^>=1.9, - cardano-ledger-binary ^>=1.3.4, + cardano-ledger-babbage ^>=1.10, + cardano-ledger-binary ^>=1.4.0, cardano-ledger-byron ^>=1.0.1, - cardano-ledger-conway ^>=1.16, - cardano-ledger-core ^>=1.14, + cardano-ledger-conway ^>=1.17, + cardano-ledger-core ^>=1.15, cardano-ledger-mary ^>=1.7, - cardano-ledger-shelley ^>=1.13.1, + cardano-ledger-shelley ^>=1.14.0, cardano-prelude, cardano-protocol-tpraos ^>=1.2, cardano-slotting, @@ -304,7 +304,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}, @@ -390,7 +390,7 @@ library unstable-cardano-testlib cardano-ledger-api, cardano-ledger-byron, cardano-ledger-conway:testlib, - cardano-ledger-conway-test ^>=1.2.1, + cardano-ledger-conway-test ^>=1.3.0, cardano-ledger-core:{cardano-ledger-core, testlib}, cardano-ledger-shelley, cardano-protocol-tpraos, @@ -545,6 +545,7 @@ library unstable-cardano-tools filepath, fs-api ^>=0.3, githash, + io-classes ^>=1.5, microlens, mtl, network, 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..d975211f41 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 @@ -26,7 +26,7 @@ import Cardano.Crypto (ProtocolMagicId, SignTag (..), Signature (..), SigningKey (..), VerificationKey (..), deterministicKeyGen, signRaw, toVerification, verifySignatureRaw) import Cardano.Crypto.DSIGN.Class -import Cardano.Crypto.Seed (SeedBytesExhausted (..), getBytesFromSeed) +import Cardano.Crypto.Seed (getBytesFromSeedEither) import qualified Cardano.Crypto.Signing as Crypto import qualified Cardano.Crypto.Wallet as CC import Cardano.Ledger.Binary @@ -90,9 +90,9 @@ instance DSIGNAlgorithm ByronDSIGN where genKeyDSIGN seed = SignKeyByronDSIGN . snd $ deterministicKeyGen seedBytes where - seedBytes = case getBytesFromSeed 32 seed of - Just (x,_) -> x - Nothing -> throw $ SeedBytesExhausted (-1) -- TODO We can't get the seed size! + seedBytes = case getBytesFromSeedEither 32 seed of + Right (x,_) -> x + Left err -> throw err 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 f4665d9851..8285368159 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 @@ -36,6 +36,9 @@ module Ouroboros.Consensus.Cardano.Node ( , CardanoHardForkTriggers (.., CardanoHardForkTriggers', triggerHardForkShelley, triggerHardForkAllegra, triggerHardForkMary, triggerHardForkAlonzo, triggerHardForkBabbage, triggerHardForkConway) , CardanoProtocolParams (..) , MaxMajorProtVer (..) + , ProtocolParamsByron + , ProtocolParamsShelleyBased + , CheckpointsMap , TriggerHardFork (..) , protocolClientInfoCardano , protocolInfoCardano @@ -64,8 +67,8 @@ 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 Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Time (SystemStart (SystemStart)) import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) @@ -100,10 +103,8 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run -import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos (Praos, PraosParams (..)) -import Ouroboros.Consensus.Protocol.Praos.Common - (praosCanBeLeaderOpCert) +import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (..), instantiatePraosCredentials) import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosParams (..)) import qualified Ouroboros.Consensus.Protocol.TPraos as Shelley import Ouroboros.Consensus.Shelley.HFEras () @@ -112,9 +113,9 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import Ouroboros.Consensus.Shelley.Ledger.Block (IsShelleyBlock, ShelleyBlockLedgerEra) import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion +import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Shelley.Node -import Ouroboros.Consensus.Shelley.Node.Common (ShelleyEraWithCrypto, - shelleyBlockIssuerVKey) +import Ouroboros.Consensus.Shelley.Node.Common (ShelleyEraWithCrypto, shelleyBlockIssuerVKey) import qualified Ouroboros.Consensus.Shelley.Node.Praos as Praos import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos import Ouroboros.Consensus.Storage.Serialisation @@ -609,12 +610,12 @@ protocolInfoCardano paramsCardano , length credssShelleyBased > 1 = error "Multiple Shelley-based credentials not allowed for mainnet" | otherwise - = assertWithMsg (validateGenesis genesisShelley) + = assertWithMsg (validateGenesis genesisShelley) $ ( ProtocolInfo { pInfoConfig = cfg , pInfoInitLedger = initExtLedgerStateCardano } - , blockForging + , mkBlockForgings ) where CardanoProtocolParams { @@ -975,8 +976,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 @@ -1002,24 +1003,26 @@ protocolInfoCardano paramsCardano ShelleyLeaderCredentials c -> m (NonEmptyOptNP (BlockForging m) (CardanoEras c)) blockForgingShelleyBased credentials = do - let ShelleyLeaderCredentials - { shelleyLeaderCredentialsInitSignKey = initSignKey - , shelleyLeaderCredentialsCanBeLeader = canBeLeader - } = credentials - - hotKey <- do - let maxKESEvo :: Word64 - maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo - - startPeriod :: Absolute.KESPeriod - startPeriod = Absolute.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader - - HotKey.mkHotKey @m @c initSignKey startPeriod maxKESEvo + let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials let slotToPeriod :: SlotNo -> Absolute.KESPeriod slotToPeriod (SlotNo slot) = assert (tpraosSlotsPerKESPeriod == praosSlotsPerKESPeriod) $ Absolute.KESPeriod $ fromIntegral $ slot `div` praosSlotsPerKESPeriod + (ocert, sk) <- instantiatePraosCredentials (praosCanBeLeaderCredentialsSource canBeLeader) + + let startPeriod :: Absolute.KESPeriod + startPeriod = SL.ocertKESPeriod ocert + + let maxKESEvo :: Word64 + maxKESEvo = assert (tpraosMaxKESEvo == praosMaxKESEvo) praosMaxKESEvo + + hotKey :: HotKey.HotKey c m <- HotKey.mkHotKey + ocert + sk + startPeriod + maxKESEvo + let tpraos :: forall era. ShelleyEraWithCrypto c (TPraos c) era => BlockForging m (ShelleyBlock (TPraos c) era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index d04f37f980..e3aff8177f 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -170,7 +170,6 @@ mkShelleyLedgerConfig genesis transCtxt epochInfo mmpv = SL.mkShelleyGlobals genesis (hoistEpochInfo (left (Text.pack . show) . runExcept) epochInfo) - maxMajorPV , shelleyLedgerTranslationContext = transCtxt } where diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index ce57f1bb3c..be5c912844 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -46,6 +46,7 @@ import Cardano.Ledger.Alonzo.Scripts (ExUnits, ExUnits', import Cardano.Ledger.Alonzo.Tx (totExUnits) import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Babbage.Rules as BabbageEra +import qualified Cardano.Ledger.BaseTypes as CB import Cardano.Ledger.Binary (Annotator (..), DecCBOR (..), EncCBOR (..), FromCBOR (..), FullByteString (..), ToCBOR (..), toPlainDecoder) @@ -342,7 +343,8 @@ instance MaxTxSizeUTxO (ShelleyEra c) where SL.ApplyTxError . pure $ ShelleyEra.UtxowFailure $ ShelleyEra.UtxoFailure - $ ShelleyEra.MaxTxSizeUTxO x y + $ ShelleyEra.MaxTxSizeUTxO + $ CB.Mismatch x y instance MaxTxSizeUTxO (AllegraEra c) where maxTxSizeUTxO x y = diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs index 2b673cf5bd..3a3a3a6940 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs @@ -44,6 +44,7 @@ import Ouroboros.Consensus.Shelley.Ledger import Ouroboros.Consensus.Shelley.Ledger.Inspect () import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () import Ouroboros.Consensus.Shelley.Node.DiffusionPipelining () +import Ouroboros.Consensus.Shelley.Node.Common import Ouroboros.Consensus.Shelley.Node.Serialisation () import Ouroboros.Consensus.Shelley.Node.TPraos import Ouroboros.Consensus.Shelley.Protocol.Abstract (pHeaderIssuer) 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..fc7cb27a47 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,13 +80,15 @@ praosSharedBlockForging ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = canBeLeader , shelleyLeaderCredentialsLabel = label - } = do + } = BlockForging { forgeLabel = label <> "_" <> T.pack (L.eraName @era), canBeLeader = canBeLeader, + updateForgeState = \_ curSlot _ -> forgeStateUpdateInfoFromUpdateInfo <$> HotKey.evolve hotKey (slotToPeriod curSlot), + checkCanForge = \cfg curSlot _tickedChainDepState _isLeader -> praosCheckCanForge (configConsensus cfg) @@ -105,5 +97,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 28b7579ec6..1904da33a9 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -55,7 +55,7 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits) import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) +import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey, mkHotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Praos.Common import Ouroboros.Consensus.Protocol.TPraos @@ -65,7 +65,8 @@ import Ouroboros.Consensus.Shelley.Ledger.Inspect () import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () import Ouroboros.Consensus.Shelley.Node.Common (ProtocolParamsShelleyBased (..), ShelleyEraWithCrypto, - ShelleyLeaderCredentials (..), shelleyBlockIssuerVKey) + ShelleyLeaderCredentials (..), + shelleyBlockIssuerVKey) import Ouroboros.Consensus.Shelley.Node.Serialisation () import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Consensus.Util.Assert @@ -88,26 +89,19 @@ 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) = SL.KESPeriod $ fromIntegral $ slot `div` tpraosSlotsPerKESPeriod + -- | Create a 'BlockForging' record safely using a given 'Hotkey'. -- -- The name of the era (separated by a @_@) will be appended to each @@ -126,6 +120,7 @@ shelleySharedBlockForging hotKey slotToPeriod credentials = BlockForging { forgeLabel = label <> "_" <> T.pack (L.eraName @era) , canBeLeader = canBeLeader + , updateForgeState = \_ curSlot _ -> forgeStateUpdateInfoFromUpdateInfo <$> HotKey.evolve hotKey (slotToPeriod curSlot) @@ -139,6 +134,8 @@ shelleySharedBlockForging hotKey slotToPeriod credentials = hotKey canBeLeader cfg + + , finalize = HotKey.finalize hotKey } where ShelleyLeaderCredentials { @@ -216,11 +213,25 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased { pInfoConfig = topLevelConfig , pInfoInitLedger = initExtLedgerState } - , traverse - (shelleyBlockForging tpraosParams) - credentialss + , traverse mkBlockForging credentialss ) where + mkBlockForging :: ShelleyLeaderCredentials c -> m (BlockForging m (ShelleyBlock (TPraos c) era)) + mkBlockForging credentials = do + let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials + (ocert, sk) <- instantiatePraosCredentials (praosCanBeLeaderCredentialsSource canBeLeader) + + let startPeriod :: Absolute.KESPeriod + startPeriod = SL.ocertKESPeriod ocert + + hotKey :: HotKey c m <- mkHotKey + ocert + sk + startPeriod + (tpraosMaxKESEvo tpraosParams) + + return $ shelleyBlockForging tpraosParams hotKey credentials + genesis :: SL.ShelleyGenesis c genesis = transitionCfg ^. L.tcShelleyGenesisL diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs index 0b2045dd7c..c6f81b9aa0 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Ouroboros/Consensus/ByronDual/Node.hs @@ -66,6 +66,7 @@ dualByronBlockForging creds = BlockForging { fmap castForgeStateUpdateInfo .: updateForgeState (dualTopLevelConfigMain cfg) , checkCanForge = checkCanForge . dualTopLevelConfigMain , forgeBlock = return .....: forgeDualByronBlock + , finalize = return () } where BlockForging {..} = byronBlockForging creds diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs index 6322d3aa3d..559035aebc 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Key.hs @@ -9,7 +9,6 @@ module Cardano.Api.Key ( , CastSigningKeyRole (..) , CastVerificationKeyRole (..) , Key (..) - , generateSigningKey ) where import Cardano.Api.Any @@ -51,16 +50,17 @@ class (Eq (VerificationKey keyrole), verificationKeyHash :: VerificationKey keyrole -> Hash keyrole --- TODO: We should move this into the Key type class, with the existing impl as the default impl. --- For KES we can then override it to keep the seed and key in mlocked memory at all times. --- | Generate a 'SigningKey' using a seed from operating system entropy. --- -generateSigningKey :: Key keyrole => AsType keyrole -> IO (SigningKey keyrole) -generateSigningKey keytype = do - seed <- Crypto.readSeedFromSystemEntropy seedSize - return $! deterministicSigningKey keytype seed - where - seedSize = deterministicSigningKeySeedSize keytype + -- | Generate a 'SigningKey' using a seed from operating system entropy. + generateSigningKey :: AsType keyrole -> IO (SigningKey keyrole) + generateSigningKey keytype = do + -- + -- For KES we can override this to keep the seed and key in mlocked memory + -- at all times. + -- + seed <- Crypto.readSeedFromSystemEntropy seedSize + return $! deterministicSigningKey keytype seed + where + seedSize = deterministicSigningKeySeedSize keytype instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs index 5dd33d6dff..1a0c2ec55a 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 (..) @@ -40,95 +40,96 @@ 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) + newtype SigningKey UnsoundPureKesKey = + KesSigningKey { unKesSigningKey :: Shelley.UnsoundPureSignKeyKES StandardCrypto } + deriving (Show, IsString) via UsingRawBytesHex (SigningKey UnsoundPureKesKey) deriving newtype (EncCBOR, DecCBOR, ToCBOR, FromCBOR) deriving anyclass 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 + -- This loses the mlock safety of the seed, since it starts from a normal + -- in-memory seed. + 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 f66cf4488b..b7fcd5234d 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/OperationalCertificate.hs @@ -94,7 +94,7 @@ instance HasTypeProxy OperationalCertificateIssueCounter where instance HasTextEnvelope OperationalCertificate where textEnvelopeType _ = "NodeOperationalCertificate" -getHotKey :: OperationalCertificate -> VerificationKey KesKey +getHotKey :: OperationalCertificate -> VerificationKey UnsoundPureKesKey getHotKey (OperationalCertificate cert _) = KesVerificationKey $ Shelley.ocertVkHot cert getKesPeriod :: OperationalCertificate -> Word diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Node/Protocol/Shelley.hs index fd58263650..a4ffa70d8f 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 @@ -31,8 +31,9 @@ import Cardano.Api.OperationalCertificate import qualified Cardano.Api.Protocol.Types as Protocol import Cardano.Api.SerialiseTextEnvelope import qualified Cardano.Crypto.Hash.Class as Crypto +import qualified Cardano.Crypto.KES.Class as KES import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion) -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (Crypto (..), StandardCrypto) import Cardano.Ledger.Keys (coerceKeyRole) import qualified Cardano.Ledger.Shelley.Genesis as Shelley import Cardano.Node.Protocol.Types @@ -45,7 +46,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 (..)) @@ -153,7 +154,7 @@ readLeaderCredentialsSingleton vrfSKey <- firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsVrfKey) vrfFile) - (opCert, kesSKey) <- opCertKesKeyCheck kesFile opCertFile + (opCert, KesSigningKey kesSKey) <- opCertKesKeyCheck kesFile opCertFile return [mkPraosLeaderCredentials opCert vrfSKey kesSKey] @@ -170,12 +171,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 +201,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 + <*> (unKesSigningKey <$> parseEnvelope (AsSigningKey AsUnsoundPureKesKey) scKes) readBulkFile :: Maybe FilePath @@ -228,21 +229,20 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } = mkPraosLeaderCredentials :: OperationalCertificate -> SigningKey VrfKey - -> SigningKey KesKey + -> KES.UnsoundPureSignKeyKES (KES StandardCrypto) -> ShelleyLeaderCredentials StandardCrypto mkPraosLeaderCredentials - (OperationalCertificate opcert (StakePoolVerificationKey vkey)) + (OperationalCertificate ocert (StakePoolVerificationKey vkey)) (VrfSigningKey vrfKey) - (KesSigningKey kesKey) = + kesKey = ShelleyLeaderCredentials { shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { - praosCanBeLeaderOpCert = opcert, praosCanBeLeaderColdVerKey = coerceKeyRole vkey, - praosCanBeLeaderSignKeyVRF = vrfKey - }, - shelleyLeaderCredentialsInitSignKey = kesKey, - shelleyLeaderCredentialsLabel = "Shelley" + praosCanBeLeaderSignKeyVRF = vrfKey, + praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound ocert kesKey + } + , shelleyLeaderCredentialsLabel = "Shelley" } parseEnvelope :: diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs index 14564611b9..f455982c5b 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs @@ -384,7 +384,6 @@ mkCardanoProtocolInfo genesisByron signatureThreshold transitionConfig initialNo emptyCheckpointsMap (ProtVer (L.eraProtVerHigh @(L.LatestKnownEra StandardCrypto)) 0) ) - where castHeaderHash :: HeaderHash ByronBlock 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 3fddfe1997..43f8047c36 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 @@ -22,6 +22,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) @@ -136,7 +137,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 @@ -165,9 +166,10 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir { pInfoConfig , pInfoInitLedger } - , blockForging + , mkForgers ) = protocolInfoCardano runP + preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () preOpenChainDB mode db = doesDirectoryExist db >>= bool create checkMode diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index 2ca053c7a8..732e6bc3c9 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,7 @@ module Test.ThreadNet.Infra.Shelley ( import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), seedSizeDSIGN) import Cardano.Crypto.Hash (Hash, HashAlgorithm) -import Cardano.Crypto.KES (KESAlgorithm (..)) +import Cardano.Crypto.KES (KESAlgorithm (..), UnsoundPureKESAlgorithm (..), seedSizeKES) import Cardano.Crypto.Seed (mkSeedFromBytes) import qualified Cardano.Crypto.Seed as Cardano.Crypto import Cardano.Crypto.VRF (SignKeyVRF, VRFAlgorithm, VerKeyVRF, @@ -78,8 +78,10 @@ import Ouroboros.Consensus.Config.SecurityParam import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader (PraosCanBeLeader), - praosCanBeLeaderColdVerKey, praosCanBeLeaderOpCert, - praosCanBeLeaderSignKeyVRF) + praosCanBeLeaderColdVerKey, + praosCanBeLeaderSignKeyVRF, + praosCanBeLeaderCredentialsSource, + PraosCredentialsSource (..)) import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Eras (EraCrypto, ShelleyEra) import Ouroboros.Consensus.Shelley.Ledger (GenTx (..), @@ -138,7 +140,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 :: !(SL.UnsoundPureSignKeyKES c) , cnOCert :: !(SL.OCert c) } @@ -180,8 +182,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 = Cardano.Ledger.Keys.signedDSIGN @c delKey @@ -209,12 +211,11 @@ genCoreNode startKESPeriod = do genSeed :: Integral a => a -> Gen Cardano.Crypto.Seed genSeed = fmap mkSeedFromBytes . genBytes -mkLeaderCredentials :: PraosCrypto c => CoreNode c -> ShelleyLeaderCredentials c +mkLeaderCredentials :: (PraosCrypto c) => CoreNode c -> ShelleyLeaderCredentials c mkLeaderCredentials CoreNode { cnDelegateKey, cnVRF, cnKES, cnOCert } = ShelleyLeaderCredentials { - shelleyLeaderCredentialsInitSignKey = cnKES - , shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { - praosCanBeLeaderOpCert = cnOCert + shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader { + praosCanBeLeaderCredentialsSource = PraosCredentialsUnsound cnOCert cnKES , praosCanBeLeaderColdVerKey = SL.VKey $ deriveVerKeyDSIGN cnDelegateKey , praosCanBeLeaderSignKeyVRF = cnVRF } @@ -421,6 +422,7 @@ mkProtocolShelley genesis initialNonce protVer coreNode = , shelleyBasedLeaderCredentials = [mkLeaderCredentials coreNode] } protVer + {------------------------------------------------------------------------------- Necessary transactions for updating the 'DecentralizationParam' -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs index 2b773ed929..d963885fb0 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs @@ -108,6 +108,7 @@ genTx _cfg slotNo TickedShelleyLedgerState { tickedShelleyLedgerState } genEnv = , ledgerIx = minBound , ledgerPp = getPParams tickedShelleyLedgerState , ledgerAccount = SL.esAccountState epochState + , ledgerMempool = False -- wild guess } utxoSt :: SL.UTxOState (MockShelley h) diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs index d06d4ef4dc..41e598f359 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs @@ -145,7 +145,7 @@ setupTestOutput :: SetupDualByron -> TestOutput DualByronBlock setupTestOutput setup@SetupDualByron{..} = runTestNetwork testConfig testConfigB TestConfigMB { nodeInfo = \coreNodeId -> - uncurry plainTestNodeInitialization + uncurry plainTestNodeInitialization $ (protocolInfoDualByron setupGenesis (setupParams setup) diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs index 0c43672007..74b718b746 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Test that we can submit transactions to the mempool using the local -- submission server, in different Cardano eras. 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 861f3d617e..48c62dfc38 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs @@ -236,15 +236,15 @@ prop_simple_cardano_convergence TestSetup testOutput = runTestNetwork setupTestConfig testConfigB TestConfigMB { nodeInfo = \coreNodeId@(CoreNodeId nid) -> - mkProtocolCardanoAndHardForkTxs - pbftParams - coreNodeId - genesisByron - generatedSecrets - propPV - genesisShelley - setupInitialNonce - (coreNodes !! fromIntegral nid) + mkProtocolCardanoAndHardForkTxs + pbftParams + coreNodeId + genesisByron + generatedSecrets + propPV + genesisShelley + setupInitialNonce + (coreNodes !! fromIntegral nid) , mkRekeyM = Nothing } @@ -438,16 +438,16 @@ mkProtocolCardanoAndHardForkTxs :: -> ShelleyGenesis c -> SL.Nonce -> Shelley.CoreNode c - -> TestNodeInitialization m (CardanoBlock c) + -> (TestNodeInitialization m (CardanoBlock c)) mkProtocolCardanoAndHardForkTxs pbftParams coreNodeId genesisByron generatedSecretsByron propPV genesisShelley initialNonce coreNodeShelley = - TestNodeInitialization - { tniCrucialTxs = crucialTxs - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging - } + TestNodeInitialization + { tniCrucialTxs = crucialTxs + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging + } where crucialTxs :: [GenTx (CardanoBlock c)] crucialTxs = diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs index f0a9cde48d..263360ec21 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs @@ -231,12 +231,12 @@ prop_simple_allegraAlonzo_convergence TestSetup testOutput :: TestOutput MaryAlonzoBlock testOutput = runTestNetwork setupTestConfig testConfigB TestConfigMB { nodeInfo = \(CoreNodeId nid) -> - let protocolParamsShelleyBased = + let leaderCredentials = Shelley.mkLeaderCredentials + (coreNodes !! fromIntegral nid) + protocolParamsShelleyBased = ProtocolParamsShelleyBased { shelleyBasedInitialNonce = setupInitialNonce - , shelleyBasedLeaderCredentials = - [Shelley.mkLeaderCredentials - (coreNodes !! fromIntegral nid)] + , shelleyBasedLeaderCredentials = [leaderCredentials] } hardForkTrigger = TriggerHardForkAtVersion $ SL.getVersion majorVersion2 @@ -252,7 +252,7 @@ prop_simple_allegraAlonzo_convergence TestSetup ) hardForkTrigger in - TestNodeInitialization { + TestNodeInitialization { tniCrucialTxs = if not setupHardFork then [] else fmap GenTxShelley1 $ 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 6729962fac..14fd59f6ae 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 @@ -417,10 +417,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..9856575b64 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 @@ -185,7 +185,7 @@ deriving instance (Show (TxGenExtra blk), Show (BlockNodeToNodeVersion blk)) -- that 'TestConfigB' can occur in contexts (such as in 'PropGeneralArgs') for -- which the @m@ parameter is irrelevant and hence unknown. data TestConfigMB m blk = TestConfigMB - { nodeInfo :: CoreNodeId -> TestNodeInitialization m blk + { nodeInfo :: CoreNodeId -> (TestNodeInitialization m blk) , mkRekeyM :: Maybe (m (RekeyM m blk)) -- ^ 'runTestNetwork' immediately runs this action once in order to -- initialize an 'RekeyM' value that it then reuses throughout the test 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 43399dfeb6..bcff2c1488 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 @@ -62,6 +62,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 qualified Ouroboros.Consensus.Fragment.InFuture as InFuture @@ -807,7 +808,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 @@ -1045,9 +1046,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..df03f4a0fa 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 @@ -141,16 +141,17 @@ prop_simple_praos_convergence TestSetup testOutput@TestOutput{testOutputNodes} = runTestNetwork testConfig testConfigB TestConfigMB - { nodeInfo = \nid -> plainTestNodeInitialization - (protocolInfoPraos - numCoreNodes - nid - params - (HardFork.defaultEraParams - k - slotLength) - setupInitialNonce - evolvingStake) - (blockForgingPraos numCoreNodes nid) + { nodeInfo = \nid -> + plainTestNodeInitialization + (protocolInfoPraos + numCoreNodes + nid + params + (HardFork.defaultEraParams + k + slotLength) + setupInitialNonce + evolvingStake) + (blockForgingPraos numCoreNodes nid) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal index 106fda375f..d97d0667c4 100644 --- a/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal +++ b/ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal @@ -74,6 +74,7 @@ library cardano-slotting, cborg, containers, + io-classes, mtl, nothunks, ouroboros-consensus ^>=0.20, @@ -90,6 +91,7 @@ library unstable-protocol-testlib base, cardano-crypto-class, cardano-crypto-tests, + cardano-ledger-core, cardano-ledger-shelley-test, cardano-protocol-tpraos, cardano-slotting, 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..00a91fb2e5 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,27 @@ module Ouroboros.Consensus.Protocol.Ledger.HotKey ( , kesStatus -- * Hot Key , HotKey (..) + , getOCert , KESEvolutionError (..) , KESEvolutionInfo , mkHotKey + , mkHotKeyEv + , mkEmptyHotKey + , mkShelleyHotKey , sign ) where import qualified Cardano.Crypto.KES as Relative (Period) import Cardano.Ledger.Crypto (Crypto) import qualified Cardano.Ledger.Keys as SL +import qualified Cardano.Protocol.TPraos.OCert as OCert import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block.Forging (UpdateInfo (..)) import Ouroboros.Consensus.Util.IOLike +import NoThunks.Class (OnlyCheckWhnfNamed (..)) {------------------------------------------------------------------------------- KES Info @@ -129,6 +139,7 @@ data HotKey c m = HotKey { -- | Return 'KESInfo' of the signing key. , getInfo :: m KESInfo -- | Return 'True' when the signing key is poisoned because it expired. + , getOCertMaybe :: m (Maybe (OCert.OCert c)) , isPoisoned :: m Bool -- | Sign the given @toSign@ with the current signing key. -- @@ -136,9 +147,33 @@ data HotKey c m = HotKey { -- -- POSTCONDITION: the signature is in normal form. , sign_ :: forall toSign. (SL.KESignable c toSign, HasCallStack) - => toSign -> m (SL.SignedKES c toSign) + => toSign + -> m (SL.SignedKES c toSign) + -- | Securely erase the key and release its memory. + , forget :: m () + + -- | Set a new sign key. + , set :: OCert.OCert c + -- ^ The new OCert + -> SL.SignKeyKES c + -- ^ The new KES key + -> Word + -- ^ The new KES key's current evolution + -> Absolute.KESPeriod + -- ^ Start period (relative to the KES key's 0th evolution) + -> m () + , finalize :: m () } +deriving via (OnlyCheckWhnfNamed "HotKey" (HotKey c m)) instance NoThunks (HotKey c m) + +getOCert :: Monad m => HotKey c m -> m (OCert.OCert c) +getOCert hotKey = do + ocertMay <- getOCertMaybe hotKey + case ocertMay of + Just ocert -> return ocert + Nothing -> error "trying to read OpCert for poisoned key" + sign :: (SL.KESignable c toSign, HasCallStack) => HotKey c m @@ -148,7 +183,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,52 +191,118 @@ 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 - , kesStateKey :: !(KESKey c) + kesStateInfo :: !KESInfo + , kesStateKey :: !(KESKey c) } deriving (Generic) 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 ocert initKey startPeriod maxKESEvolutions = do + hotKey <- mkEmptyHotKey maxKESEvolutions (pure ()) + set hotKey ocert initKey 0 startPeriod + return hotKey + +-- Create a new 'HotKey' and initialize it to the given initial KES key. The +-- initial key should be at the given evolution. +mkHotKeyEv :: + forall m c. (Crypto c, IOLike m) + => Word + -> OCert.OCert c + -> SL.SignKeyKES c -> Absolute.KESPeriod -- ^ Start period -> Word64 -- ^ Max KES evolutions -> m (HotKey c m) -mkHotKey initKey startPeriod@(Absolute.KESPeriod start) maxKESEvolutions = do +mkHotKeyEv evolution ocert initKey startPeriod maxKESEvolutions = do + hotKey <- mkEmptyHotKey maxKESEvolutions (pure ()) + set hotKey ocert initKey evolution startPeriod + return hotKey + +-- | Create a new 'HotKey' and initialize it to a poisoned state (containing no +-- valid KES sign key). +mkEmptyHotKey :: + forall m c. (Crypto c, IOLike m) + => Word64 -- ^ Max KES evolutions + -> m () + -> m (HotKey c m) +mkEmptyHotKey maxKESEvolutions finalizer = do varKESState <- newMVar initKESState + return HotKey { evolve = evolveKey varKESState , getInfo = kesStateInfo <$> readMVar varKESState + , getOCertMaybe = kesStateKey <$> readMVar varKESState >>= \case + KESKeyPoisoned -> return Nothing + KESKey ocert _ -> return (Just ocert) + , isPoisoned = kesKeyIsPoisoned . kesStateKey <$> readMVar varKESState , sign_ = \toSign -> do - KESState { kesStateInfo, kesStateKey } <- readMVar varKESState - case kesStateKey of - KESKeyPoisoned -> error "trying to sign with a poisoned key" - KESKey key -> do - let evolution = kesEvolution kesStateInfo - signed = SL.signedKES () evolution toSign key - -- Force the signature to WHNF (for 'SignedKES', WHNF implies - -- NF) so that we don't have any thunks holding on to a key that - -- might be destructively updated when evolved. - evaluate signed + withMVar varKESState $ \KESState { kesStateInfo, kesStateKey } -> do + case kesStateKey of + KESKeyPoisoned -> + error "trying to sign with a poisoned key" + KESKey _ key -> do + let evolution = kesEvolution kesStateInfo + SL.signedKES () evolution toSign key + , forget = do + modifyMVar_ varKESState $ poisonState + , set = \newOCert newKey evolution startPeriod@(Absolute.KESPeriod start) -> do + modifyMVar_ varKESState $ \oldState -> do + _ <- poisonState oldState + return $ KESState { + kesStateInfo = KESInfo { + kesStartPeriod = startPeriod + , kesEndPeriod = Absolute.KESPeriod (start + fromIntegral maxKESEvolutions) + , kesEvolution = evolution + } + , kesStateKey = KESKey newOCert newKey + } + , finalize = finalizer } where initKESState :: KESState c initKESState = KESState { kesStateInfo = KESInfo { - kesStartPeriod = startPeriod - , kesEndPeriod = Absolute.KESPeriod (start + fromIntegral maxKESEvolutions) - -- We always start from 0 as the key hasn't evolved yet. + kesStartPeriod = Absolute.KESPeriod 0 + , kesEndPeriod = Absolute.KESPeriod 0 , kesEvolution = 0 } - , kesStateKey = KESKey initKey + , kesStateKey = KESKeyPoisoned } +mkShelleyHotKey :: forall m c. (Crypto c, IOLike m) + => OCert.OCert c + -> SL.SignKeyKES c + -> Absolute.KESPeriod + -> Word64 + -> m (HotKey c m) +mkShelleyHotKey ocert sk startPeriod maxEvolutions = + mkHotKey ocert sk startPeriod maxEvolutions + +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 +331,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 +340,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 +353,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 72395ca4ce..54555b9b2a 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 @@ -159,27 +159,25 @@ forgePraosFields hotKey PraosCanBeLeader { praosCanBeLeaderColdVerKey, - praosCanBeLeaderSignKeyVRF, - praosCanBeLeaderOpCert + praosCanBeLeaderSignKeyVRF } PraosIsLeader {praosIsLeaderVrfRes} mkToSign = do + ocert <- HotKey.getOCert hotKey + let signedFields = + PraosToSign + { praosToSignIssuerVK = praosCanBeLeaderColdVerKey, + praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF, + praosToSignVrfRes = praosIsLeaderVrfRes, + praosToSignOCert = ocert + } + toSign = mkToSign signedFields signature <- HotKey.sign hotKey toSign return PraosFields { praosSignature = signature, praosToSign = toSign } - where - toSign = mkToSign signedFields - - signedFields = - PraosToSign - { praosToSignIssuerVK = praosCanBeLeaderColdVerKey, - praosToSignVrfVK = VRF.deriveVerKeyVRF praosCanBeLeaderSignKeyVRF, - praosToSignVrfRes = praosIsLeaderVrfRes, - praosToSignOCert = praosCanBeLeaderOpCert - } {------------------------------------------------------------------------------- Protocol proper diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs index 94241bc6c1..701343455e 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Common.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -15,17 +16,22 @@ module Ouroboros.Consensus.Protocol.Praos.Common ( -- * node support , PraosNonces (..) , PraosProtocolSupportsNode (..) + , PraosCredentialsSource (..) + , instantiatePraosCredentials ) where import qualified Cardano.Crypto.VRF as VRF -import Cardano.Ledger.BaseTypes (Nonce) import qualified Cardano.Ledger.BaseTypes as SL -import Cardano.Ledger.Crypto (Crypto, VRF) +import qualified Cardano.Crypto.KES.Class as KES +import Cardano.Ledger.BaseTypes (Nonce, Version) +import Cardano.Ledger.Crypto (Crypto, VRF, KES) import Cardano.Ledger.Keys (KeyHash, KeyRole (BlockIssuer)) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.OCert as OCert import Cardano.Slotting.Block (BlockNo) import Cardano.Slotting.Slot (SlotNo) +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadThrow) import Data.Function (on) import Data.Map.Strict (Map) import Data.Ord (Down (Down)) @@ -245,16 +251,31 @@ instance Crypto c => ChainOrder (PraosChainSelectView c) where preferCandidate cfg ours cand = comparePraos cfg ours cand == LT data PraosCanBeLeader c = PraosCanBeLeader - { -- | Certificate delegating rights from the stake pool cold key (or - -- genesis stakeholder delegate cold key) to the online KES key. - praosCanBeLeaderOpCert :: !(OCert.OCert c), - -- | Stake pool cold key or genesis stakeholder delegate cold key. + { -- | Stake pool cold key or genesis stakeholder delegate cold key. praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer c), - praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c) + praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c), + praosCanBeLeaderCredentialsSource :: !(PraosCredentialsSource c) + -- praosCanBeLeaderOCert :: !(OCert.OCert c), + -- praosCanBeLeaderKESKey :: !(SL.SignKeyKES c) } deriving (Generic) -instance Crypto c => NoThunks (PraosCanBeLeader c) +data PraosCredentialsSource c + = PraosCredentialsUnsound (OCert.OCert c) (SL.UnsoundPureSignKeyKES c) + deriving (Generic) + +instance (NoThunks (SL.UnsoundPureSignKeyKES c), Crypto c) => NoThunks (PraosCredentialsSource c) +instance (NoThunks (SL.UnsoundPureSignKeyKES c), Crypto c) => NoThunks (PraosCanBeLeader c) + +instantiatePraosCredentials :: ( KES.UnsoundPureKESAlgorithm (KES c) + , MonadST m + , MonadThrow m + ) + => PraosCredentialsSource c + -> m (OCert.OCert c, SL.SignKeyKES c) +instantiatePraosCredentials (PraosCredentialsUnsound ocert skUnsound) = do + sk <- KES.unsoundPureSignKeyKESToSoundSignKeyKES skUnsound + return (ocert, sk) -- | See 'PraosProtocolSupportsNode' data PraosNonces = PraosNonces { diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs index f416424214..39be932cd4 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 @@ -395,7 +395,7 @@ mkShelleyGlobals TPraosConfig{..} = SL.Globals { , securityParameter = k , maxKESEvo = tpraosMaxKESEvo , quorum = tpraosQuorum - , maxMajorPV = getMaxMajorProtVer tpraosMaxMajorPV + -- , maxMajorPV = getMaxMajorProtVer tpraosMaxMajorPV , maxLovelaceSupply = tpraosMaxLovelaceSupply , activeSlotCoeff = tpraosLeaderF , networkId = tpraosNetworkId diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index 7686d00a04..4ed53ca1fc 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -6,8 +8,9 @@ -- to be semantically correct at all, only structurally correct. module Test.Consensus.Protocol.Serialisation.Generators () where -import Cardano.Crypto.KES (signedKES) +import Cardano.Crypto.KES (UnsoundPureKESAlgorithm, unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) +import Cardano.Ledger.Crypto (KES) import Cardano.Protocol.TPraos.BHeader (HashHeader, PrevHash (..)) import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod), OCert (OCert)) @@ -27,7 +30,7 @@ import Test.QuickCheck (Arbitrary (..), Gen, choose, oneof) instance Arbitrary InputVRF where arbitrary = mkInputVRF <$> arbitrary <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where +instance (Praos.PraosCrypto c, UnsoundPureKESAlgorithm (KES c)) => Arbitrary (HeaderBody c) where arbitrary = let ocert = OCert @@ -55,12 +58,12 @@ instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where <*> ocert <*> arbitrary -instance Praos.PraosCrypto c => Arbitrary (Header c) where +instance (Praos.PraosCrypto c, UnsoundPureKESAlgorithm (KES c)) => Arbitrary (Header c) where arbitrary = do hBody <- arbitrary period <- arbitrary sKey <- arbitrary - let hSig = signedKES () period hBody sKey + let hSig = unsoundPureSignedKES () period hBody sKey pure $ Header hBody hSig instance Praos.PraosCrypto c => Arbitrary (PraosState c) where diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index cce3ffa020..6513d09df6 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -281,7 +281,7 @@ library bytestring >=0.10 && <0.13, cardano-binary, cardano-crypto-class, - cardano-ledger-core ^>=1.14, + cardano-ledger-core ^>=1.15, cardano-prelude, cardano-slotting, cardano-strict-containers, @@ -474,6 +474,7 @@ library unstable-mock-block containers, deepseq, hashable, + io-classes, mtl, nothunks, ouroboros-consensus, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Abstract.hs index ff7f160206..e270e87987 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/Abstract.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Block.Abstract ( , BlockConfig , CodecConfig , StorageConfig + , BlockForgingCredentials -- * Previous hash , GetPrevHash (..) , blockPrevHash @@ -108,6 +109,10 @@ data family CodecConfig blk :: Type -- avoid circular dependencies. data family StorageConfig blk :: Type +-- | Credentials needed for block forging. In eras that use KES, this will be +-- a pair of KES sign key and OpCert; in other eras, it should be 'Void'. +type family BlockForgingCredentials blk :: Type + {------------------------------------------------------------------------------- Get hash of previous block -------------------------------------------------------------------------------} 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..e43c8d484c 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,9 @@ data BlockForging m blk = BlockForging { -> [Validated (GenTx blk)] -- Transactions to include -> IsLeader (BlockProtocol blk) -- Proof we are leader -> m blk + + , finalize :: m () + } data ShouldForge blk = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index e89589374c..5b2be17841 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -77,6 +77,8 @@ deriving stock instance CanHardFork xs => Show (LedgerState (HardForkBlock xs) deriving stock instance CanHardFork xs => Eq (LedgerState (HardForkBlock xs)) deriving newtype instance CanHardFork xs => NoThunks (LedgerState (HardForkBlock xs)) +type instance BlockForgingCredentials (HardForkBlock '[blk]) = BlockForgingCredentials blk + {------------------------------------------------------------------------------- Protocol config -------------------------------------------------------------------------------} 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..c11ef7a881 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 @@ -11,6 +11,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | Witness isomorphism between @b@ and @HardForkBlock '[b]@ @@ -417,6 +418,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 +466,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..6ce3646ecb 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,12 @@ hardForkCanBeLeader = SomeErasCanBeLeader . hmap (WrapCanBeLeader . canBeLeader) +hardForkFinalize :: (Monad m, All Top xs) + => NonEmptyOptNP (BlockForging m) xs -> m () +hardForkFinalize blockForging = + -- pure () + void $ htraverse_ finalize blockForging + -- | POSTCONDITION: the returned 'ForgeStateUpdateInfo' is from the same era as -- the ticked 'ChainDepState'. hardForkUpdateForgeState :: diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs index cf3d7b11b0..aa7e8eb9bb 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/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..9a43c2da1c 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 @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -47,6 +49,7 @@ import Cardano.Crypto.DSIGN.Ed448 (Ed448DSIGN) import Cardano.Crypto.Hash.Class (HashAlgorithm (..), hashToBytes, hashWithSerialiser, sizeHash) import Cardano.Crypto.Hash.SHA256 (SHA256) +import Cardano.Crypto.DSIGN.Class import Cardano.Crypto.KES.Class import Cardano.Crypto.KES.Mock import Cardano.Crypto.KES.Simple @@ -54,6 +57,9 @@ import Cardano.Crypto.Util import Cardano.Crypto.VRF.Class import Cardano.Crypto.VRF.Mock (MockVRF) import Cardano.Crypto.VRF.Simple (SimpleVRF) +import Cardano.Crypto.Libsodium.MLockedSeed (mlockedSeedUseAsCPtr) +import Cardano.Crypto.Libsodium.Memory (packByteStringCStringLen) +import Cardano.Crypto.Seed (mkSeedFromBytes) import Cardano.Slotting.EpochInfo import Codec.CBOR.Decoding (decodeListLenOf) import Codec.CBOR.Encoding (encodeListLen) @@ -66,6 +72,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Data.Typeable import Data.Word (Word64) +import Foreign.Ptr (castPtr) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..)) @@ -76,7 +83,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 +209,12 @@ 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 (NoThunks (UnsoundPureSignKeyKES (PraosKES c)), PraosCrypto c) => NoThunks (HotKey c) +deriving instance (Show (UnsoundPureSignKeyKES (PraosKES c)), PraosCrypto c) => Show (HotKey c) -- | The 'HotKey' could not be evolved to the given 'Period'. newtype HotKeyEvolutionError = HotKeyEvolutionError Period @@ -219,21 +225,22 @@ newtype HotKeyEvolutionError = HotKeyEvolutionError Period -- NOTE: when the key's period is after the target period, we shouldn't use -- it, but we currently do. In real TPraos we check this in -- 'tpraosCheckCanForge'. -evolveKey :: - PraosCrypto c - => SlotNo - -> HotKey c - -> (HotKey c, UpdateInfo (HotKey c) HotKeyEvolutionError) +evolveKey :: ( PraosCrypto c + ) + => SlotNo + -> HotKey c + -> (HotKey c, UpdateInfo (HotKey c) HotKeyEvolutionError) evolveKey slotNo hotKey = case hotKey of HotKey keyPeriod oldKey | keyPeriod >= targetPeriod -> (hotKey, Updated hotKey) | otherwise - -> case updateKES () oldKey keyPeriod of - Nothing -> - (HotKeyPoisoned, UpdateFailed $ HotKeyEvolutionError targetPeriod) - Just newKey -> - evolveKey slotNo (HotKey (keyPeriod + 1) newKey) + -> let newKeyMay = unsoundPureUpdateKES () oldKey keyPeriod + in case newKeyMay of + Nothing -> + (HotKeyPoisoned, UpdateFailed $ HotKeyEvolutionError targetPeriod) + Just newKey -> + evolveKey slotNo (HotKey (keyPeriod + 1) newKey) HotKeyPoisoned -> (HotKeyPoisoned, UpdateFailed $ HotKeyEvolutionError targetPeriod) where @@ -251,13 +258,15 @@ forgePraosFields :: ( PraosCrypto c => PraosProof c -> HotKey c -> (PraosExtraFields c -> toSign) - -> PraosFields c toSign + -> (PraosFields c toSign) forgePraosFields PraosProof{..} hotKey mkToSign = case hotKey of - HotKey kesPeriod key -> PraosFields { - praosSignature = signedKES () kesPeriod (mkToSign fieldsToSign) key - , praosExtraFields = fieldsToSign - } + HotKey kesPeriod key -> + let signed = unsoundPureSignedKES () kesPeriod (mkToSign fieldsToSign) key + in PraosFields { + praosSignature = signed + , praosExtraFields = fieldsToSign + } HotKeyPoisoned -> error "trying to sign with a poisoned key" where fieldsToSign = PraosExtraFields { @@ -406,14 +415,14 @@ infosEta :: forall c. (PraosCrypto c) -> [BlockInfo c] -> EpochNo -> Natural -infosEta l _ 0 = +infosEta l _ (EpochNo 0) = praosInitialEta l -infosEta l@PraosConfig{praosParams = PraosParams{..}} xs e = +infosEta l@PraosConfig{praosParams = PraosParams{..}} xs (EpochNo e) = let e' = e - 1 -- the η from the previous epoch - eta' = infosEta l xs e' + eta' = infosEta l xs (EpochNo e') -- the first slot in previous epoch - from = epochFirst l e' + from = epochFirst l (EpochNo e') -- 2/3 of the slots per epoch n = div (2 * praosSlotsPerEpoch) 3 -- the last of the 2/3 of slots in this epoch @@ -591,7 +600,7 @@ rhoYT st xs s nid = Crypto models -------------------------------------------------------------------------------} -class ( KESAlgorithm (PraosKES c) +class ( UnsoundPureKESAlgorithm (PraosKES c) , VRFAlgorithm (PraosVRF c) , HashAlgorithm (PraosHash c) , Typeable c @@ -618,6 +627,40 @@ instance PraosCrypto PraosMockCrypto where type PraosVRF PraosMockCrypto = MockVRF type PraosHash PraosMockCrypto = SHA256 +{------------------------------------------------------------------------------- + Orphan instances to make Ed448 look like a proper mlocked DSIGN +-------------------------------------------------------------------------------} + +instance DSIGNMAlgorithm Ed448DSIGN where + data SignKeyDSIGNM Ed448DSIGN = SignKeyDSIGNMEd448 (SignKeyDSIGN Ed448DSIGN) + deriving (Generic) + + deriveVerKeyDSIGNM (SignKeyDSIGNMEd448 sk) = + return $ deriveVerKeyDSIGN sk + + signDSIGNM context signable (SignKeyDSIGNMEd448 sk) = + return $ signDSIGN context signable sk + + genKeyDSIGNMWith _ mlockedSeed = do + seed <- mlockedSeedUseAsCPtr mlockedSeed $ \seedPtr -> do + mkSeedFromBytes <$> packByteStringCStringLen (castPtr seedPtr, fromIntegral $ seedSizeDSIGN (Proxy :: Proxy Ed448DSIGN)) + return . SignKeyDSIGNMEd448 $ genKeyDSIGN seed + + cloneKeyDSIGNMWith _ sk = return sk + + getSeedDSIGNMWith _ _ _ = + error "getSeed not implemented for Ed448" + + forgetSignKeyDSIGNMWith _ _ = + -- This is fake mlocking, so just don't forget anything + return () + +deriving instance NoThunks (SignKeyDSIGNM Ed448DSIGN) + +instance UnsoundDSIGNMAlgorithm Ed448DSIGN where + rawSerialiseSignKeyDSIGNM = error "Not implemented: rawSerialiseSignKeyDSIGNM" + rawDeserialiseSignKeyDSIGNMWith = error "Not implemented: rawDeserialiseSignKeyDSIGNMWith" + {------------------------------------------------------------------------------- Condense -------------------------------------------------------------------------------} diff --git a/sop-extras/src/Data/SOP/OptNP.hs b/sop-extras/src/Data/SOP/OptNP.hs index 488967f471..15bc7b22b9 100644 --- a/sop-extras/src/Data/SOP/OptNP.hs +++ b/sop-extras/src/Data/SOP/OptNP.hs @@ -142,9 +142,28 @@ ctraverse' _ f = go go (OptSkip xs) = OptSkip <$> go xs go OptNil = pure OptNil +ctraverse_ :: + forall c proxy empty xs f g. (All c xs, Applicative g) + => proxy c -> (forall a. c a => f a -> g ()) -> OptNP empty f xs -> g () +ctraverse_ _ f = go + where + go :: All c ys => OptNP empty' f ys -> g () + go (OptCons x xs) = f x *> go xs + go (OptSkip xs) = go xs + go OptNil = pure () + +traverse_ :: + forall empty xs f g. (SListI xs, Applicative g) + => (forall a. f a -> g ()) -> OptNP empty f xs -> g () +traverse_ f = ctraverse_ (Proxy @Top) f + instance HAp (OptNP empty) where hap = ap +instance HTraverse_ (OptNP empty) where + hctraverse_ = ctraverse_ + htraverse_ = traverse_ + instance HSequence (OptNP empty) where hctraverse' = ctraverse' htraverse' = hctraverse' (Proxy @Top)