Make --stake-delegators write credentials to disk. Keep current behav…

…ior with --transient-stake-delegators.

cardano-cli/src/Cardano/CLI/EraBased/Commands/Genesis.hs

@@ -87,7 +87,7 @@ data GenesisCreateTestNetDataCmdArgs = GenesisCreateTestNetDataCmdArgs
   { specShelley :: !(Maybe FilePath) -- ^ Path to the @genesis-shelley@ file to use. If unspecified, a default one will be used if omitted.
   , numGenesisKeys :: !Word -- ^ The number of genesis keys credentials to create and write to disk.
   , numPools :: !Word -- ^ The number of stake pools credentials to create and write to disk.
-  , numStakeDelegators :: !Word -- ^ The number of delegators to pools to create and write to disk.
+  , stakeDelegators :: !StakeDelegators -- ^ The number of delegators to pools to create.
   , numStuffedUtxo :: !Word -- ^ The number of UTxO accounts to make. They are "stuffed" because the credentials are not written to disk.
   , numUtxoKeys :: !Word -- ^ The number of UTxO credentials to create and write to disk.
   , supply :: !(Maybe Lovelace) -- ^ The number of Lovelace to distribute over initial, non-delegating stake holders.

cardano-cli/src/Cardano/CLI/EraBased/Options/Genesis.hs

@@ -232,14 +232,19 @@ pGenesisCreateTestNetData envCli =
         , Opt.help "The number of stake pool credential sets to make (default is 0)."
         , Opt.value 0
         ]
-    pNumStakeDelegs :: Parser Word
+    pNumStakeDelegs :: Parser StakeDelegators
     pNumStakeDelegs =
-      Opt.option Opt.auto $ mconcat
-        [ Opt.long "stake-delegators"
-        , Opt.metavar "INT"
-        , Opt.help "The number of stake delegator credential sets to make (default is 0)."
-        , Opt.value 0
-      ]
+      pNumOnDiskStakeDelegators <|> pNumTransientStakeDelegs
+      where
+        pNumOnDiskStakeDelegators = fmap OnDisk $ Opt.option Opt.auto $ mconcat $
+          [ Opt.long "stake-delegators"
+          , Opt.help "The number of stake delegator credential sets to make (default is 0). Credentials are written to disk."
+          ] ++ common
+        pNumTransientStakeDelegs = fmap Transient $ Opt.option Opt.auto $ mconcat $
+          [ Opt.long "transient-stake-delegators"
+          , Opt.help "The number of stake delegator credential sets to make (default is 0). The credentials are NOT written to disk."
+          ] ++ common
+        common = [Opt.metavar "INT", Opt.value 0]
     pNumStuffedUtxoCount :: Parser Word
     pNumStuffedUtxoCount =
       Opt.option Opt.auto $ mconcat

cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs

@@ -31,6 +31,7 @@ import           Cardano.Api.Shelley
 
 import           Cardano.CLI.EraBased.Commands.Genesis as Cmd
 import qualified Cardano.CLI.EraBased.Commands.Node as Cmd
+import           Cardano.CLI.EraBased.Run.Address (runAddressKeyGenCmd)
 import qualified Cardano.CLI.EraBased.Run.Key as Key
 import           Cardano.CLI.EraBased.Run.Node (runNodeIssueOpCertCmd, runNodeKeyGenColdCmd,
                    runNodeKeyGenKesCmd, runNodeKeyGenVrfCmd)
@@ -41,6 +42,7 @@ import           Cardano.CLI.Types.Errors.GenesisCmdError
 import           Cardano.CLI.Types.Errors.NodeCmdError
 import           Cardano.CLI.Types.Errors.StakePoolCmdError
 import           Cardano.CLI.Types.Key
+import qualified Cardano.CLI.Types.Key as Keys
 import           Cardano.Crypto.Hash (HashAlgorithm)
 import qualified Cardano.Crypto.Hash as Hash
 import qualified Cardano.Crypto.Random as Crypto
@@ -55,7 +57,7 @@ import qualified Cardano.Ledger.Shelley.API as Ledger
 import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesisStaking (..))
 
 import           Control.DeepSeq (NFData, force)
-import           Control.Monad (forM, forM_, unless, void)
+import           Control.Monad (forM, forM_, unless, void, zipWithM)
 import           Control.Monad.Except (MonadError (..), runExceptT)
 import           Control.Monad.IO.Class (MonadIO (..))
 import           Control.Monad.Trans.Except (ExceptT)
@@ -184,7 +186,7 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs
    , specShelley
    , numGenesisKeys
    , numPools
-   , numStakeDelegators
+   , stakeDelegators
    , numStuffedUtxo
    , numUtxoKeys
    , supply
@@ -207,10 +209,12 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs
       delegateKeys = mkPaths numGenesisKeys delegateDir "delegate" "key.vkey"
       -- {0 -> delegate-keys/delegate0/vrf.vkey, 1 -> delegate-keys/delegate1/vrf.vkey, ...}
       delegateVrfKeys = mkPaths numGenesisKeys delegateDir "delegate" "vrf.vkey"
+      -- {"stake-delegators/delegator1", "stake-delegators/delegator2", ...}
+      stakeDelegatorsDirs = [stakeDelegatorsDir </> "delegator" <> show i | i <- [1 .. numStakeDelegators]]
 
   forM_ [ 1 .. numGenesisKeys ] $ \index -> do
     createGenesisKeys (genesisDir </> ("genesis" <> show index))
-    createDelegateKeys keyOutputFormat (delegateDir </> ("delegate" <> show index))
+    createDelegateKeys desiredKeyOutputFormat (delegateDir </> ("delegate" <> show index))
 
   writeREADME genesisDir genesisREADME
   writeREADME delegateDir delegatesREADME
@@ -229,13 +233,19 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs
   poolParams <- forM [ 1 .. numPools ] $ \index -> do
     let poolDir = poolsDir </> ("pool" <> show index)
 
-    createPoolCredentials keyOutputFormat poolDir
+    createPoolCredentials desiredKeyOutputFormat poolDir
     buildPoolParams networkId poolDir Nothing (fromMaybe mempty mayStakePoolRelays)
 
   writeREADME poolsDir poolsREADME
 
   -- Stake delegators
-  let (delegsPerPool, delegsRemaining) = divMod numStakeDelegators numPools
+  case stakeDelegators of
+    OnDisk _ ->
+      forM_ [ 1 .. numStakeDelegators] $ \index -> do
+        createStakeDelegatorCredentials (stakeDelegatorsDir </> "delegator" <> show index)
+    Transient _ -> pure ()
+
+  let (delegsPerPool, delegsRemaining) = numStakeDelegators `divMod` numPools
       delegsForPool poolIx = if delegsRemaining /= 0 && poolIx == numPools
         then delegsPerPool
         else delegsPerPool + delegsRemaining
@@ -244,7 +254,16 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs
   g <- Random.getStdGen
 
   -- Distribute M delegates across N pools:
-  delegations <- liftIO $ Lazy.forStateM g distribution $ flip computeInsecureDelegation networkId
+  delegations <-
+    case stakeDelegators of
+      OnDisk _ -> do
+        let delegates = concat $ repeat stakeDelegatorsDirs
+        -- We don't need to be attentive to laziness here, because anyway this
+        -- doesn't scale really well (because we're generating legit credentials,
+        -- as opposed to the Transient case).
+        zipWithM (computeDelegation networkId) delegates distribution
+      Transient _ ->
+        liftIO $ Lazy.forStateM g distribution $ flip computeInsecureDelegation networkId
 
   genDlgs <- readGenDelegsMap genesisVKeysPaths delegateKeys delegateVrfKeys
   nonDelegAddrs <- readInitialFundAddresses utxoKeys networkId
@@ -269,10 +288,15 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs
     delegateDir = outputDir </> "delegate-keys"
     utxoKeysDir = outputDir </> "utxo-keys"
     poolsDir = outputDir </> "pools-keys"
-    keyOutputFormat = KeyOutputFormatTextEnvelope
+    stakeDelegatorsDir = outputDir </> "stake-delegators"
+    numStakeDelegators = case stakeDelegators of OnDisk n -> n; Transient n -> n
     mkDelegationMapEntry :: Delegation -> (Ledger.KeyHash Ledger.Staking StandardCrypto, Ledger.PoolParams StandardCrypto)
     mkDelegationMapEntry d = (dDelegStaking d, dPoolParams d)
 
+-- | The output format used all along this file
+desiredKeyOutputFormat :: KeyOutputFormat
+desiredKeyOutputFormat = KeyOutputFormatTextEnvelope
+
 writeREADME :: ()
   => FilePath
   -> Text.Text
@@ -366,6 +390,19 @@ createGenesisKeys dir = do
     , signingKeyPath = File @(SigningKey ()) $ dir </> "key.skey"
     }
 
+createStakeDelegatorCredentials :: FilePath -> ExceptT GenesisCmdError IO ()
+createStakeDelegatorCredentials dir = do
+  liftIO $ createDirectoryIfMissing True dir
+  firstExceptT GenesisCmdAddressCmdError $
+    runAddressKeyGenCmd desiredKeyOutputFormat AddressKeyShelley paymentVK paymentSK
+  firstExceptT GenesisCmdStakeAddressCmdError $
+    runStakeAddressKeyGenCmd desiredKeyOutputFormat stakingVK stakingSK
+  where
+    paymentVK = File @(VerificationKey ()) $ dir </> "payment.vkey"
+    paymentSK = File @(SigningKey ()) $ dir </> "payment.skey"
+    stakingVK = File @(VerificationKey ()) $ dir </> "staking.vkey"
+    stakingSK = File @(SigningKey ()) $ dir </> "staking.skey"
+
 createUtxoKeys :: FilePath -> ExceptT GenesisCmdError IO ()
 createUtxoKeys dir = do
   liftIO $ createDirectoryIfMissing True dir
@@ -458,6 +495,27 @@ buildPoolParams nw dir index specifiedRelays = do
    poolVrfVKF = File $ dir </> "vrf" ++ strIndex ++ ".vkey"
    poolRewardVKF = File $ dir </> "staking-reward" ++ strIndex ++ ".vkey"
 
+computeDelegation
+  :: NetworkId
+  -> FilePath
+  -> Ledger.PoolParams StandardCrypto
+  -> ExceptT GenesisCmdError IO Delegation
+computeDelegation nw delegDir dPoolParams = do
+    payVK   <- readVKeyFromDisk AsPaymentKey payVKF
+    stakeVK <- readVKeyFromDisk AsStakeKey   stakeVKF
+    let paymentCredential = PaymentCredentialByKey $ verificationKeyHash payVK
+        stakeAddrRef = StakeAddressByValue $ StakeCredentialByKey $ verificationKeyHash stakeVK
+        dInitialUtxoAddr = makeShelleyAddressInEra ShelleyBasedEraShelley nw paymentCredential stakeAddrRef
+        dDelegStaking = Ledger.hashKey $ unStakeVerificationKey stakeVK
+
+    pure $ Delegation { dInitialUtxoAddr, dDelegStaking, dPoolParams }
+   where
+     payVKF = File @(VerificationKey ()) $ delegDir </> "payment.vkey"
+     stakeVKF = File @(VerificationKey ()) $ delegDir </> "staking.vkey"
+     readVKeyFromDisk role file =
+      firstExceptT GenesisCmdFileInputDecodeError $ newExceptT $
+        Keys.readVerificationKeyOrFile role (VerificationKeyFilePath file)
+
 -- | This function should only be used for testing purposes.
 -- Keys returned by this function are not cryptographically secure.
 computeInsecureDelegation

cardano-cli/src/Cardano/CLI/Types/Common.hs

@@ -55,6 +55,7 @@ module Cardano.CLI.Types.Common
   , SigningKeyFile
   , SlotsTillKesKeyExpiry (..)
   , SomeKeyFile(..)
+  , StakeDelegators(..)
   , StakePoolMetadataFile
   , TransferDirection(..)
   , TxBodyFile
@@ -141,6 +142,11 @@ data VoteHashSource
   | VoteHashSourceHash (L.SafeHash Crypto.StandardCrypto L.AnchorData)
   deriving Show
 
+data StakeDelegators
+  = OnDisk !Word -- ^ The number of credentials to write to disk
+  | Transient !Word -- ^ The number of credentials, that are not written to disk
+  deriving Show
+
 -- | Specify whether to render the script cost as JSON
 -- in the cli's build command.
 data TxBuildOutputOptions = OutputScriptCostOnly (File () Out)

cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs

@@ -39,6 +39,7 @@ data GenesisCmdError
   | GenesisCmdByronError !ByronGenesisError
   | GenesisCmdStakePoolRelayFileError !FilePath !IOException
   | GenesisCmdStakePoolRelayJsonDecodeError !FilePath !String
+  | GenesisCmdFileInputDecodeError !(FileError InputDecodeError)
   deriving Show
 
 instance Error GenesisCmdError where
@@ -95,3 +96,5 @@ instance Error GenesisCmdError where
     GenesisCmdStakePoolRelayJsonDecodeError fp e ->
       "Error occurred while decoding the stake pool relay specification file: " <> pretty fp <>
       " Error: " <> pretty e
+    GenesisCmdFileInputDecodeError ide ->
+      "Error occured while decoding a file: " <> pshow ide