Add genCoreNodeKeys that can be used in consensus

Create some helper functions and instances to make this possible

Author: lehins

eras/shelley/test-suite/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.6.0.0
 
+* Add `genCoreNodeKeys` and `genIssuerKeys`
 * Move `VRFNatVal` into `cardano-protocol-tpraos:testlib`
 * Account for removal of crypto parametrization
 * Remove crypto parametrization from `PoolSetUpArgs`, `PoolInfo`, `RewardUpdateOld`

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Presets.hs

@@ -10,6 +10,8 @@
 --   Functions in this module make specific assumptions about the sets of keys
 --   involved, and thus cannot be used as generic generators.
 module Test.Cardano.Ledger.Shelley.Generator.Presets (
+  genCoreNodeKeys,
+  genIssuerKeys,
   coreNodeKeys,
   keySpace,
   genEnv,
@@ -28,25 +30,20 @@ import Cardano.Ledger.Keys (
   coerceKeyRole,
   hashKey,
  )
-import Cardano.Protocol.Crypto (hashVerKeyVRF)
-import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
-import Data.List.NonEmpty (NonEmpty ((:|)))
+import Cardano.Protocol.Crypto (Crypto, hashVerKeyVRF)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Proxy (Proxy (..))
 import Data.Word (Word64)
+import Test.Cardano.Ledger.Common
 import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
 import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
 import Test.Cardano.Ledger.Shelley.Generator.Core
 import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), allScripts, someKeyPairs)
 import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (keyPairs)
-import Test.Cardano.Ledger.Shelley.Utils (
-  maxKESIterations,
-  mkKESKeyPair,
-  mkVRFKeyPair,
-  slotsPerKESIteration,
- )
+import Test.Cardano.Ledger.Shelley.Utils (maxKESIterations, slotsPerKESIteration)
+import Test.Cardano.Protocol.TPraos.Create (genAllIssuerKeys)
 
 -- =================================================================
 
@@ -97,62 +94,47 @@ keySpace c =
 -- NOTE: we use a seed range in the [1000...] range
 -- to create keys that don't overlap with any of the other generated keys
 coreNodeKeys ::
+  Crypto c =>
   Constants ->
-  [(KeyPair 'Genesis, AllIssuerKeys MockCrypto 'GenesisDelegate)]
-coreNodeKeys c@Constants {numCoreNodes} =
-  [ ( (toKeyPair . mkGenKey) (RawSeed x 0 0 0 0)
-    , issuerKeys c 0 x
-    )
-  | x <- [1001 .. 1000 + numCoreNodes]
-  ]
-  where
-    toKeyPair (sk, vk) = KeyPair vk sk
+  [(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
+coreNodeKeys = runGen 1000 30 . genCoreNodeKeys
+
+genCoreNodeKeys ::
+  Crypto c =>
+  Constants ->
+  Gen [(KeyPair 'Genesis, AllIssuerKeys c 'GenesisDelegate)]
+genCoreNodeKeys c@Constants {numCoreNodes} =
+  replicateM (fromIntegral numCoreNodes) $ (,) <$> arbitrary <*> genIssuerKeys c
 
 -- Pre-generate a set of keys to use for genesis delegates.
-genesisDelegates :: Constants -> [AllIssuerKeys MockCrypto 'GenesisDelegate]
+genesisDelegates :: Crypto c => Constants -> [AllIssuerKeys c 'GenesisDelegate]
 genesisDelegates c =
   [ issuerKeys c 20 x
   | x <- [0 .. 50]
   ]
 
 -- Pre-generate a set of keys to use for stake pools.
-stakePoolKeys :: Constants -> [AllIssuerKeys MockCrypto 'StakePool]
+stakePoolKeys :: Crypto c => Constants -> [AllIssuerKeys c 'StakePool]
 stakePoolKeys c =
   [ issuerKeys c 10 x
   | x <- [0 .. 50]
   ]
 
 -- | Generate all keys for any entity which will be issuing blocks.
 issuerKeys ::
+  Crypto c =>
   Constants ->
   -- | Namespace parameter. Can be used to differentiate between different
   --   "types" of issuer.
   Word64 ->
   Word64 ->
-  AllIssuerKeys MockCrypto r
-issuerKeys Constants {maxSlotTrace} ns x =
-  let (skCold, vkCold) = mkKeyPair (RawSeed x 0 0 0 (ns + 1))
-      iters =
-        0
-          :| [ 1
-             .. 1
-              + ( maxSlotTrace
-                    `div` fromIntegral (maxKESIterations * slotsPerKESIteration)
-                )
-             ]
-   in AllIssuerKeys
-        { aikCold = KeyPair vkCold skCold
-        , aikHot =
-            fmap
-              ( \iter ->
-                  ( KESPeriod (fromIntegral (iter * fromIntegral maxKESIterations))
-                  , mkKESKeyPair (RawSeed x 0 0 (fromIntegral iter) (ns + 3))
-                  )
-              )
-              iters
-        , aikVrf = mkVRFKeyPair (RawSeed x 0 0 0 (ns + 2))
-        , aikColdKeyHash = hashKey vkCold
-        }
+  AllIssuerKeys c r
+issuerKeys c ns x =
+  runGen (fromIntegral x) 30 $ variant ns (genIssuerKeys c)
+
+genIssuerKeys :: Crypto c => Constants -> Gen (AllIssuerKeys c r)
+genIssuerKeys Constants {maxSlotTrace} =
+  genAllIssuerKeys maxSlotTrace maxKESIterations slotsPerKESIteration
 
 genesisDelegs0 ::
   Constants ->
@@ -164,7 +146,7 @@ genesisDelegs0 c =
           (coerceKeyRole . hashVKey $ aikCold pkeys)
           (hashVerKeyVRF @MockCrypto . vrfVerKey $ aikVrf pkeys)
       )
-    | (gkey, pkeys) <- coreNodeKeys c
+    | (gkey, pkeys) <- coreNodeKeys @MockCrypto c
     ]
   where
     hashVKey = hashKey . vKey

libs/cardano-ledger-core/CHANGELOG.md

@@ -7,7 +7,7 @@
 * Move `Cardano.Ledger.SnapShots` module contents into `Cardano.Ledger.State` and deprecated the former
 * Move `Cardano.Ledger.UTxO` module contents into `Cardano.Ledger.State` and deprecated the former
 * Add `CanGetUTxO` and `CanSetUTxO` type classes
-* Add `CanGetUTxO` and `CanSetUTxO` instances for `UTxO` 
+* Add `CanGetUTxO` and `CanSetUTxO` instances for `UTxO`
 * Add `DecShareCBOR` instances for `DRep` and `DRepState`
 * Added `ToPlutusData` instance for `NonZero`
 * `maxpool'` now expects `nOpt` to be a `NonZero Word16`
@@ -99,6 +99,7 @@
 
 ### `testlib`
 
+* Add `runGen`
 * Added `Arbitrary` and `ToExpr` instances for `NonZero`
 * Deprecate `genBadPtr`, `genAddrBadPtr` and `genCompactAddrBadPtr`
 * Remove crypto parametrization from types: `KeyPair` and `KeyPairs`

libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Common.hs

@@ -4,6 +4,7 @@ module Test.Cardano.Ledger.Common (
   ledgerTestMainWith,
   ledgerHspecConfig,
   NFData,
+  runGen,
 
   -- * Expr
   ToExpr (..),
@@ -63,6 +64,8 @@ import Test.Hspec.Runner
 import Test.ImpSpec (ansiDocToString, impSpecConfig, impSpecMainWithConfig)
 import Test.ImpSpec.Expectations
 import Test.QuickCheck as X
+import Test.QuickCheck.Gen (Gen (..))
+import Test.QuickCheck.Random (mkQCGen)
 import UnliftIO.Exception (evaluateDeep)
 
 infix 1 `shouldBeExpr`
@@ -110,3 +113,13 @@ shouldBeLeftExpr e x = expectLeftExpr e >>= (`shouldBeExpr` x)
 -- | Same as `Test.QuickCheck.discard` but outputs a debug trace message
 tracedDiscard :: String -> a
 tracedDiscard message = (if False then Debug.trace $ "\nDiscarded trace: " ++ message else id) discard
+
+runGen ::
+  -- | Seed
+  Int ->
+  -- | Size
+  Int ->
+  -- | Generator to run.
+  Gen a ->
+  a
+runGen seed size gen = unGen gen (mkQCGen seed) size

libs/cardano-protocol-tpraos/CHANGELOG.md

@@ -14,6 +14,8 @@
 
 ### `testlib`
 
+* Add `genAllIssuerKeys`
+* Add `Arbitrary` instances for `KESKeyPair` and `VRFKeyPair`
 * Move `VRFNatVal` from `cardano-ledger-shelley-test` in here.
 * Change type of `kesSignKey` in `KESKeyPair` and result of `evolveKESUntil` from `SignKeyKES` to `UnsoundPureSignKeyKES`
 

libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/Crypto/KES.hs

@@ -1,14 +1,26 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Test.Cardano.Protocol.Crypto.KES (
   KESKeyPair (..),
 ) where
 
+import Cardano.Crypto.KES (
+  UnsoundPureKESAlgorithm (..),
+  seedSizeKES,
+  unsoundPureDeriveVerKeyKES,
+  unsoundPureGenKeyKES,
+ )
 import qualified Cardano.Crypto.KES.Class as KES
+import Cardano.Crypto.Seed
 import Cardano.Protocol.Crypto
+import Data.Proxy
+import Test.Cardano.Ledger.Binary.Arbitrary (genByteString)
+import Test.Cardano.Ledger.Common
 
 data KESKeyPair c = KESKeyPair
   { kesSignKey :: !(KES.UnsoundPureSignKeyKES (KES c))
@@ -19,3 +31,20 @@ instance Show (KES.VerKeyKES (KES c)) => Show (KESKeyPair c) where
   show (KESKeyPair _ vk) =
     -- showing `SignKeyKES` is impossible for security reasons.
     "KESKeyPair <SignKeyKES> " <> show vk
+
+-- TODO: upstream into `cardano-base`
+
+-- | Generate a `Seed` with specified number of bytes, which can only be positive.
+genSeedN :: HasCallStack => Int -> Gen Seed
+genSeedN n
+  | n >= 1 = mkSeedFromBytes <$> genByteString n
+  | otherwise = error $ "Seed cannot be empty. Supplied " ++ show n ++ " for the size of the seed"
+
+instance Crypto c => Arbitrary (KESKeyPair c) where
+  arbitrary = do
+    signKey <- unsoundPureGenKeyKES <$> genSeedN (fromIntegral (seedSizeKES (Proxy @(KES c))))
+    pure $
+      KESKeyPair
+        { kesSignKey = signKey
+        , kesVerKey = unsoundPureDeriveVerKeyKES signKey
+        }

libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/Crypto/VRF.hs

@@ -9,6 +9,7 @@ module Test.Cardano.Protocol.Crypto.VRF (
 
 import qualified Cardano.Crypto.VRF.Class as VRF
 import Cardano.Protocol.Crypto
+import Test.Cardano.Ledger.Common
 
 data VRFKeyPair c = VRFKeyPair
   { vrfSignKey :: !(VRF.SignKeyVRF (VRF c))
@@ -17,3 +18,12 @@ data VRFKeyPair c = VRFKeyPair
 
 deriving instance
   (Show (VRF.SignKeyVRF (VRF c)), Show (VRF.VerKeyVRF (VRF c))) => Show (VRFKeyPair c)
+
+instance (Crypto c, Arbitrary (VRF.SignKeyVRF (VRF c))) => Arbitrary (VRFKeyPair c) where
+  arbitrary = do
+    signKey <- arbitrary
+    pure $
+      VRFKeyPair
+        { vrfSignKey = signKey
+        , vrfVerKey = VRF.deriveVerKeyVRF signKey
+        }

libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs

@@ -5,13 +5,15 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Test.Cardano.Protocol.TPraos.Create (
   AllIssuerKeys (..),
+  genAllIssuerKeys,
   KESKeyPair (..),
   VRFKeyPair (..),
   mkOCert,
@@ -52,12 +54,14 @@ import Cardano.Protocol.TPraos.OCert (
   OCert (..),
   OCertSignable (..),
  )
+import Control.Monad (forM)
 import Data.Coerce
 import Data.List.NonEmpty as NE
 import Data.Ratio (denominator, numerator, (%))
 import Data.Sequence.Strict as StrictSeq
 import Data.Word
 import Numeric.Natural
+import Test.Cardano.Ledger.Common
 import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
 import Test.Cardano.Protocol.Crypto.KES (KESKeyPair (..))
 import Test.Cardano.Protocol.Crypto.VRF (VRFKeyPair (..))
@@ -74,6 +78,33 @@ deriving instance
   (Show (VRF.SignKeyVRF (VRF c)), Show (VRF.VerKeyVRF (VRF c)), Show (KES.VerKeyKES (KES c))) =>
   Show (AllIssuerKeys c r)
 
+genAllIssuerKeys ::
+  Crypto c =>
+  -- | Maxium slot number
+  Int ->
+  -- | This corresponds to number of KES evolutions `Cardano.Ledger.BaseTypes.maxKESEvo` from
+  -- `Cardano.Ledger.BaseTypes.Globals`.
+  Word64 ->
+  -- | This corresponds to number of KES evolutions `Cardano.Ledger.BaseTypes.slotsPerKESPeriod` from
+  -- `Cardano.Ledger.BaseTypes.Globals`.
+  Word64 ->
+  Gen (AllIssuerKeys c r)
+genAllIssuerKeys maxSlotNumber maxKESIterations slotsPerKESPeriod = do
+  coldKeyPair <- arbitrary
+  let maxIter =
+        maxSlotNumber `div` fromIntegral (maxKESIterations * slotsPerKESPeriod)
+      iters = 0 :| [1 .. 1 + maxIter]
+  hotKESKeys <- forM iters $ \iter ->
+    (KESPeriod (fromIntegral (iter * fromIntegral maxKESIterations)),) <$> arbitrary
+  vrfKeyPair <- arbitrary
+  pure $
+    AllIssuerKeys
+      { aikCold = coldKeyPair
+      , aikHot = hotKESKeys
+      , aikVrf = vrfKeyPair
+      , aikColdKeyHash = hashKey (vKey coldKeyPair)
+      }
+
 mkOCert ::
   forall c r.
   Crypto c =>