Merge pull request #1250 from IntersectMBO/jordan/move-protocol-parameters-update

Move protocol parameters update code

Author: Jimbo4350

cardano-cli/cardano-cli.cabal

@@ -64,6 +64,7 @@ library
     Cardano.CLI.Compatible.Governance.Command
     Cardano.CLI.Compatible.Governance.Option
     Cardano.CLI.Compatible.Governance.Run
+    Cardano.CLI.Compatible.Governance.Types
     Cardano.CLI.Compatible.Json.Friendly
     Cardano.CLI.Compatible.Option
     Cardano.CLI.Compatible.Run

cardano-cli/src/Cardano/CLI/Byron/Delegation.hs

@@ -20,7 +20,6 @@ import Cardano.Api.Monad.Error
 import Cardano.Api.Pretty
 import Cardano.Api.Serialise.Raw
 
-import Cardano.CLI.Byron.Key (ByronKeyFailure, renderByronKeyFailure)
 import Cardano.CLI.Type.Common (CertificateFile (..))
 import Cardano.Crypto (ProtocolMagicId)
 import Cardano.Crypto qualified as Crypto
@@ -38,7 +37,6 @@ import Formatting (Format, sformat)
 data ByronDelegationError
   = CertificateValidationErrors !FilePath ![Text]
   | DlgCertificateDeserialisationFailed !FilePath !Text
-  | ByronDelegationKeyError !ByronKeyFailure
   deriving Show
 
 renderByronDelegationError :: ByronDelegationError -> Doc ann
@@ -47,8 +45,6 @@ renderByronDelegationError = \case
     "Certificate validation error(s) at: " <> pshow certFp <> " Errors: " <> pshow errs
   DlgCertificateDeserialisationFailed certFp deSererr ->
     "Certificate deserialisation error at: " <> pshow certFp <> " Error: " <> pshow deSererr
-  ByronDelegationKeyError kerr ->
-    renderByronKeyFailure kerr
 
 -- TODO:  we need to support password-protected secrets.
 

cardano-cli/src/Cardano/CLI/Byron/Vote.hs

@@ -4,20 +4,16 @@
 {-# LANGUAGE RankNTypes #-}
 
 module Cardano.CLI.Byron.Vote
-  ( ByronVoteError (..)
-  , readByronVote
-  , renderByronVoteError
+  ( readByronVote
   , runVoteCreation
   , submitByronVote
   )
 where
 
 import Cardano.Api
-  ( Doc
-  , SocketPath
+  ( SocketPath
   , deserialiseFromRawBytes
   , liftIO
-  , pretty
   , serialiseToRawBytes
   )
 import Cardano.Api.Byron
@@ -35,18 +31,6 @@ import Cardano.CLI.Type.Common
 import Control.Tracer (stdoutTracer, traceWith)
 import Data.ByteString qualified as BS
 
-data ByronVoteError
-  = ByronVoteDecodingError !FilePath
-  deriving Show
-
-instance Error ByronVoteError where
-  prettyError = renderByronVoteError
-
-renderByronVoteError :: ByronVoteError -> Doc ann
-renderByronVoteError = \case
-  ByronVoteDecodingError fp ->
-    "Error decoding Byron vote at " <> pretty fp
-
 runVoteCreation
   :: NetworkId
   -> SigningKeyFile In

cardano-cli/src/Cardano/CLI/Compatible/Governance/Command.hs

@@ -9,7 +9,7 @@ where
 
 import Cardano.Api
 
-import Cardano.CLI.EraBased.Governance.Actions.Command
+import Cardano.CLI.Compatible.Governance.Types
 import Cardano.CLI.EraBased.Governance.Option
 import Cardano.CLI.Type.Key (VerificationKeyOrHashOrFile)
 
@@ -19,7 +19,8 @@ import Data.Text
 -- we can remove all remaining legacy commands. We can also remove/move the exising
 -- byron era commands under the new compatiblilty commands.
 data CompatibleGovernanceCmds era
-  = CreateCompatibleProtocolParametersUpdateCmd (GovernanceActionCmds era)
+  = CreateCompatibleProtocolParametersUpdateCmd
+      (GovernanceActionProtocolParametersUpdateCmdArgs era)
   | CompatibleCreateMirCertificateStakeAddressesCmd
       (ShelleyToBabbageEra era)
       MIRPot
@@ -44,8 +45,8 @@ data CompatibleGovernanceCmds era
 
 renderCompatibleGovernanceCmds :: CompatibleGovernanceCmds era -> Text
 renderCompatibleGovernanceCmds = \case
-  CreateCompatibleProtocolParametersUpdateCmd cmd ->
-    renderGovernanceActionCmds cmd
+  CreateCompatibleProtocolParametersUpdateCmd{} ->
+    "governance create-protocol-parameters-update"
   CompatibleGenesisKeyDelegationCertificate{} ->
     "governance create-genesis-key-delegation-certificate"
   CompatibleCreateMirCertificateStakeAddressesCmd{} ->

cardano-cli/src/Cardano/CLI/Compatible/Governance/Option.hs

@@ -11,8 +11,8 @@ import Cardano.Api
 import Cardano.Api.Experimental (obtainCommonConstraints)
 
 import Cardano.CLI.Compatible.Governance.Command
+import Cardano.CLI.Compatible.Governance.Types
 import Cardano.CLI.EraBased.Common.Option
-import Cardano.CLI.EraBased.Governance.Actions.Command
 import Cardano.CLI.EraBased.Governance.Actions.Option
   ( pCostModelsFile
   , pGovActionProtocolParametersUpdate
@@ -53,7 +53,8 @@ pCompatibleGovernanceCmds sbe =
           sbe
       ]
 
-pGovernanceActionCmds :: ShelleyBasedEra era -> Maybe (Parser (GovernanceActionCmds era))
+pGovernanceActionCmds
+  :: ShelleyBasedEra era -> Maybe (Parser (GovernanceActionProtocolParametersUpdateCmdArgs era))
 pGovernanceActionCmds sbe =
   subInfoParser
     "action"
@@ -68,12 +69,11 @@ pGovernanceActionCmds sbe =
 pGovernanceActionProtocolParametersUpdateCmd
   :: ()
   => ShelleyBasedEra era
-  -> Maybe (Parser (GovernanceActionCmds era))
+  -> Maybe (Parser (GovernanceActionProtocolParametersUpdateCmdArgs era))
 pGovernanceActionProtocolParametersUpdateCmd sbe = do
   w <- forShelleyBasedEraMaybeEon sbe
   pure $
-    GovernanceActionProtocolParametersUpdateCmd
-      <$> pUpdateProtocolParametersCmd w
+    pUpdateProtocolParametersCmd w
 
 pUpdateProtocolParametersCmd
   :: ShelleyBasedEra era -> Parser (GovernanceActionProtocolParametersUpdateCmdArgs era)

cardano-cli/src/Cardano/CLI/Compatible/Governance/Run.hs

@@ -1,24 +1,34 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Cardano.CLI.Compatible.Governance.Run
   ( runCompatibleGovernanceCmds
   )
 where
 
+import Cardano.Api as Api
+import Cardano.Api.Ledger qualified as L
+
 import Cardano.CLI.Compatible.Exception
 import Cardano.CLI.Compatible.Governance.Command
+import Cardano.CLI.Compatible.Governance.Types
 import Cardano.CLI.EraBased.Governance.Actions.Run
 import Cardano.CLI.EraBased.Governance.GenesisKeyDelegationCertificate.Run
 import Cardano.CLI.EraBased.Governance.Run
+import Cardano.CLI.Read
+import Cardano.CLI.Type.Common
+import Cardano.CLI.Type.Error.GovernanceActionsError
 
 import Data.Typeable (Typeable)
 
 runCompatibleGovernanceCmds :: Typeable era => CompatibleGovernanceCmds era -> CIO e ()
 runCompatibleGovernanceCmds = \case
   CreateCompatibleProtocolParametersUpdateCmd cmd ->
-    runGovernanceActionCmds cmd
+    runCompatibleGovernanceActionCreateProtocolParametersUpdateCmd cmd
   LatestCompatibleGovernanceCmds cmd -> runGovernanceCmds cmd
   CompatibleGenesisKeyDelegationCertificate sta genVk genDelegVk vrfVk out ->
     runGovernanceGenesisKeyDelegationCertificate sta genVk genDelegVk vrfVk out
@@ -28,3 +38,119 @@ runCompatibleGovernanceCmds = \case
     runGovernanceCreateMirCertificateTransferToReservesCmd w ll oFp
   CompatibleCreateMirCertificateTransferToTreasuryCmd w ll oFp ->
     runGovernanceCreateMirCertificateTransferToReservesCmd w ll oFp
+
+runCompatibleGovernanceActionCreateProtocolParametersUpdateCmd
+  :: forall era e
+   . ()
+  => GovernanceActionProtocolParametersUpdateCmdArgs era
+  -> CIO e ()
+runCompatibleGovernanceActionCreateProtocolParametersUpdateCmd eraBasedPParams' = do
+  let sbe = uppShelleyBasedEra eraBasedPParams'
+  case sbe of
+    ShelleyBasedEraShelley ->
+      shelleyToBabbageProtocolParametersUpdate sbe eraBasedPParams'
+    ShelleyBasedEraAllegra ->
+      shelleyToBabbageProtocolParametersUpdate sbe eraBasedPParams'
+    ShelleyBasedEraMary ->
+      shelleyToBabbageProtocolParametersUpdate sbe eraBasedPParams'
+    ShelleyBasedEraAlonzo ->
+      shelleyToBabbageProtocolParametersUpdate sbe eraBasedPParams'
+    ShelleyBasedEraBabbage ->
+      shelleyToBabbageProtocolParametersUpdate sbe eraBasedPParams'
+    ShelleyBasedEraConway -> conwayProtocolParametersUpdate sbe eraBasedPParams'
+ where
+
+maybeAddUpdatedCostModel
+  :: GovernanceActionProtocolParametersUpdateCmdArgs era
+  -> CIO e (EraBasedProtocolParametersUpdate era)
+maybeAddUpdatedCostModel args = case uppCostModelsFile args of
+  Nothing -> pure $ uppNewPParams args
+  Just (CostModelsFile alonzoOnwards costModelsFile') -> do
+    costModels <-
+      fromExceptTCli $
+        readCostModels costModelsFile'
+    pure . addCostModelsToEraBasedProtocolParametersUpdate alonzoOnwards costModels $
+      uppNewPParams args
+
+conwayProtocolParametersUpdate
+  :: ShelleyBasedEra ConwayEra
+  -> GovernanceActionProtocolParametersUpdateCmdArgs ConwayEra
+  -> CIO e ()
+conwayProtocolParametersUpdate sbe args = do
+  let oFp = uppFilePath args
+      anyEra = AnyShelleyBasedEra sbe
+
+  UpdateProtocolParametersConwayOnwards
+    _cOnwards
+    network
+    deposit'
+    returnAddr'
+    proposalUrl'
+    proposalHash'
+    checkProposalHash'
+    mPrevGovActId
+    mConstitutionalScriptHash <-
+    fromExceptTCli $
+      hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra) $
+        uppConwayOnwards args
+
+  eraBasedPParams <- maybeAddUpdatedCostModel args
+
+  depositStakeCredential <-
+    getStakeCredentialFromIdentifier returnAddr'
+
+  let updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams
+
+      prevGovActId = L.maybeToStrictMaybe $ L.GovPurposeId <$> mPrevGovActId
+      proposalAnchor =
+        L.Anchor
+          { L.anchorUrl = unProposalUrl proposalUrl'
+          , L.anchorDataHash = proposalHash'
+          }
+
+  fromExceptTCli $ carryHashChecks checkProposalHash' proposalAnchor ProposalCheck
+
+  let govAct =
+        UpdatePParams
+          prevGovActId
+          updateProtocolParams
+          (toShelleyScriptHash <$> L.maybeToStrictMaybe mConstitutionalScriptHash)
+
+  let proposalProcedure = createProposalProcedure sbe network deposit' depositStakeCredential govAct proposalAnchor
+
+  fromEitherIOCli @(FileError ()) $
+    shelleyBasedEraConstraints sbe $
+      writeFileTextEnvelope oFp (Just "Update protocol parameters proposal") proposalProcedure
+
+shelleyToBabbageProtocolParametersUpdate
+  :: Typeable era
+  => ShelleyBasedEra era
+  -> GovernanceActionProtocolParametersUpdateCmdArgs era
+  -> CIO e ()
+shelleyToBabbageProtocolParametersUpdate sbe args = do
+  let oFp = uppFilePath args
+      anyEra = AnyShelleyBasedEra sbe
+  UpdateProtocolParametersPreConway _stB expEpoch genesisVerKeys <-
+    fromExceptTCli $
+      hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra) $
+        uppPreConway args
+
+  eraBasedPParams <- maybeAddUpdatedCostModel args
+
+  let updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams
+      apiUpdateProtocolParamsType = fromLedgerPParamsUpdate sbe updateProtocolParams
+
+  genVKeys <-
+    sequence
+      [ fromEitherIOCli $
+          readFileTextEnvelope vkeyFile
+      | vkeyFile <- genesisVerKeys
+      ]
+
+  let genKeyHashes = fmap verificationKeyHash genVKeys
+      upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType genKeyHashes expEpoch
+
+  fromEitherIOCli @(FileError ()) $
+    shelleyBasedEraConstraints sbe $
+      writeLazyByteStringFile oFp $
+        textEnvelopeToJSON Nothing upProp

cardano-cli/src/Cardano/CLI/Compatible/Governance/Types.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Cardano.CLI.Compatible.Governance.Types
+  ( GovernanceActionProtocolParametersUpdateCmdArgs (..)
+  , UpdateProtocolParametersPreConway (..)
+  , UpdateProtocolParametersConwayOnwards (..)
+  , CostModelsFile (..)
+  )
+where
+
+import Cardano.Api
+import Cardano.Api.Experimental qualified as Exp
+import Cardano.Api.Ledger qualified as L
+
+import Cardano.CLI.Type.Common
+import Cardano.CLI.Type.Key
+
+data GovernanceActionProtocolParametersUpdateCmdArgs era
+  = GovernanceActionProtocolParametersUpdateCmdArgs
+  { uppShelleyBasedEra :: !(ShelleyBasedEra era)
+  , uppPreConway :: !(Maybe (UpdateProtocolParametersPreConway era))
+  , uppConwayOnwards :: !(Maybe (UpdateProtocolParametersConwayOnwards era))
+  , uppNewPParams :: !(EraBasedProtocolParametersUpdate era)
+  -- ^ New parameters to be proposed. From Alonzo onwards, the type
+  -- 'EraBasedProtocolParametersUpdate' also contains cost models. Since all
+  -- other protocol parameters are read from command line arguments, whereas
+  -- the cost models are read from a file, we separate the cost models from
+  -- the rest of the protocol parameters to ease parsing.
+  , uppCostModelsFile :: !(Maybe (CostModelsFile era))
+  -- ^ The new cost models proposed. See the comment at 'uppNewPParams' for
+  -- why this is a separate field.
+  , uppFilePath :: !(File () Out)
+  }
+  deriving Show
+
+data UpdateProtocolParametersPreConway era
+  = UpdateProtocolParametersPreConway
+  { eon :: !(ShelleyToBabbageEra era)
+  , expiryEpoch :: !EpochNo
+  , genesisVerificationKeys :: ![VerificationKeyFile In]
+  }
+
+deriving instance Show (UpdateProtocolParametersPreConway era)
+
+data UpdateProtocolParametersConwayOnwards era
+  = UpdateProtocolParametersConwayOnwards
+  { era :: !(Exp.Era era)
+  , networkId :: !L.Network
+  , deposit :: !Lovelace
+  , returnAddr :: !StakeIdentifier
+  , proposalUrl :: !ProposalUrl
+  , proposalHash :: !(L.SafeHash L.AnchorData)
+  , checkProposalHash :: !(MustCheckHash ProposalUrl)
+  , governanceActionId :: !(Maybe L.GovActionId)
+  , constitutionScriptHash :: !(Maybe ScriptHash)
+  }
+
+deriving instance Show (UpdateProtocolParametersConwayOnwards era)
+
+data CostModelsFile era
+  = CostModelsFile
+  { eon :: !(AlonzoEraOnwards era)
+  , costModelsFile :: !(File L.CostModels In)
+  }
+  deriving Show

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

@@ -38,18 +38,6 @@ import Cardano.CLI.Type.Common
 import Control.Monad
 import Lens.Micro
 
-data CompatibleTransactionError
-  = forall err. Error err => CompatibleFileError (FileError err)
-  | CompatibleProposalError !ProposalError
-
-instance Show CompatibleTransactionError where
-  show = show . prettyError
-
-instance Error CompatibleTransactionError where
-  prettyError = \case
-    CompatibleFileError e -> prettyError e
-    CompatibleProposalError e -> pshow e
-
 runCompatibleTransactionCmd
   :: forall era e
    . CompatibleTransactionCmds era