WIP: Fix chairman test by generating the shelley genesis JSON with

Alonzo parameters
IntersectMBO · May 18, 2021 · 28b32b2 · 28b32b2
1 parent 45bbb5b
commit 28b32b2
Show file tree

Hide file tree

Showing 3 changed files with 85 additions and 28 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs b/cardano-cli/src/Cardano/CLI/Shelley/Orphans.hs
@@ -129,3 +129,6 @@ instance FromJSON Alonzo.AlonzoGenesis where
         collateralPercentage,
         maxCollateralInputs
       }
+
+instance ToJSON AlonzoGenesis where
+  toJSON = panic "TODO: Fill me in"
diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs b/cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis.hs
@@ -64,6 +64,7 @@ import           Ouroboros.Consensus.Shelley.Protocol (StandardCrypto)
 
 import qualified Cardano.Ledger.Alonzo.Language as Alonzo
 import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
+import           Cardano.Ledger.Alonzo.Translation (AlonzoGenesis (..))
 import qualified Cardano.Ledger.Alonzo.Translation as Alonzo
 import           Cardano.Ledger.Coin (Coin (..))
 import qualified Shelley.Spec.Ledger.API as Ledger
@@ -359,7 +360,11 @@ runGenesisCreate (GenesisDir rootdir)
   utxoAddrs <- readInitialFundAddresses utxodir network
   start <- maybe (SystemStart <$> getCurrentTimePlus30) pure mStart
 
-  let finalGenesis = updateTemplate start genDlgs mAmount utxoAddrs mempty (Lovelace 0) [] [] template
+  let finalGenesis = updateTemplate
+                       -- Shelley genesis parameters
+                       start genDlgs mAmount utxoAddrs mempty (Lovelace 0) [] [] template
+                       -- Alono genesis parameters TODO: Parameterize
+                       (Lovelace 10) (Lovelace 1, Lovelace 1) (1,1) (1,1) 1 1 1
 
   writeShelleyGenesis (rootdir </> "genesis.json") finalGenesis
   where
@@ -442,7 +447,11 @@ runGenesisCreateStaked (GenesisDir rootdir)
   let poolMap :: Map (Ledger.KeyHash Ledger.Staking StandardCrypto) (Ledger.PoolParams StandardCrypto)
       poolMap = Map.fromList $ mkDelegationMapEntry <$> delegations
       delegAddrs = dInitialUtxoAddr <$> delegations
-      finalGenesis = updateTemplate start genDlgs mNonDlgAmount nonDelegAddrs poolMap stDlgAmount delegAddrs stuffedUtxoAddrs template
+      finalGenesis = updateTemplate
+                       -- Shelley genesis parameters
+                       start genDlgs mNonDlgAmount nonDelegAddrs poolMap stDlgAmount delegAddrs stuffedUtxoAddrs template
+                       -- Alonzo genesis parameters TODO: Parameterize
+                       (Lovelace 10) (Lovelace 1, Lovelace 1) (1,1) (1,1) 1 1 1
 
   writeShelleyGenesis (rootdir </> "genesis.json") finalGenesis
   liftIO $ Text.putStrLn $ mconcat $
@@ -725,29 +734,64 @@ updateTemplate
     -> [AddressInEra ShelleyEra]
     -> [AddressInEra ShelleyEra]
     -> ShelleyGenesis StandardShelley
-    -> ShelleyGenesis StandardShelley
+    -- Alonzo genesis parameters
+    -> Lovelace
+    -- ^ Ada per UTxO word
+    -> (Lovelace, Lovelace)
+    -- ^ Execution prices (memory, steps)
+    -> (Word64, Word64)
+    -- ^ Max Tx execution units
+    -> (Word64, Word64)
+    -- ^ Max block execution units
+    -> Natural
+    -- ^ Max value size
+    -> Natural
+    -- ^ Collateral percentage
+    -> Natural
+    -- ^ Max collateral inputs
+    -> (ShelleyGenesis StandardShelley, Alonzo.AlonzoGenesis)
 updateTemplate (SystemStart start)
                genDelegMap mAmountNonDeleg utxoAddrsNonDeleg
                poolSpecs (Lovelace amountDeleg) utxoAddrsDeleg stuffedUtxoAddrs
-               template =
-    template
-      { sgSystemStart = start
-      , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin
-      , sgGenDelegs = shelleyDelKeys
-      , sgInitialFunds = Map.fromList
-                          [ (toShelleyAddr addr, toShelleyLovelace v)
-                          | (addr, v) <-
-                            distribute nonDelegCoin utxoAddrsNonDeleg ++
-                            distribute delegCoin    utxoAddrsDeleg ++
-                            mkStuffedUtxo stuffedUtxoAddrs ]
-      , sgStaking =
-        ShelleyGenesisStaking
-          { sgsPools = Map.fromList
-                        [ (Ledger._poolId poolParams, poolParams)
-                        | poolParams <- Map.elems poolSpecs ]
-          , sgsStake = Ledger._poolId <$> poolSpecs
+               template  adaPerUtxoWrd' (exMem,exStep) (maxTxMem, maxTxStep)
+               (maxBlkMem, maxBlkStep) maxValSize' collPercent maxColInputs = do
+
+    let shelleyGenesis = template
+          { sgSystemStart = start
+          , sgMaxLovelaceSupply = fromIntegral $ nonDelegCoin + delegCoin
+          , sgGenDelegs = shelleyDelKeys
+          , sgInitialFunds = Map.fromList
+                              [ (toShelleyAddr addr, toShelleyLovelace v)
+                              | (addr, v) <-
+                                distribute nonDelegCoin utxoAddrsNonDeleg ++
+                                distribute delegCoin    utxoAddrsDeleg ++
+                                mkStuffedUtxo stuffedUtxoAddrs ]
+          , sgStaking =
+            ShelleyGenesisStaking
+              { sgsPools = Map.fromList
+                            [ (Ledger._poolId poolParams, poolParams)
+                            | poolParams <- Map.elems poolSpecs ]
+              , sgsStake = Ledger._poolId <$> poolSpecs
+              }
           }
-      }
+        cModel = case Plutus.extractModelParams Plutus.defaultCostModel of
+                   Just m ->
+                     if Alonzo.validateCostModelParams m
+                     then Map.singleton Alonzo.PlutusV1 $ Alonzo.CostModel m
+                     else panic "updateTemplate: Plutus.defaultCostModel is invalid"
+
+                   Nothing -> panic "updateTemplate: Could not extract cost model params from Plutus.defaultCostModel"
+        alonzoGenesis = AlonzoGenesis
+                          { adaPerUTxOWord = toShelleyLovelace adaPerUtxoWrd'
+                          , costmdls = cModel
+                          , prices = Alonzo.Prices (toShelleyLovelace exMem) (toShelleyLovelace exStep)
+                          , maxTxExUnits = Alonzo.ExUnits maxTxMem maxTxStep
+                          , maxBlockExUnits = Alonzo.ExUnits maxBlkMem maxBlkStep
+                          , maxValSize = maxValSize'
+                          , collateralPercentage = collPercent
+                          , maxCollateralInputs = maxColInputs
+                          }
+    (shelleyGenesis, alonzoGenesis)
   where
     nonDelegCoin, delegCoin :: Integer
     nonDelegCoin = fromIntegral $ fromMaybe (sgMaxLovelaceSupply template) (unLovelace <$> mAmountNonDeleg)
@@ -784,11 +828,22 @@ updateTemplate (SystemStart start)
     unLovelace :: Integral a => Lovelace -> a
     unLovelace (Lovelace coin) = fromIntegral coin
 
-writeShelleyGenesis :: FilePath -> ShelleyGenesis StandardShelley -> ExceptT ShelleyGenesisCmdError IO ()
-writeShelleyGenesis fpath sg =
-  handleIOExceptT (ShelleyGenesisCmdGenesisFileError . FileIOError fpath) $ LBS.writeFile fpath (encodePretty sg)
-
-
+-- We need to include Alonzo genesis parameters
+writeShelleyGenesis
+  :: FilePath
+  -> (ShelleyGenesis StandardShelley, AlonzoGenesis)
+  -> ExceptT ShelleyGenesisCmdError IO ()
+writeShelleyGenesis fpath (sg, ag) = do
+  let sgValue = toJSON sg
+      agValue = toJSON ag
+  genesisCombined <- hoistEither $ combineAndEncode sgValue agValue
+  handleIOExceptT
+    (ShelleyGenesisCmdGenesisFileError . FileIOError fpath)
+    $ LBS.writeFile fpath genesisCombined
+ where
+  combineAndEncode :: Aeson.Value -> Aeson.Value -> Either ShelleyGenesisCmdError LBS.ByteString
+  combineAndEncode (Object sgO) (Object agO) = Right $ encodePretty $ sgO <> agO
+  combineAndEncode _sgWrong _agWrong = panic "combineAndEncode: Implement ShelleyGenesisCmdError constuctor"
 -- -------------------------------------------------------------------------------------------------
 
 readGenDelegsMap :: FilePath -> FilePath

diff --git a/cardano-node/src/Cardano/Node/Orphans.hs b/cardano-node/src/Cardano/Node/Orphans.hs
@@ -13,8 +13,7 @@ import           Prelude (fail)
 
 import           Cardano.Api.Orphans ()
 
-import           Data.Aeson (FromJSON (..), ToJSON (..), ToJSONKey, Value (..),
-                             withObject, (.:))
+import           Data.Aeson (FromJSON (..), ToJSON (..), ToJSONKey, Value (..), withObject, (.:))
 import qualified Data.Text as Text
 
 import           Cardano.BM.Data.Tracer (TracingVerbosity (..))