Add create-protocol-parameters-update command to era based commands

cabal.project

@@ -14,7 +14,7 @@ repository cardano-haskell-packages
 -- you need to run if you change them
 index-state:
   , hackage.haskell.org 2023-08-08T19:56:09Z
-  , cardano-haskell-packages 2023-08-11T16:23:05Z
+  , cardano-haskell-packages 2023-08-15T15:38:21Z
 
 packages:
   cardano-cli

cardano-cli/cardano-cli.cabal

@@ -137,7 +137,7 @@ library
                       , binary
                       , bytestring
                       , canonical-json
-                      , cardano-api ^>= 8.13
+                      , cardano-api ^>= 8.14
                       , cardano-binary
                       , cardano-crypto
                       , cardano-crypto-class >= 2.1.1
@@ -224,7 +224,7 @@ test-suite cardano-cli-test
                       , base16-bytestring
                       , bech32 >= 1.1.0
                       , bytestring
-                      , cardano-api:{cardano-api, internal} ^>= 8.13
+                      , cardano-api:{cardano-api, internal} ^>= 8.14
                       , cardano-api-gen ^>= 8.1.1.0
                       , cardano-cli
                       , cardano-cli:cardano-cli-test-lib
@@ -268,7 +268,7 @@ test-suite cardano-cli-golden
   build-depends:        aeson >= 1.5.6.0
                       , base16-bytestring
                       , bytestring
-                      , cardano-api:{cardano-api, gen} ^>= 8.13
+                      , cardano-api:{cardano-api, gen} ^>= 8.14
                       , cardano-binary
                       , cardano-cli
                       , cardano-cli:cardano-cli-test-lib

cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Actions.hs

@@ -20,6 +20,10 @@ data GovernanceActionCmds era
   = GovernanceActionCreateConstitution
       (ConwayEraOnwards era)
       EraBasedNewConstitution
+  | GovernanceActionProtocolParametersUpdate
+      (ShelleyBasedEra era)
+      (EraBasedProtocolParametersUpdate era)
+      (File () Out)
     deriving Show
 
 data EraBasedNewConstitution
@@ -35,6 +39,9 @@ renderGovernanceActionCmds = \case
   GovernanceActionCreateConstitution {} ->
     "governance action create-constitution"
 
+  GovernanceActionProtocolParametersUpdate {} ->
+    "governance action create-protocol-parameters-update"
+
 
 data AnyStakeIdentifier
   = AnyStakeKey (VerificationKeyOrHashOrFile StakeKey)

cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs

@@ -1,13 +1,21 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+
 module Cardano.CLI.EraBased.Options.Governance.Actions
   ( pGovernanceActionCmds
   ) where
 
 import           Cardano.Api
+import           Cardano.Api.Ledger
+import           Cardano.Api.Shelley
 
 import           Cardano.CLI.EraBased.Commands.Governance.Actions
 import           Cardano.CLI.EraBased.Options.Common
+import           Cardano.Ledger.BaseTypes (NonNegativeInterval)
+import qualified Cardano.Ledger.BaseTypes as Ledger
 
 import           Data.Foldable
+import           GHC.Natural (Natural)
 import           Options.Applicative
 import qualified Options.Applicative as Opt
 
@@ -22,6 +30,7 @@ pGovernanceActionCmds era =
           ]
     )
     [ pGovernanceActionNewConstitution era
+    , pGovernanceActionProtocolParametersUpdate era
     ]
 
 
@@ -35,7 +44,7 @@ pGovernanceActionNewConstitution =
  where
   pCmd :: ConwayEraOnwards era -> Parser (GovernanceActionCmds era)
   pCmd cOn =
-    fmap (GovernanceActionCreateConstitution cOn)  $
+    fmap (GovernanceActionCreateConstitution cOn) $
       EraBasedNewConstitution
         <$> pGovActionDeposit
         <*> pAnyStakeIdentifier
@@ -48,3 +57,153 @@ pAnyStakeIdentifier =
        , AnyStakeKey <$> pStakeVerificationKeyOrHashOrFile
        ]
 
+pGovernanceActionProtocolParametersUpdate
+  :: CardanoEra era  -> Maybe (Parser (GovernanceActionCmds era))
+pGovernanceActionProtocolParametersUpdate era =
+   Just $ subParser "create-protocol-parameters-update"
+        $ Opt.info (pCmd era)
+        $ Opt.progDesc "Create a protocol parameters update."
+ where
+  pCmd :: CardanoEra era -> Parser (GovernanceActionCmds era)
+  pCmd era' =
+    case cardanoEraStyle era' of
+      LegacyByronEra -> empty
+      ShelleyBasedEra sbe ->
+        case sbe of
+         ShelleyBasedEraShelley ->
+           GovernanceActionProtocolParametersUpdate sbe
+             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraShelley
+             <*> pOutputFile
+         ShelleyBasedEraAllegra ->
+           GovernanceActionProtocolParametersUpdate sbe
+             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraAllegra
+             <*> pOutputFile
+         ShelleyBasedEraMary ->
+           GovernanceActionProtocolParametersUpdate sbe
+             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraMary
+             <*> pOutputFile
+         ShelleyBasedEraAlonzo ->
+           GovernanceActionProtocolParametersUpdate sbe
+             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraAlonzo
+             <*> pOutputFile
+         ShelleyBasedEraBabbage ->
+           GovernanceActionProtocolParametersUpdate sbe
+             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraBabbage
+             <*> pOutputFile
+         ShelleyBasedEraConway ->
+           GovernanceActionProtocolParametersUpdate sbe
+             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraConway
+             <*> pOutputFile
+
+convertToLedger :: (a -> b) -> Parser (Maybe a) -> Parser (StrictMaybe b)
+convertToLedger conv = fmap (maybeToStrictMaybe . fmap conv)
+
+toNonNegativeIntervalOrErr :: Rational -> NonNegativeInterval
+toNonNegativeIntervalOrErr r = case Ledger.boundRational r of
+                         Nothing ->
+                           error $ mconcat [ "toNonNegativeIntervalOrErr: "
+                                           , "rational out of bounds " <> show r
+                                           ]
+                         Just n -> n
+
+toUnitIntervalOrErr :: Rational -> Ledger.UnitInterval
+toUnitIntervalOrErr r = case Ledger.boundRational r of
+                         Nothing ->
+                           error $ mconcat [ "toUnitIntervalOrErr: "
+                                           , "rational out of bounds " <> show r
+                                           ]
+                         Just n -> n
+
+mkProtocolVersionOrErr :: (Natural, Natural) -> Ledger.ProtVer
+mkProtocolVersionOrErr (majorProtVer, minorProtVer) =
+  case (`Ledger.ProtVer` minorProtVer) <$> Ledger.mkVersion majorProtVer of
+    Just v -> v
+    Nothing ->
+      error $ "mkProtocolVersionOrErr: invalid protocol version " <> show (majorProtVer, minorProtVer)
+
+pCommonProtocolParameters :: Parser CommonProtocolParametersUpdate
+pCommonProtocolParameters =
+  CommonProtocolParametersUpdate
+    <$> convertToLedger toShelleyLovelace (optional pMinFeeConstantFactor)
+    <*> convertToLedger toShelleyLovelace (optional pMinFeePerByteFactor)
+    <*> convertToLedger id (optional pMaxBodySize)
+    <*> convertToLedger id (optional pMaxTransactionSize)
+    <*> convertToLedger id (optional pMaxBlockHeaderSize)
+    <*> convertToLedger toShelleyLovelace (optional pKeyRegistDeposit)
+    <*> convertToLedger toShelleyLovelace (optional pPoolDeposit)
+    <*> convertToLedger id (optional pEpochBoundRetirement)
+    <*> convertToLedger id (optional pNumberOfPools)
+    <*> convertToLedger toNonNegativeIntervalOrErr (optional pPoolInfluence)
+    <*> convertToLedger toUnitIntervalOrErr (optional pTreasuryExpansion)
+    <*> convertToLedger toUnitIntervalOrErr (optional pMonetaryExpansion)
+    <*> convertToLedger mkProtocolVersionOrErr (optional pProtocolVersion)
+    <*> convertToLedger toShelleyLovelace (optional pMinPoolCost)
+
+
+pDeprecatedAfterMaryPParams :: Parser (DeprecatedAfterMaryPParams ledgerera)
+pDeprecatedAfterMaryPParams =
+  DeprecatedAfterMaryPParams
+    <$> convertToLedger toShelleyLovelace (optional pMinUTxOValue)
+
+pShelleyToAlonzoPParams' :: Parser (ShelleyToAlonzoPParams' ledgerera)
+pShelleyToAlonzoPParams' =
+  ShelleyToAlonzoPParams'
+    <$> convertToLedger id (optional $ toLedgerNonce <$> pExtraEntropy)
+    <*> convertToLedger toUnitIntervalOrErr (optional pDecentralParam)
+
+pShelleyToAlonzoPParams :: Parser (ShelleyToAlonzoPParams era)
+pShelleyToAlonzoPParams =
+  ShelleyToAlonzoPParams
+    <$> convertToLedger (CoinPerWord . toShelleyLovelace) (optional pUTxOCostPerWord)
+
+
+pAlonzoOnwardsPParams :: Parser (AlonzoOnwardsPParams ledgerera)
+pAlonzoOnwardsPParams =
+  AlonzoOnwardsPParams SNothing -- TODO: Conway era cost model
+    <$> convertToLedger (either (\e -> error $ "pAlonzoOnwardsPParams: " <> show e) id . toAlonzoPrices)
+                        (optional pExecutionUnitPrices)
+    <*> convertToLedger toAlonzoExUnits (optional pMaxTxExecutionUnits)
+    <*> convertToLedger toAlonzoExUnits (optional pMaxBlockExecutionUnits)
+    <*> convertToLedger id (optional pMaxValueSize)
+    <*> convertToLedger id (optional pCollateralPercent)
+    <*> convertToLedger id (optional pMaxCollateralInputs)
+
+
+pIntroducedInBabbagePParams :: Parser (IntroducedInBabbagePParams ledgerera)
+pIntroducedInBabbagePParams =
+  IntroducedInBabbagePParams
+    <$> convertToLedger (CoinPerByte . toShelleyLovelace) (optional pUTxOCostPerByte)
+
+dpGovActionProtocolParametersUpdate :: ShelleyBasedEra era -> Parser (EraBasedProtocolParametersUpdate era)
+dpGovActionProtocolParametersUpdate = \case
+  ShelleyBasedEraShelley ->
+    ShelleyEraBasedProtocolParametersUpdate
+      <$> pCommonProtocolParameters
+      <*> pDeprecatedAfterMaryPParams
+      <*> pShelleyToAlonzoPParams'
+  ShelleyBasedEraAllegra ->
+    AllegraEraBasedProtocolParametersUpdate
+      <$> pCommonProtocolParameters
+      <*> pDeprecatedAfterMaryPParams
+      <*> pShelleyToAlonzoPParams'
+  ShelleyBasedEraMary ->
+    MaryEraBasedProtocolParametersUpdate
+      <$> pCommonProtocolParameters
+      <*> pDeprecatedAfterMaryPParams
+      <*> pShelleyToAlonzoPParams'
+  ShelleyBasedEraAlonzo ->
+    AlonzoEraBasedProtocolParametersUpdate
+      <$> pCommonProtocolParameters
+      <*> pShelleyToAlonzoPParams'
+      <*> pAlonzoOnwardsPParams
+      <*> pShelleyToAlonzoPParams
+  ShelleyBasedEraBabbage ->
+    BabbageEraBasedProtocolParametersUpdate
+      <$> pCommonProtocolParameters
+      <*> pAlonzoOnwardsPParams
+      <*> pIntroducedInBabbagePParams
+  ShelleyBasedEraConway ->
+    ConwayEraBasedProtocolParametersUpdate
+      <$> pCommonProtocolParameters
+      <*> pAlonzoOnwardsPParams
+      <*> pIntroducedInBabbagePParams

cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs

@@ -34,6 +34,9 @@ runGovernanceActionCmds = \case
   GovernanceActionCreateConstitution cOn newConstitution ->
     runGovernanceActionCreateConstitution cOn newConstitution
 
+  GovernanceActionProtocolParametersUpdate sbe eraBasedProtocolParametersUpdate ofp ->
+    runGovernanceActionCreateProtocolParametersUpdate sbe eraBasedProtocolParametersUpdate ofp
+
 runGovernanceActionCreateConstitution :: ()
   => ConwayEraOnwards era
   -> EraBasedNewConstitution
@@ -74,3 +77,18 @@ runGovernanceActionCreateConstitution cOn (EraBasedNewConstitution deposit anySt
         $ writeFileTextEnvelope outFp Nothing proposal
 
 
+runGovernanceActionCreateProtocolParametersUpdate :: ()
+  => ShelleyBasedEra era
+  -> EraBasedProtocolParametersUpdate era
+  -> File () Out
+  -> ExceptT GovernanceActionsError IO ()
+runGovernanceActionCreateProtocolParametersUpdate sbe eraBasedPParams oFp = do
+  let updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams
+      apiUpdateProtocolParamsType = fromLedgerPParamsUpdate sbe updateProtocolParams
+      -- TODO: Update EraBasedProtocolParametersUpdate to require genesis delegate keys
+      -- depending on the era
+      -- TODO: Require expiration epoch no
+      upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType [] (error "runGovernanceActionCreateProtocolParametersUpdate")
+
+  firstExceptT GovernanceActionsCmdWriteFileError . newExceptT
+    $ writeLazyByteStringFile oFp $ textEnvelopeToJSON Nothing upProp

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

@@ -121,10 +121,13 @@ data ShelleyTxCmdError
   | ShelleyTxCmdTxCertificatesValidationError TxCertificatesValidationError
   | ShelleyTxCmdTxUpdateProposalValidationError TxUpdateProposalValidationError
   | ShelleyTxCmdScriptValidityValidationError TxScriptValidityValidationError
+  | ShelleyTxCmdProtocolParamsConverstionError ProtocolParametersConversionError
 
 renderShelleyTxCmdError :: ShelleyTxCmdError -> Text
 renderShelleyTxCmdError err =
   case err of
+    ShelleyTxCmdProtocolParamsConverstionError err' ->
+      "Error while converting protocol parameters: " <> Text.pack (displayError err')
     ShelleyTxCmdVoteError voteErr -> Text.pack $ show voteErr
     ShelleyTxCmdConstitutionError constErr -> Text.pack $ show constErr
     ShelleyTxCmdReadTextViewFileError fileErr -> Text.pack (displayError fileErr)
@@ -420,12 +423,14 @@ runTxBuildCmd
       let BuildTxWith mTxProtocolParams = txProtocolParams txBodycontent
 
       pparams <- pure mTxProtocolParams & onNothing (left ShelleyTxCmdProtocolParametersNotPresentInTxBody)
+      pp <- case cardanoEraStyle cEra of
+              LegacyByronEra -> left ShelleyTxCmdByronEra
+              ShelleyBasedEra sbe ->
+                hoistEither . first ShelleyTxCmdProtocolParamsConverstionError $ toLedgerPParams sbe pparams
 
       executionUnitPrices <- pure (protocolParamPrices pparams) & onNothing (left ShelleyTxCmdPParamExecutionUnitsNotAvailable)
 
       let consensusMode = consensusModeOnly cModeParams
-      bpp <- hoistEither . first (ShelleyTxCmdTxBodyError . TxBodyProtocolParamsConversionError) $
-        bundleProtocolParams cEra pparams
 
       case consensusMode of
         CardanoMode -> do
@@ -447,7 +452,7 @@ runTxBuildCmd
             firstExceptT ShelleyTxCmdTxExecUnitsErr $ hoistEither
               $ evaluateTransactionExecutionUnits
                   systemStart (toLedgerEpochInfo eraHistory)
-                  bpp txEraUtxo balancedTxBody
+                  pp txEraUtxo balancedTxBody
 
           scriptCostOutput <-
             firstExceptT ShelleyTxCmdPlutusScriptCostErr $ hoistEither
@@ -714,7 +719,7 @@ runTxBuild
   validatedTxScriptValidity <- hoistEither (first ShelleyTxCmdScriptValidityValidationError $ validateTxScriptValidity era mScriptValidity)
 
   case (consensusMode, cardanoEraStyle era) of
-    (CardanoMode, ShelleyBasedEra _sbe) -> do
+    (CardanoMode, ShelleyBasedEra sbe) -> do
       void $ pure (toEraInMode era CardanoMode)
         & onNothing (left (ShelleyTxCmdEraConsensusModeMismatchTxBalance outputOptions
                             (AnyConsensusMode CardanoMode) (AnyCardanoEra era)))
@@ -743,6 +748,8 @@ runTxBuild
           & onLeft (left . ShelleyTxCmdQueryConvenienceError . AcqFailure)
           & onLeft (left . ShelleyTxCmdQueryConvenienceError)
 
+      pp <- hoistEither . first ShelleyTxCmdProtocolParamsConverstionError $ toLedgerPParams sbe pparams
+
       validatedPParams <- hoistEither $ first ShelleyTxCmdProtocolParametersValidationError
                                       $ validateProtocolParameters era (Just pparams)
       let validatedTxGovernanceActions = proposals
@@ -785,7 +792,7 @@ runTxBuild
         firstExceptT ShelleyTxCmdBalanceTxBody
           . hoistEither
           $ makeTransactionBodyAutoBalance systemStart (toLedgerEpochInfo eraHistory)
-                                           pparams stakePools stakeDelegDeposits txEraUtxo
+                                           pp stakePools stakeDelegDeposits txEraUtxo
                                            txBodyContent cAddr mOverrideWits
 
       liftIO $ putStrLn $ "Estimated transaction fee: " <> (show fee :: String)
@@ -1256,9 +1263,8 @@ runTxCalculateMinRequiredUTxO (AnyCardanoEra era) pParamsFile txOut = do
     ShelleyBasedEra sbe -> do
       firstExceptT ShelleyTxCmdPParamsErr . hoistEither
         $ checkProtocolParameters sbe pp
-      bpparams <- hoistEither . first (ShelleyTxCmdTxBodyError . TxBodyProtocolParamsConversionError) $
-        bundleProtocolParams era pp
-      let minValue = calculateMinimumUTxO sbe out bpparams
+      pp' <- hoistEither . first ShelleyTxCmdProtocolParamsConverstionError $ toLedgerPParams sbe pp
+      let minValue = calculateMinimumUTxO sbe out pp'
       liftIO . IO.print $ minValue
 
 runTxCreatePolicyId :: ScriptFile -> ExceptT ShelleyTxCmdError IO ()