create-testnet-data: more fine-grained generation of Byron files

IntersectMBO · Nov 21, 2024 · e862761 · e862761
1 parent d0fe09b
commit e862761
Show file tree

Hide file tree

Showing 4 changed files with 54 additions and 25 deletions.
diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal
@@ -218,6 +218,7 @@ library
     containers,
     contra-tracer,
     cryptonite,
+    data-default-class,
     deepseq,
     directory,
     exceptions,

diff --git a/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs b/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs
@@ -1,8 +1,10 @@
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Cardano.CLI.Byron.Genesis
   ( ByronGenesisError (..)
+  , DumpGenesis (..)
   , GenesisParameters (..)
   , NewDirectory (..)
   , dumpGenesis
@@ -23,12 +25,14 @@ import           Cardano.CLI.Types.Common (GenesisFile (..))
 import qualified Cardano.Crypto as Crypto
 import           Cardano.Prelude (canonicalDecodePretty, canonicalEncodePretty)
 
+import           Control.Monad (when)
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans (MonadTrans (..))
 import           Control.Monad.Trans.Except (ExceptT (..), withExceptT)
 import           Control.Monad.Trans.Except.Extra (firstExceptT, left, right)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as LB
+import           Data.Default.Class
 import qualified Data.List as List
 import qualified Data.Map.Strict as Map
 import           Data.String (IsString)
@@ -156,43 +160,65 @@ readGenesis (GenesisFile file) nw =
         , Byron.configUTxOConfiguration = Byron.defaultUTxOConfiguration
         }
 
+-- | Toggles to decide what to write in 'dumpGenesis'. Useful because if we write
+-- everything all the time, deleting after the fact isn't super reliable on Windows.
+-- Use the 'Default' instance to write everything.
+data DumpGenesis = DumpGenesis
+  { writeGenesis :: Bool
+  , writeGenesisKeys :: Bool
+  , writeDelegateKeys :: Bool
+  , writePoorKeys :: Bool
+  , writeDelegationCert :: Bool
+  , writeAvvmSecrets :: Bool
+  }
+
+instance Default DumpGenesis where
+  def = DumpGenesis True True True True True True
+
 -- | Write out genesis into a directory that must not yet exist.  An error is
 -- thrown if the directory already exists, or the genesis has delegate keys that
 -- are not delegated to.
 dumpGenesis
-  :: NewDirectory
+  :: DumpGenesis
+  -> NewDirectory
   -> Byron.GenesisData
   -> Byron.GeneratedSecrets
   -> ExceptT ByronGenesisError IO ()
-dumpGenesis (NewDirectory outDir) genesisData gs = do
+dumpGenesis DumpGenesis{..} (NewDirectory outDir) genesisData gs = do
   exists <- liftIO $ doesPathExist outDir
   if exists
     then left $ GenesisOutputDirAlreadyExists outDir
     else liftIO $ createDirectory outDir
-  liftIO $ LB.writeFile genesisJSONFile (canonicalEncodePretty genesisData)
+  when writeGenesis (liftIO $ LB.writeFile genesisJSONFile (canonicalEncodePretty genesisData))
 
   dlgCerts <- mapM (findDelegateCert . ByronSigningKey) $ Byron.gsRichSecrets gs
 
-  liftIO $
-    wOut
-      "genesis-keys"
-      "key"
-      serialiseToRawBytes
-      (map ByronSigningKey $ Byron.gsDlgIssuersSecrets gs)
-  liftIO $
-    wOut
-      "delegate-keys"
-      "key"
-      serialiseToRawBytes
-      (map ByronSigningKey $ Byron.gsRichSecrets gs)
-  liftIO $
-    wOut
-      "poor-keys"
-      "key"
-      serialiseToRawBytes
-      (map (ByronSigningKey . Byron.poorSecretToKey) $ Byron.gsPoorSecrets gs)
-  liftIO $ wOut "delegation-cert" "json" serialiseDelegationCert dlgCerts
-  liftIO $ wOut "avvm-secrets" "secret" printFakeAvvmSecrets $ Byron.gsFakeAvvmSecrets gs
+  when writeGenesisKeys $
+    liftIO $
+      wOut
+        "genesis-keys"
+        "key"
+        serialiseToRawBytes
+        (map ByronSigningKey $ Byron.gsDlgIssuersSecrets gs)
+  when writeDelegateKeys $
+    liftIO $
+      wOut
+        "delegate-keys"
+        "key"
+        serialiseToRawBytes
+        (map ByronSigningKey $ Byron.gsRichSecrets gs)
+  when writePoorKeys $
+    liftIO $
+      wOut
+        "poor-keys"
+        "key"
+        serialiseToRawBytes
+        (map (ByronSigningKey . Byron.poorSecretToKey) $ Byron.gsPoorSecrets gs)
+  when writeDelegationCert $ liftIO $ wOut "delegation-cert" "json" serialiseDelegationCert dlgCerts
+  when writeAvvmSecrets $
+    liftIO $
+      wOut "avvm-secrets" "secret" printFakeAvvmSecrets $
+        Byron.gsFakeAvvmSecrets gs
  where
   dlgCertMap = Byron.unGenesisDelegation $ Byron.gdHeavyDelegation genesisData
 

diff --git a/cardano-cli/src/Cardano/CLI/Byron/Run.hs b/cardano-cli/src/Cardano/CLI/Byron/Run.hs
@@ -27,6 +27,7 @@ import qualified Cardano.Crypto.Signing as Crypto
 
 import           Data.Bifunctor (Bifunctor (..))
 import qualified Data.ByteString.Char8 as BS
+import           Data.Default.Class
 import           Data.Text (Text)
 import qualified Data.Text.IO as Text
 import qualified Data.Text.Lazy.Builder as Builder
@@ -91,7 +92,7 @@ runNodeCmds (UpdateProposal nw sKey pVer sVer sysTag insHash outputFp params) =
 runGenesisCommand :: NewDirectory -> GenesisParameters -> ExceptT ByronClientCmdError IO ()
 runGenesisCommand outDir params = do
   (genData, genSecrets) <- firstExceptT ByronCmdGenesisError $ mkGenesis params
-  firstExceptT ByronCmdGenesisError $ dumpGenesis outDir genData genSecrets
+  firstExceptT ByronCmdGenesisError $ dumpGenesis def outDir genData genSecrets
 
 runValidateCBOR :: CBORObject -> FilePath -> ExceptT ByronClientCmdError IO ()
 runValidateCBOR cborObject fp = do

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis/CreateTestnetData.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Genesis/CreateTestnetData.hs
@@ -393,11 +393,12 @@ runGenesisCreateTestNetDataCmd
 
     let byronGenesisParameters = mkByronGenesisParameters actualNetworkWord32 byronGenesisFp shelleyGenesis'
         byronOutputDir = outputDir </> "byron-gen-command"
+        dumpGenesis = Byron.DumpGenesis False False True True True False
     (byronGenesis, byronSecrets) <-
       firstExceptT GenesisCmdByronError $ Byron.mkGenesis byronGenesisParameters
 
     firstExceptT GenesisCmdByronError $
-      Byron.dumpGenesis (NewDirectory byronOutputDir) byronGenesis byronSecrets
+      Byron.dumpGenesis dumpGenesis (NewDirectory byronOutputDir) byronGenesis byronSecrets
 
     -- Move things from byron-gen-command to the nodes' directories
     forM_ [1 .. min byronPoolNumber numPools] $ \index -> do