Merge pull request #1267 from IntersectMBO/jordan/fix-legacy-genesis-creation

Fix legacy genesis creation

Author: Jimbo4350

cardano-cli/cardano-cli.cabal

@@ -436,8 +436,11 @@ test-suite cardano-cli-golden
     cardano-cli,
     cardano-cli:cardano-cli-test-lib,
     cardano-crypto-wrapper,
+    cardano-ledger-alonzo,
+    cardano-ledger-core,
     cardano-strict-containers ^>=0.1,
     cborg,
+    containers,
     directory,
     exceptions,
     extra,
@@ -478,6 +481,7 @@ test-suite cardano-cli-golden
     Test.Golden.Help
     Test.Golden.Key.NonExtendedKey
     Test.Golden.Latest.Transaction.CalculateMinFee
+    Test.Golden.Legacy.Genesis.Create
     Test.Golden.Shelley.Address.Build
     Test.Golden.Shelley.Address.Info
     Test.Golden.Shelley.Address.KeyGen

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

@@ -45,7 +45,7 @@ data GenesisCmds era
   deriving Show
 
 data GenesisCreateCmdArgs era = GenesisCreateCmdArgs
-  { eon :: !(Exp.Era era)
+  { eon :: !AnyShelleyBasedEra
   , keyOutputFormat :: !(Vary [FormatBech32, FormatTextEnvelope])
   , genesisDir :: !GenesisDir
   , numGenesisKeys :: !Word

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -187,17 +188,18 @@ pGenesisCreateCardano envCli =
         "JSON file with genesis defaults for conway."
       <*> pNodeConfigTemplate
 
-pGenesisCreate :: Exp.IsEra era => EnvCli -> Parser (GenesisCmds era)
+pGenesisCreate :: forall era. Exp.IsEra era => EnvCli -> Parser (GenesisCmds era)
 pGenesisCreate envCli =
-  fmap GenesisCreate $
-    GenesisCreateCmdArgs (convert Exp.useEra)
-      <$> pKeyOutputFormat
-      <*> pGenesisDir
-      <*> pGenesisNumGenesisKeys
-      <*> pGenesisNumUTxOKeys
-      <*> pMaybeSystemStart
-      <*> pInitialSupplyNonDelegated
-      <*> pNetworkId envCli
+  let sbe :: ShelleyBasedEra era = convert Exp.useEra
+   in fmap GenesisCreate $
+        GenesisCreateCmdArgs (shelleyBasedEraConstraints sbe $ AnyShelleyBasedEra sbe)
+          <$> pKeyOutputFormat
+          <*> pGenesisDir
+          <*> pGenesisNumGenesisKeys
+          <*> pGenesisNumUTxOKeys
+          <*> pMaybeSystemStart
+          <*> pInitialSupplyNonDelegated
+          <*> pNetworkId envCli
 
 pGenesisCreateStaked :: Exp.IsEra era => EnvCli -> Parser (GenesisCmds era)
 pGenesisCreateStaked envCli =

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

@@ -241,11 +241,13 @@ runGenesisCreateCmd
     , Cmd.mSupply
     , Cmd.network
     } = do
+    AnyShelleyBasedEra sbe <- return eon
     let GenesisDir rootdir = genesisDir
         gendir = rootdir </> "genesis-keys"
         deldir = rootdir </> "delegate-keys"
         utxodir = rootdir </> "utxo-keys"
-        era = toCardanoEra eon
+
+        era = toCardanoEra sbe
     liftIO $ do
       createDirectoryIfMissing False rootdir
       createDirectoryIfMissing False gendir

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

@@ -133,28 +133,28 @@ runQueryProtocolParametersCmd
     , Cmd.outputFormat
     , Cmd.mOutFile
     } = do
-    AnyCardanoEra cEra <- fromExceptTCli $ determineEra nodeConnInfo
-    era <- fromExceptTCli $ supportedEra cEra
+    anyCEra@(AnyCardanoEra cEra) <- fromExceptTCli $ determineEra nodeConnInfo
+    case forEraInEonMaybe cEra id of
+      Nothing -> throwCliError $ QueryCmdEraNotSupported anyCEra
+      Just sbe -> do
+        let qInMode = QueryInEra $ QueryInShelleyBasedEra sbe Api.QueryProtocolParameters
 
-    let sbe = convert era
-        qInMode = QueryInEra $ QueryInShelleyBasedEra sbe Api.QueryProtocolParameters
-
-    pparams <-
-      fromExceptTCli $
-        executeQueryAnyMode nodeConnInfo qInMode
+        pparams <-
+          fromExceptTCli $
+            executeQueryAnyMode nodeConnInfo qInMode
 
-    let output =
-          Exp.obtainCommonConstraints era
-            $ outputFormat
-              & ( id
-                    . Vary.on (\FormatJson -> Json.encodeJson)
-                    . Vary.on (\FormatYaml -> Json.encodeYaml)
-                    $ Vary.exhaustiveCase
-                )
-            $ pparams
+        let output =
+              shelleyBasedEraConstraints sbe
+                $ outputFormat
+                  & ( id
+                        . Vary.on (\FormatJson -> Json.encodeJson)
+                        . Vary.on (\FormatYaml -> Json.encodeYaml)
+                        $ Vary.exhaustiveCase
+                    )
+                $ pparams
 
-    fromEitherIOCli @(FileError ()) $
-      writeLazyByteStringOutput mOutFile output
+        fromEitherIOCli @(FileError ()) $
+          writeLazyByteStringOutput mOutFile output
 
 -- | Calculate the percentage sync rendered as text: @min 1 (tipTime/nowTime)@
 percentage
@@ -316,12 +316,13 @@ runQueryUTxOCmd
     ) = do
     fromEitherIOCli
       ( executeLocalStateQueryExpr nodeConnInfo target $ runExceptT $ do
-          AnyCardanoEra cEra <- easyRunQueryCurrentEra
+          anyCEra@(AnyCardanoEra cEra) <- easyRunQueryCurrentEra
 
-          era <- hoist liftIO $ supportedEra cEra
-
-          utxo <- easyRunQuery (queryUtxo (convert era) queryFilter)
-          hoist liftIO $ writeFilteredUTxOs era outputFormat mOutFile utxo
+          case forEraInEonMaybe cEra id of
+            Nothing -> throwCliError $ QueryCmdEraNotSupported anyCEra
+            Just sbe -> do
+              utxo <- easyRunQuery (queryUtxo sbe queryFilter)
+              hoist liftIO $ writeFilteredUTxOs sbe outputFormat mOutFile utxo
       )
       & fromEitherCIOCli
 
@@ -1199,20 +1200,20 @@ writePoolState outputFormat mOutFile serialisedCurrentEpochState = do
     $ writeLazyByteStringOutput mOutFile output
 
 writeFilteredUTxOs
-  :: Exp.Era era
+  :: ShelleyBasedEra era
   -> Vary [FormatCborBin, FormatCborHex, FormatJson, FormatText, FormatYaml]
   -> Maybe (File () Out)
   -> UTxO era
   -> ExceptT QueryCmdError IO ()
 writeFilteredUTxOs era format mOutFile utxo = do
   let output =
-        Exp.obtainCommonConstraints era $
+        shelleyBasedEraConstraints era $
           format
             & ( id
-                  . Vary.on (\FormatCborBin -> CBOR.serialize $ toLedgerUTxO (convert era) utxo)
-                  . Vary.on (\FormatCborHex -> Base16.encode . CBOR.serialize $ toLedgerUTxO (convert era) utxo)
+                  . Vary.on (\FormatCborBin -> CBOR.serialize $ toLedgerUTxO era utxo)
+                  . Vary.on (\FormatCborHex -> Base16.encode . CBOR.serialize $ toLedgerUTxO era utxo)
                   . Vary.on (\FormatJson -> Json.encodeJson utxo)
-                  . Vary.on (\FormatText -> strictTextToLazyBytestring $ filteredUTxOsToText (convert era) utxo)
+                  . Vary.on (\FormatText -> strictTextToLazyBytestring $ filteredUTxOsToText era utxo)
                   . Vary.on (\FormatYaml -> Json.encodeYaml utxo)
                   $ Vary.exhaustiveCase
               )
@@ -1221,26 +1222,71 @@ writeFilteredUTxOs era format mOutFile utxo = do
     . newExceptT
     $ writeLazyByteStringOutput mOutFile output
 
-filteredUTxOsToText :: Exp.Era era -> UTxO era -> Text
-filteredUTxOsToText era (UTxO utxo) = do
+filteredUTxOsToText :: Api.ShelleyBasedEra era -> UTxO era -> Text
+filteredUTxOsToText sbe (UTxO utxo) = do
   mconcat
     [ Text.unlines [title, Text.replicate (Text.length title + 2) "-"]
-    , Text.unlines $ case era of
-        Exp.ConwayEra ->
-          map (utxoToText era) $ toList utxo
+    , Text.unlines $ case sbe of
+        ShelleyBasedEraShelley ->
+          map (utxoToText sbe) $ toList utxo
+        ShelleyBasedEraAllegra ->
+          map (utxoToText sbe) $ toList utxo
+        ShelleyBasedEraMary ->
+          map (utxoToText sbe) $ toList utxo
+        ShelleyBasedEraAlonzo ->
+          map (utxoToText sbe) $ toList utxo
+        ShelleyBasedEraBabbage ->
+          map (utxoToText sbe) $ toList utxo
+        ShelleyBasedEraConway ->
+          map (utxoToText sbe) $ toList utxo
     ]
  where
   title :: Text
   title =
     "                           TxHash                                 TxIx        Amount"
 
 utxoToText
-  :: Exp.Era era
+  :: Api.ShelleyBasedEra era
   -> (TxIn, TxOut CtxUTxO era)
   -> Text
 utxoToText sbe txInOutTuple =
   case sbe of
-    Exp.ConwayEra ->
+    ShelleyBasedEraShelley ->
+      let (TxIn (TxId txhash) (TxIx index), TxOut _ value _ _) = txInOutTuple
+       in mconcat
+            [ Text.decodeLatin1 (hashToBytesAsHex txhash)
+            , textShowN 6 index
+            , "        " <> printableValue value
+            ]
+    ShelleyBasedEraAllegra ->
+      let (TxIn (TxId txhash) (TxIx index), TxOut _ value _ _) = txInOutTuple
+       in mconcat
+            [ Text.decodeLatin1 (hashToBytesAsHex txhash)
+            , textShowN 6 index
+            , "        " <> printableValue value
+            ]
+    ShelleyBasedEraMary ->
+      let (TxIn (TxId txhash) (TxIx index), TxOut _ value _ _) = txInOutTuple
+       in mconcat
+            [ Text.decodeLatin1 (hashToBytesAsHex txhash)
+            , textShowN 6 index
+            , "        " <> printableValue value
+            ]
+    ShelleyBasedEraAlonzo ->
+      let (TxIn (TxId txhash) (TxIx index), TxOut _ value mDatum _) = txInOutTuple
+       in mconcat
+            [ Text.decodeLatin1 (hashToBytesAsHex txhash)
+            , textShowN 6 index
+            , "        " <> printableValue value <> " + " <> Text.pack (show mDatum)
+            ]
+    ShelleyBasedEraBabbage ->
+      let (TxIn (TxId txhash) (TxIx index), TxOut _ value mDatum _) = txInOutTuple
+       in mconcat
+            [ Text.decodeLatin1 (hashToBytesAsHex txhash)
+            , textShowN 6 index
+            , "        " <> printableValue value <> " + " <> Text.pack (show mDatum)
+            ]
+    ShelleyBasedEraConway ->
       let (TxIn (TxId txhash) (TxIx index), TxOut _ value mDatum _) = txInOutTuple
        in mconcat
             [ Text.decodeLatin1 (hashToBytesAsHex txhash)

cardano-cli/src/Cardano/CLI/Legacy/Genesis/Command.hs

@@ -19,8 +19,8 @@ import Data.Word (Word64)
 import Vary (Vary)
 
 data LegacyGenesisCmds
-  = forall era. GenesisCreate
-      (Era era)
+  = GenesisCreate
+      AnyShelleyBasedEra
       (Vary [FormatBech32, FormatTextEnvelope])
       GenesisDir
       Word

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

@@ -130,7 +130,7 @@ runLegacyGenesisAddrCmd vkf nid mOf =
 
 runLegacyGenesisCreateCmd
   :: ()
-  => Era era
+  => AnyShelleyBasedEra
   -> Vary [FormatBech32, FormatTextEnvelope]
   -> GenesisDir
   -> Word

cardano-cli/src/Cardano/CLI/Legacy/Option.hs

@@ -28,8 +28,9 @@ import Cardano.CLI.Parser
 import Cardano.CLI.Type.Common
 import Cardano.Ledger.BaseTypes (NonZero, knownNonZeroBounded)
 
+import Data.Char (toLower)
 import Data.Foldable
-import Data.Maybe (fromMaybe)
+import Data.Maybe
 import Data.Word (Word64)
 import Options.Applicative hiding (help, str)
 import Options.Applicative qualified as Opt
@@ -192,7 +193,7 @@ pGenesisCmds envCli =
   pGenesisCreate :: Parser LegacyGenesisCmds
   pGenesisCreate =
     GenesisCreate
-      <$> pConwayEra envCli
+      <$> pShelleyBasedEra envCli
       <*> pKeyOutputFormat
       <*> pGenesisDir
       <*> pGenesisNumGenesisKeys
@@ -378,3 +379,25 @@ pGenesisCmds envCli =
         , Opt.help "Each bulk pool to contain this many pool credential sets [default is 0]."
         , Opt.value 0
         ]
+
+pShelleyBasedEra :: EnvCli -> Parser AnyShelleyBasedEra
+pShelleyBasedEra envCli =
+  asum $
+    [ shelleyBasedEraFlag era
+    | era <- enumFrom minBound
+    ]
+      ++ (pure <$> maybeToList (envCliShelleyBasedEra envCli))
+ where
+  shelleyBasedEraFlag :: AnyShelleyBasedEra -> Parser AnyShelleyBasedEra
+  shelleyBasedEraFlag era@(AnyShelleyBasedEra sbe) =
+    let eraName = show . pretty $ toCardanoEra sbe
+     in flag' era $
+          mconcat
+            [ long $ map toLower eraName
+            , Opt.help $ "Specify the " <> eraName <> " era"
+            ]
+
+envCliShelleyBasedEra :: EnvCli -> Maybe AnyShelleyBasedEra
+envCliShelleyBasedEra envCli = do
+  AnyCardanoEra era <- envCliAnyCardanoEra envCli
+  AnyShelleyBasedEra <$> forEraMaybeEon era

cardano-cli/test/cardano-cli-golden/Test/Golden/Legacy/Genesis/Create.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.Golden.Legacy.Genesis.Create where
+
+import Cardano.Api qualified as H
+import Cardano.Api.Genesis
+
+import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
+import Cardano.Ledger.Plutus.CostModels (costModelsValid, getCostModelParams)
+import Cardano.Ledger.Plutus.Language
+
+import Control.Monad (void)
+import Data.ByteString.Char8 qualified as C8
+import Data.ByteString.Lazy qualified as LBS
+import Data.Map.Strict qualified as Map
+import System.FilePath ((</>))
+
+import Test.Cardano.CLI.Util (execCardanoCLI, propertyOnce, watchdogProp)
+
+import Hedgehog (Property)
+import Hedgehog qualified as H
+import Hedgehog.Extras.Test qualified as H
+
+{- HLINT ignore "Use camelCase" -}
+
+-- | QA needs the ability to generate a V2 cost model with 175 parameters in the Alonzo era
+hprop_golden_alonzo_genesis_v2_cost_model_has_175_parameters :: Property
+hprop_golden_alonzo_genesis_v2_cost_model_has_175_parameters =
+  watchdogProp . propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do
+    alonzoGenesisSpec <-
+      H.note "test/cardano-cli-golden/files/input/genesis.alonzo.spec.json"
+    shelleyGenesisSpec <-
+      H.note "test/cardano-cli-golden/files/input/genesis.spec.json"
+
+    conwayGenesisSpec <-
+      H.note "test/cardano-cli-golden/files/input/genesis.conway.spec.json"
+
+    outDir <- H.note $ tempDir </> "genesis-dir"
+
+    -- Copy genesis spec files to genesis output directory
+    alonzoGenSpecBs <- H.readFile alonzoGenesisSpec
+    shelleyGenSpecBs <- H.readFile shelleyGenesisSpec
+    conwayGenesisSpecBs <- H.readFile conwayGenesisSpec
+
+    H.createDirectoryIfMissing_ outDir
+    genAlonzoSpec <- H.noteTempFile outDir "genesis.alonzo.spec.json"
+    genConwaySpec <- H.noteTempFile outDir "genesis.conway.spec.json"
+    genShelleySpec <- H.noteTempFile outDir "genesis.spec.json"
+
+    H.writeFile genAlonzoSpec alonzoGenSpecBs
+    H.writeFile genConwaySpec conwayGenesisSpecBs
+    H.writeFile genShelleySpec shelleyGenSpecBs
+
+    -- Create genesis files
+    void $
+      execCardanoCLI
+        [ "legacy"
+        , "genesis"
+        , "create"
+        , "--alonzo"
+        , "--genesis-dir"
+        , outDir
+        , "--mainnet"
+        ]
+
+    -- Read generated alonzo genesis file
+    alonzoGenesisFp <- H.note $ outDir </> "genesis.alonzo.json"
+    alonzoGenesisBs <- C8.pack <$> H.readFile alonzoGenesisFp
+
+    alonzoGenesisE <- H.liftIO . H.runExceptT $ decodeGen $ LBS.fromStrict alonzoGenesisBs
+    AlonzoGenesis _ costModels _ _ _ _ _ _ <- H.evalEither alonzoGenesisE
+    let v2CostModel = costModelsValid costModels
+        mV2Params = Map.lookup PlutusV2 v2CostModel
+    v2Params <- getCostModelParams <$> H.evalMaybe mV2Params
+
+    H.note_ $ "Cost model filepath: " <> alonzoGenesisFp
+    length v2Params H.=== 175
+
+decodeGen :: LBS.ByteString -> H.ExceptT String IO AlonzoGenesis
+decodeGen = decodeAlonzoGenesis (Just H.AlonzoEra)