Upgrade cardano-base dependency to support mlocked KES

cabal.project

@@ -36,3 +36,64 @@ import: ./asserts.cabal
 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: a2f139eb08255741860751e05e5f37177ff9145c
+  --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/input-output-hk/cardano-ledger-executable-spec.git
+  tag: ddfb7f4a311dcc52971b3bb847ba52b68d0b0a3f
+  --sha256: sha256-dQVyvzVhVUOsLUuX8XQvN/wPGmbIvYeAmX7RpnT1gk8=
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/cardano-ledger
+  tag: ddb5b99fe86f88faf00ed63c3304922d3798b22b
+  --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

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

@@ -29,7 +29,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
@@ -93,9 +93,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
 

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs

@@ -58,6 +58,7 @@ module Ouroboros.Consensus.Cardano.Node (
 
 import           Cardano.Binary (DecoderError (..), enforceSize)
 import           Cardano.Chain.Slotting (EpochSlots)
+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.BaseTypes as SL
@@ -1048,7 +1049,8 @@ protocolInfoCardano paramsCardano
               startPeriod :: Absolute.KESPeriod
               startPeriod = Absolute.ocertKESPeriod $ praosCanBeLeaderOpCert canBeLeader
 
-          HotKey.mkHotKey @m @c initSignKey startPeriod maxKESEvo
+          skSound <- KES.unsoundPureSignKeyKESToSoundSignKeyKES initSignKey
+          HotKey.mkHotKey @m @c skSound startPeriod maxKESEvo
 
         let slotToPeriod :: SlotNo -> Absolute.KESPeriod
             slotToPeriod (SlotNo slot) = assert (tpraosSlotsPerKESPeriod == praosSlotsPerKESPeriod) $

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

@@ -52,7 +52,12 @@ data ShelleyLeaderCredentials c = ShelleyLeaderCredentials
     --
     -- Note that this is not inside 'ShelleyCanBeLeader' since it gets evolved
     -- automatically, whereas 'ShelleyCanBeLeader' does not change.
-    shelleyLeaderCredentialsInitSignKey :: SL.SignKeyKES c,
+    -- TODO: this currently uses 'UnsoundPureSignKeyKES', so the KES key is not
+    -- mlocked, and does not provide full forward security. Eventually, this
+    -- field should be removed entirely, and the KES sign key acquired through
+    -- different means, ensuring a fully mlocked in-memory chain from key
+    -- generation to block forging.
+    shelleyLeaderCredentialsInitSignKey :: SL.UnsoundPureSignKeyKES c,
     shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c,
     -- | Identifier for this set of credentials.
     --

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

@@ -20,6 +20,7 @@ module Ouroboros.Consensus.Shelley.Node.Praos (
   , ProtocolParams (..)
   ) where
 
+import qualified Cardano.Crypto.KES as KES
 import qualified Cardano.Ledger.Api.Era as L
 import qualified Cardano.Ledger.Shelley.API as SL
 import qualified Cardano.Protocol.TPraos.OCert as Absolute
@@ -60,7 +61,8 @@ praosBlockForging ::
   -> ShelleyLeaderCredentials (EraCrypto era)
   -> m (BlockForging m (ShelleyBlock (Praos c) era))
 praosBlockForging praosParams maxTxCapacityOverrides credentials = do
-    hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod praosMaxKESEvo
+    skSound <- KES.unsoundPureSignKeyKESToSoundSignKeyKES initSignKey
+    hotKey <- HotKey.mkHotKey @m @c skSound startPeriod praosMaxKESEvo
     pure $ praosSharedBlockForging hotKey slotToPeriod credentials maxTxCapacityOverrides
   where
     PraosParams {praosMaxKESEvo, praosSlotsPerKESPeriod} = praosParams

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

@@ -34,6 +34,7 @@ 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
@@ -94,7 +95,8 @@ shelleyBlockForging ::
   -> ShelleyLeaderCredentials (EraCrypto era)
   -> m (BlockForging m (ShelleyBlock (TPraos c) era))
 shelleyBlockForging tpraosParams maxTxCapacityOverrides credentials = do
-    hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod tpraosMaxKESEvo
+    skSound <- KES.unsoundPureSignKeyKESToSoundSignKeyKES initSignKey
+    hotKey <- HotKey.mkHotKey @m @c skSound startPeriod tpraosMaxKESEvo
     pure $ shelleySharedBlockForging hotKey slotToPeriod credentials maxTxCapacityOverrides
   where
     TPraosParams {tpraosMaxKESEvo, tpraosSlotsPerKESPeriod} = tpraosParams

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs

@@ -191,8 +191,7 @@ mkSimpleTestProtocolInfo
     byronSlotLenghtInSeconds
     shelleySlotLengthInSeconds
     hardForkSpec
-  = fst
-  $ mkTestProtocolInfo @IO
+  = fst $ mkTestProtocolInfo @IO
       (CoreNodeId 0, coreNodeShelley)
       shelleyGenesis
       byronProtocolVersion
@@ -268,8 +267,7 @@ mkTestProtocolInfo
     generatedSecretsByron
     aByronPbftSignatureThreshold
     hardForkSpec
-  =
-    protocolInfoCardano
+  = protocolInfoCardano
         (CardanoProtocolParams
           ProtocolParamsByron {
               byronGenesis                = genesisByron
@@ -338,9 +336,9 @@ mkTestProtocolInfo
           generatedSecretsByron
           coreNodeId
 
+    leaderCredentialsShelley :: ShelleyLeaderCredentials c
+    leaderCredentialsShelley = Shelley.mkLeaderCredentials coreNode
+
     -- This sets a vestigial header field which is not actually used for anything.
     softVerByron :: CC.Update.SoftwareVersion
     softVerByron = Byron.theProposedSoftwareVersion
-
-    leaderCredentialsShelley :: ShelleyLeaderCredentials c
-    leaderCredentialsShelley = Shelley.mkLeaderCredentials coreNode

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

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 (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

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