Merge pull request #908 from IntersectMBO/smelc/create-testnet-data-c…

…reate-node-config-file

create-testnet-data: take optional node configuration file as input and check/add genesis hashes and paths

cardano-cli/cardano-cli.cabal

@@ -306,6 +306,7 @@ test-suite cardano-cli-test
   type: exitcode-stdio-1.0
   build-depends:
     aeson,
+    aeson-pretty,
     base16-bytestring,
     bech32 >=1.1.0,
     bytestring,

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

@@ -94,6 +94,8 @@ data GenesisCreateStakedCmdArgs era = GenesisCreateStakedCmdArgs
 
 data GenesisCreateTestNetDataCmdArgs era = GenesisCreateTestNetDataCmdArgs
   { eon :: !(ShelleyBasedEra era)
+  , specNodeConfig :: !(Maybe FilePath)
+  -- ^ Path to the node configuration file to use. If unspecified, a default one will be used.
   , specShelley :: !(Maybe FilePath)
   -- ^ Path to the @genesis-shelley@ file to use. If unspecified, a default one will be used.
   , specAlonzo :: !(Maybe FilePath)

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

@@ -218,7 +218,8 @@ pGenesisCreateTestNetData :: ShelleyBasedEra era -> EnvCli -> Parser (GenesisCmd
 pGenesisCreateTestNetData sbe envCli =
   fmap GenesisCreateTestNetData $
     GenesisCreateTestNetDataCmdArgs sbe
-      <$> optional (pSpecFile "shelley")
+      <$> optional pNodeFile
+      <*> optional (pSpecFile "shelley")
       <*> optional (pSpecFile "alonzo")
       <*> optional (pSpecFile "conway")
       <*> pNumGenesisKeys
@@ -234,6 +235,10 @@ pGenesisCreateTestNetData sbe envCli =
       <*> pMaybeSystemStart
       <*> pOutputDir
  where
+  pNodeFile =
+    parseFilePath
+      "node-configuration"
+      "The node configuration file to use. Entries for hashes and paths of genesis files are checked if they exist. Otherwise they are filled in."
   pSpecFile eraStr =
     parseFilePath
       ("spec-" <> eraStr)

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

@@ -494,26 +494,15 @@ runGenesisCreateCardanoCmd
       writeFileGenesis (rootdir </> "conway-genesis.json") $ WritePretty conwayGenesis
 
     liftIO $ do
-      case mNodeConfigTemplate of
-        Nothing -> pure ()
-        Just nodeCfg -> do
-          nodeConfig <- Yaml.decodeFileThrow nodeCfg
-          let
-            setHash field hash = Aeson.insert field $ String $ Crypto.hashToTextAsHex hash
-            updateConfig :: Yaml.Value -> Yaml.Value
-            updateConfig (Object obj) =
-              Object $
-                setHash "ByronGenesisHash" byronGenesisHash $
-                  setHash "ShelleyGenesisHash" shelleyGenesisHash $
-                    setHash "AlonzoGenesisHash" alonzoGenesisHash $
-                      setHash
-                        "ConwayGenesisHash"
-                        conwayGenesisHash
-                        obj
-            updateConfig x = x
-            newConfig :: Yaml.Value
-            newConfig = updateConfig nodeConfig
-          encodeFile (rootdir </> "node-config.json") newConfig
+      forM_ mNodeConfigTemplate $ \nodeCfg -> do
+        let hashes =
+              Map.fromList
+                [ ("ByronGenesisHash", byronGenesisHash)
+                , ("ShelleyGenesisHash", shelleyGenesisHash)
+                , ("AlonzoGenesisHash", alonzoGenesisHash)
+                , ("ConwayGenesisHash", conwayGenesisHash)
+                ]
+        writeGenesisHashesToNodeConfigFile nodeCfg hashes (rootdir </> "node-config.json")
    where
     convertToShelleyError = withExceptT GenesisCmdByronError
     convertGenesisKey :: Byron.SigningKey -> SigningKey GenesisExtendedKey
@@ -572,6 +561,30 @@ runGenesisCreateCardanoCmd
     dlgCertMap :: Genesis.GenesisData -> Map Byron.KeyHash Dlg.Certificate
     dlgCertMap byronGenesis = Genesis.unGenesisDelegation $ Genesis.gdHeavyDelegation byronGenesis
 
+-- | @writeGenesisHashesToNodeConfigFile src hashes dest@ reads the node configuration file
+-- at @src@ and the writes an augmented version of this file at @dest@, with the hashes.
+writeGenesisHashesToNodeConfigFile
+  :: ()
+  => MonadIO m
+  => FilePath
+  -- ^ From where to read the node configuration file
+  -> Map.Map Aeson.Key (Crypto.Hash h a)
+  -- ^ Key of an era's hash (like "ByronGenesisHash", "ShelleyGenesisHash", etc.), to the hash of its genesis file
+  -> FilePath
+  -- ^ Where to write the updated node config file
+  -> m ()
+writeGenesisHashesToNodeConfigFile sourcePath hashes destinationPath = liftIO $ do
+  nodeConfig <- Yaml.decodeFileThrow sourcePath
+  let newConfig = foldr updateConfigHash nodeConfig $ Map.toList hashes
+  Aeson.encodeFile destinationPath newConfig
+ where
+  setHash field hash = Aeson.insert field $ Aeson.String $ Crypto.hashToTextAsHex hash
+  updateConfigHash :: (Aeson.Key, Crypto.Hash h a) -> Yaml.Value -> Yaml.Value
+  updateConfigHash (field, hash) =
+    \case
+      Aeson.Object obj -> Aeson.Object $ setHash field hash obj
+      v -> v
+
 runGenesisCreateStakedCmd
   :: GenesisCreateStakedCmdArgs era
   -> ExceptT GenesisCmdError IO ()

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

@@ -49,12 +49,17 @@ 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           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 qualified Data.Aeson.Key as Aeson
+import qualified Data.Aeson.KeyMap as Aeson
 import           Data.Bifunctor (Bifunctor (..))
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import           Data.ListMap (ListMap (..))
 import           Data.Map.Strict (Map)
@@ -65,6 +70,7 @@ import           Data.String (fromString)
 import qualified Data.Text as Text
 import           Data.Tuple (swap)
 import           Data.Word (Word64)
+import qualified Data.Yaml as Yaml
 import           GHC.Exts (IsList (..))
 import           GHC.Generics (Generic)
 import           GHC.Num (Natural)
@@ -170,6 +176,7 @@ runGenesisCreateTestNetDataCmd
   Cmd.GenesisCreateTestNetDataCmdArgs
     { eon
     , networkId
+    , specNodeConfig
     , specShelley
     , specAlonzo
     , specConway
@@ -321,9 +328,37 @@ runGenesisCreateTestNetDataCmd
         shelleyGenesis
 
     -- Write genesis.json file to output
-    liftIO $ LBS.writeFile (outputDir </> "conway-genesis.json") $ Aeson.encode conwayGenesis'
-    liftIO $ LBS.writeFile (outputDir </> "shelley-genesis.json") $ Aeson.encode shelleyGenesis'
-    liftIO $ LBS.writeFile (outputDir </> "alonzo-genesis.json") $ Aeson.encode alonzoGenesis
+    let conwayGenesisFilename = "conway-genesis.json"
+        shelleyGenesisFilename = "shelley-genesis.json"
+        alonzoGenesisFilename = "alonzo-genesis.json"
+        conwayGenesisPath = outputDir </> conwayGenesisFilename
+        shelleyGenesisPath = outputDir </> shelleyGenesisFilename
+        alonzoGenesisPath = outputDir </> alonzoGenesisFilename
+    liftIO $ LBS.writeFile conwayGenesisPath $ Aeson.encodePretty conwayGenesis'
+    liftIO $ LBS.writeFile shelleyGenesisPath $ Aeson.encodePretty shelleyGenesis'
+    liftIO $ LBS.writeFile alonzoGenesisPath $ Aeson.encodePretty alonzoGenesis
+
+    case specNodeConfig of
+      Nothing -> {- Don't do anything for now -} pure ()
+      Just inputNodeConfigPath -> do
+        let outputNodeConfigPath = outputDir </> "configuration.json"
+            addOrCheckHash k v = addOrCheck inputNodeConfigPath k (Crypto.hashToTextAsHex v)
+            addOrCheckPath k v = addOrCheck inputNodeConfigPath k (Text.pack v)
+        conwayGenesisHash <- getShelleyOnwardsGenesisHash conwayGenesisPath
+        shelleyGenesisHash <- getShelleyOnwardsGenesisHash shelleyGenesisPath
+        alonzoGenesisHash <- getShelleyOnwardsGenesisHash alonzoGenesisPath
+        nodeConfig <- Yaml.decodeFileThrow inputNodeConfigPath
+        nodeConfigToWrite <-
+          except $
+            -- Write hashs
+            addOrCheckHash "ConwayGenesisHash" conwayGenesisHash nodeConfig
+              >>= addOrCheckHash "ShelleyGenesisHash" shelleyGenesisHash
+              >>= addOrCheckHash "AlonzoGenesisHash" alonzoGenesisHash
+              -- Write paths
+              >>= addOrCheckPath "ConwayGenesisFile" conwayGenesisFilename
+              >>= addOrCheckPath "ShelleyGenesisFile" shelleyGenesisFilename
+              >>= addOrCheckPath "AlonzoGenesisFile" alonzoGenesisFilename
+        liftIO $ LBS.writeFile outputNodeConfigPath $ Aeson.encodePretty nodeConfigToWrite
    where
     genesisDir = outputDir </> "genesis-keys"
     delegateDir = outputDir </> "delegate-keys"
@@ -335,6 +370,30 @@ runGenesisCreateTestNetDataCmd
       :: Delegation -> (L.KeyHash L.Staking L.StandardCrypto, L.PoolParams L.StandardCrypto)
     mkDelegationMapEntry d = (dDelegStaking d, dPoolParams d)
 
+    -- @addOrCheck filepath key expectedValue obj @ checks
+    -- if @obj@ maps @key@. If it does, it checks that the value is @expectedValue@.
+    -- If @key@ is not mapped, the mapping @key -> expectedValue@ is inserted.
+    addOrCheck :: FilePath -> Aeson.Key -> Text.Text -> Yaml.Value -> Either GenesisCmdError Yaml.Value
+    addOrCheck filepath key expectedValue nodeConfig@(Aeson.Object obj) =
+      case Aeson.lookup key obj of
+        Nothing ->
+          -- Key of hash is not there, insert it
+          pure $ Aeson.Object $ Aeson.insert key (Aeson.String expectedValue) obj
+        Just (Aeson.String seen)
+          | seen == expectedValue ->
+              -- Hash is there and it's correct: no change
+              pure nodeConfig
+        Just (Aeson.String seen) ->
+          -- Hash is there, but it's incorrect: fail
+          Left $ GenesisCmdWrongGenesisHash filepath (Aeson.toText key) seen expectedValue
+        _ ->
+          Left $
+            GenesisCmdWrongNodeConfigFile
+              filepath
+              ("Expected a String at key \"" <> Aeson.toText key <> "\", but found something else")
+    addOrCheck filepath _ _ _ =
+      Left $ GenesisCmdWrongNodeConfigFile filepath "Expected Object at the top-level"
+
     addDRepsToConwayGenesis
       :: [VerificationKey DRepKey]
       -> [VerificationKey StakeKey]
@@ -408,6 +467,15 @@ runGenesisCreateTestNetDataCmd
       rest <- mapAccumM f a' t
       return $ h' : rest
 
+    --- | Read the given file and hashes it using 'Blake2b_256'
+    getShelleyOnwardsGenesisHash
+      :: MonadIO m
+      => FilePath
+      -> m (Crypto.Hash Crypto.Blake2b_256 BS.ByteString)
+    getShelleyOnwardsGenesisHash path = do
+      content <- liftIO $ BS.readFile path
+      return $ Crypto.hashWith @Crypto.Blake2b_256 id content
+
 -- | The output format used all along this file
 desiredKeyOutputFormat :: KeyOutputFormat
 desiredKeyOutputFormat = KeyOutputFormatTextEnvelope

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

@@ -44,6 +44,14 @@ data GenesisCmdError
       !(VerificationKeyFile In)
       !Text
       !SomeAddressVerificationKey
+  | -- | @GenesisCmdWrongNodeConfigFile path error@ indicates
+    -- that the node configuration at @path@ is badly formed. @error@
+    -- gives details about the error
+    GenesisCmdWrongNodeConfigFile !FilePath !Text
+  | -- | @GenesisCmdWrongGenesisHash path key seen expected@ indicates
+    -- that the node configuration at @path@ has the wrong value @seen@ for @key@.
+    -- The value should be @expected@ instead.
+    GenesisCmdWrongGenesisHash !FilePath !Text !Text !Text
   deriving Show
 
 instance Error GenesisCmdError where
@@ -133,3 +141,18 @@ instance Error GenesisCmdError where
         <> "."
         <> "This is incorrect: the delegated supply should be less or equal to the total supply."
         <> " Note that the total supply can either come from --total-supply or from the default template. Please fix what you use."
+    GenesisCmdWrongNodeConfigFile path err ->
+      "Node configuration file at "
+        <> pretty path
+        <> " is badly formed: "
+        <> pretty err
+    GenesisCmdWrongGenesisHash path key seen expected ->
+      "Hash associated to key \""
+        <> pretty key
+        <> "\" in file "
+        <> pretty path
+        <> " is wrong. The value in the file is "
+        <> pretty seen
+        <> " whereas "
+        <> pretty expected
+        <> " is expected."