genesis creation: share code

Author: smelc

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

@@ -40,6 +40,7 @@ import qualified Cardano.CLI.Byron.Key as Byron
 import qualified Cardano.CLI.Commands.Node as Cmd
 import           Cardano.CLI.EraBased.Commands.Genesis as Cmd
 import           Cardano.CLI.EraBased.Run.Genesis.Common
+import           Cardano.CLI.EraBased.Run.Genesis.CreateTestnetData (WriteFileGenesis (..))
 import qualified Cardano.CLI.EraBased.Run.Genesis.CreateTestnetData as TN
 import           Cardano.CLI.EraBased.Run.StakeAddress (runStakeAddressKeyGenCmd)
 import qualified Cardano.CLI.IO.Lazy as Lazy
@@ -53,7 +54,6 @@ import           Cardano.CLI.Types.Key
 import qualified Cardano.Crypto as CC
 import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Signing as Byron
-import           Cardano.Prelude (canonicalEncodePretty)
 import           Cardano.Slotting.Slot (EpochSize (EpochSize))
 import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesisStaking (..))
 
@@ -72,7 +72,6 @@ import           Data.Char (isDigit)
 import           Data.Fixed (Fixed (MkFixed))
 import           Data.Function (on)
 import           Data.Functor (void)
-import           Data.Functor.Identity (Identity)
 import qualified Data.List as List
 import qualified Data.List.Split as List
 import           Data.ListMap (ListMap (..))
@@ -95,8 +94,6 @@ import qualified System.IO as IO
 import           System.IO.Error (isDoesNotExistError)
 import qualified System.Random as Random
 import           System.Random (StdGen)
-import qualified Text.JSON.Canonical (ToJSON)
-import           Text.JSON.Canonical (parseCanonicalJSON, renderCanonicalJSON)
 import           Text.Read (readMaybe)
 
 runGenesisCmds :: GenesisCmds era -> ExceptT GenesisCmdError IO ()
@@ -278,9 +275,9 @@ runGenesisCreateCmd
             []
             template
 
-    void $ writeFileGenesis (rootdir </> "genesis.json") $ WritePretty shelleyGenesis
-    void $ writeFileGenesis (rootdir </> "genesis.alonzo.json") $ WritePretty alonzoGenesis
-    void $ writeFileGenesis (rootdir </> "genesis.conway.json") $ WritePretty conwayGenesis
+    void $ TN.writeFileGenesis (rootdir </> "genesis.json") $ WritePretty shelleyGenesis
+    void $ TN.writeFileGenesis (rootdir </> "genesis.alonzo.json") $ WritePretty alonzoGenesis
+    void $ TN.writeFileGenesis (rootdir </> "genesis.conway.json") $ WritePretty conwayGenesis
    where
     -- TODO: rationalise the naming convention on these genesis json files.
 
@@ -478,13 +475,13 @@ runGenesisCreateCardanoCmd
       writeSecrets deldir "shelley" "counter.json" toCounter opCerts
 
     byronGenesisHash <-
-      writeFileGenesis (rootdir </> "byron-genesis.json") $ WriteCanonical byronGenesis
+      TN.writeFileGenesis (rootdir </> "byron-genesis.json") $ WriteCanonical byronGenesis
     shelleyGenesisHash <-
-      writeFileGenesis (rootdir </> "shelley-genesis.json") $ WritePretty shelleyGenesis
+      TN.writeFileGenesis (rootdir </> "shelley-genesis.json") $ WritePretty shelleyGenesis
     alonzoGenesisHash <-
-      writeFileGenesis (rootdir </> "alonzo-genesis.json") $ WritePretty alonzoGenesis
+      TN.writeFileGenesis (rootdir </> "alonzo-genesis.json") $ WritePretty alonzoGenesis
     conwayGenesisHash <-
-      writeFileGenesis (rootdir </> "conway-genesis.json") $ WritePretty conwayGenesis
+      TN.writeFileGenesis (rootdir </> "conway-genesis.json") $ WritePretty conwayGenesis
 
     liftIO $ do
       case mNodeConfigTemplate of
@@ -690,8 +687,8 @@ runGenesisCreateStakedCmd
 
     liftIO $ LBS.writeFile (rootdir </> "genesis.json") $ encodePretty shelleyGenesis
 
-    void $ writeFileGenesis (rootdir </> "genesis.alonzo.json") $ WritePretty alonzoGenesis
-    void $ writeFileGenesis (rootdir </> "genesis.conway.json") $ WritePretty conwayGenesis
+    void $ TN.writeFileGenesis (rootdir </> "genesis.alonzo.json") $ WritePretty alonzoGenesis
+    void $ TN.writeFileGenesis (rootdir </> "genesis.conway.json") $ WritePretty conwayGenesis
     -- TODO: rationalise the naming convention on these genesis json files.
 
     liftIO $
@@ -1151,29 +1148,6 @@ updateTemplate
     unLovelace :: Integral a => Lovelace -> a
     unLovelace (L.Coin coin) = fromIntegral coin
 
-writeFileGenesis
-  :: FilePath
-  -> WriteFileGenesis
-  -> ExceptT GenesisCmdError IO (Crypto.Hash Crypto.Blake2b_256 ByteString)
-writeFileGenesis fpath genesis = do
-  handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $
-    BS.writeFile fpath content
-  return $ Crypto.hashWith id content
- where
-  content = case genesis of
-    WritePretty a -> LBS.toStrict $ encodePretty a
-    WriteCanonical a ->
-      LBS.toStrict
-        . renderCanonicalJSON
-        . either (error . ("error parsing json that was just encoded!? " ++) . show) id
-        . parseCanonicalJSON
-        . canonicalEncodePretty
-        $ a
-
-data WriteFileGenesis where
-  WriteCanonical :: Text.JSON.Canonical.ToJSON Identity genesis => genesis -> WriteFileGenesis
-  WritePretty :: ToJSON genesis => genesis -> WriteFileGenesis
-
 -- ----------------------------------------------------------------------------
 
 readGenDelegsMap

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

@@ -18,6 +18,8 @@ module Cardano.CLI.EraBased.Run.Genesis.CreateTestnetData
   , runGenesisKeyGenDelegateCmd
   , runGenesisCreateTestNetDataCmd
   , runGenesisKeyGenDelegateVRF
+  , writeFileGenesis
+  , WriteFileGenesis (..)
   )
 where
 
@@ -49,13 +51,19 @@ 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.Crypto.Hash as Crypto
+import           Cardano.Prelude (canonicalEncodePretty)
 import           Ouroboros.Consensus.Shelley.Node (ShelleyGenesisStaking (..))
 
 import           Control.DeepSeq (NFData, deepseq)
 import           Control.Monad (forM, forM_, unless, void, when)
 import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
 import           Data.Bifunctor (Bifunctor (..))
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
+import           Data.Functor.Identity (Identity)
 import           Data.ListMap (ListMap (..))
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -74,6 +82,8 @@ import           System.Directory (createDirectoryIfMissing)
 import           System.FilePath ((</>))
 import qualified System.Random as Random
 import           System.Random (StdGen)
+import qualified Text.JSON.Canonical (ToJSON)
+import           Text.JSON.Canonical (parseCanonicalJSON, renderCanonicalJSON)
 
 runGenesisKeyGenGenesisCmd
   :: GenesisKeyGenGenesisCmdArgs
@@ -164,6 +174,29 @@ runGenesisKeyGenUTxOCmd
     skeyDesc = "Genesis Initial UTxO Signing Key"
     vkeyDesc = "Genesis Initial UTxO Verification Key"
 
+writeFileGenesis
+  :: FilePath
+  -> WriteFileGenesis
+  -> ExceptT GenesisCmdError IO (Crypto.Hash Crypto.Blake2b_256 ByteString)
+writeFileGenesis fpath genesis = do
+  handleIOExceptT (GenesisCmdGenesisFileError . FileIOError fpath) $
+    BS.writeFile fpath content
+  return $ Crypto.hashWith id content
+ where
+  content = case genesis of
+    WritePretty a -> LBS.toStrict $ Aeson.encodePretty a
+    WriteCanonical a ->
+      LBS.toStrict
+        . renderCanonicalJSON
+        . either (error . ("error parsing json that was just encoded!? " ++) . show) id
+        . parseCanonicalJSON
+        . canonicalEncodePretty
+        $ a
+
+data WriteFileGenesis where
+  WriteCanonical :: Text.JSON.Canonical.ToJSON Identity genesis => genesis -> WriteFileGenesis
+  WritePretty :: ToJSON genesis => genesis -> WriteFileGenesis
+
 runGenesisCreateTestNetDataCmd
   :: GenesisCreateTestNetDataCmdArgs era
   -> ExceptT GenesisCmdError IO ()