Merge pull request #369 from input-output-hk/jordan/update-protocol-p…

…arameters-fix

Update Protocol Parameters Fix

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

@@ -1,7 +1,10 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
 
 module Cardano.CLI.EraBased.Commands.Governance.Actions
   ( GovernanceActionCmds(..)
@@ -12,6 +15,8 @@ module Cardano.CLI.EraBased.Commands.Governance.Actions
   , GovernanceActionViewCmdArgs(..)
   , GovernanceActionProtocolParametersUpdateCmdArgs(..)
   , GovernanceActionTreasuryWithdrawalCmdArgs(..)
+  , UpdateProtocolParametersConwayOnwards(..)
+  , UpdateProtocolParametersPreConway(..)
   , renderGovernanceActionCmds
 
   , AnyStakeIdentifier(..)
@@ -93,11 +98,11 @@ data GovernanceActionCreateNoConfidenceCmdArgs era
 
 data GovernanceActionProtocolParametersUpdateCmdArgs era
   = GovernanceActionProtocolParametersUpdateCmdArgs
-      { eon               :: !(ConwayEraOnwards era)
-      , epochNo           :: !EpochNo
-      , genesisVkeyFiles  :: ![VerificationKeyFile In]
-      , pparamsUpdate     :: !(EraBasedProtocolParametersUpdate era)
-      , outFile           :: !(File () Out)
+      { uppShelleyBasedEra :: !(ShelleyBasedEra era)
+      , uppPreConway       :: !(Maybe (UpdateProtocolParametersPreConway era))
+      , uppConwayOnwards   :: !(Maybe (UpdateProtocolParametersConwayOnwards era))
+      , uppNewPParams      :: !(EraBasedProtocolParametersUpdate era)
+      , uppFilePath        :: !(File () Out)
       } deriving Show
 
 data GovernanceActionTreasuryWithdrawalCmdArgs era
@@ -120,6 +125,29 @@ data GovernanceActionViewCmdArgs era
       , mOutFile   :: !(Maybe (File () Out))
       } deriving Show
 
+data UpdateProtocolParametersConwayOnwards era
+  = UpdateProtocolParametersConwayOnwards
+      { eon                 :: !(ConwayEraOnwards era)
+      , networkId           :: !Ledger.Network
+      , deposit             :: !Lovelace
+      , returnAddr          :: !AnyStakeIdentifier
+      , proposalUrl         :: !ProposalUrl
+      , proposalHashSource  :: !ProposalHashSource
+      , governanceActionId  :: !(Maybe (TxId, Word32))
+      }
+
+deriving instance Show (UpdateProtocolParametersConwayOnwards era)
+
+data UpdateProtocolParametersPreConway era
+  = UpdateProtocolParametersPreConway
+      { eon                     :: !(ShelleyToBabbageEra era)
+      , expiryEpoch             :: !EpochNo
+      , genesisVerificationKeys :: ![VerificationKeyFile In]
+      }
+
+
+deriving instance Show (UpdateProtocolParametersPreConway era)
+
 renderGovernanceActionCmds :: GovernanceActionCmds era -> Text
 renderGovernanceActionCmds = ("governance action " <>) . \case
   GovernanceActionCreateConstitutionCmd {} ->

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

@@ -160,23 +160,59 @@ pAnyStakeIdentifier prefix =
     , Cmd.AnyStakeKey <$> pStakeVerificationKeyOrHashOrFile prefix
     ]
 
+pUpdateProtocolParametersPreConway :: ShelleyToBabbageEra era -> Parser (Cmd.UpdateProtocolParametersPreConway era)
+pUpdateProtocolParametersPreConway shelleyToBab =
+  Cmd.UpdateProtocolParametersPreConway shelleyToBab
+    <$> pEpochNoUpdateProp
+    <*> pProtocolParametersUpdateGenesisKeys
+
+pUpdateProtocolParametersPostConway :: ConwayEraOnwards era -> Parser (Cmd.UpdateProtocolParametersConwayOnwards era)
+pUpdateProtocolParametersPostConway conwayOnwards =
+  Cmd.UpdateProtocolParametersConwayOnwards conwayOnwards
+    <$> pNetwork
+    <*> pGovActionDeposit
+    <*> pAnyStakeIdentifier Nothing
+    <*> pProposalUrl
+    <*> pProposalHashSource
+    <*> pPreviousGovernanceAction
+
+
+pUpdateProtocolParametersCmd :: ShelleyBasedEra era -> Parser (Cmd.GovernanceActionProtocolParametersUpdateCmdArgs era)
+pUpdateProtocolParametersCmd =
+  caseShelleyToBabbageOrConwayEraOnwards
+    (\shelleyToBab ->
+        let sbe = shelleyToBabbageEraToShelleyBasedEra shelleyToBab
+        in subParser "create-protocol-parameters-update"
+                         $ Opt.info
+                             ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs (shelleyToBabbageEraToShelleyBasedEra shelleyToBab)
+                                 <$> fmap Just (pUpdateProtocolParametersPreConway shelleyToBab)
+                                 <*> pure Nothing
+                                 <*> dpGovActionProtocolParametersUpdate sbe
+                                 <*> pOutputFile
+                             )
+                         $ Opt.progDesc "Create a protocol parameters update.")
+    (\conwayOnwards ->
+        let sbe = conwayEraOnwardsToShelleyBasedEra conwayOnwards
+        in subParser "create-protocol-parameters-update"
+                        $ Opt.info
+                            ( Cmd.GovernanceActionProtocolParametersUpdateCmdArgs
+                                (conwayEraOnwardsToShelleyBasedEra conwayOnwards) Nothing
+                                <$> fmap Just (pUpdateProtocolParametersPostConway conwayOnwards)
+                                <*> dpGovActionProtocolParametersUpdate sbe
+                                <*> pOutputFile
+                            )
+                        $ Opt.progDesc "Create a protocol parameters update."
+
+    )
+
 pGovernanceActionProtocolParametersUpdateCmd :: ()
   => CardanoEra era
   -> Maybe (Parser (Cmd.GovernanceActionCmds era))
 pGovernanceActionProtocolParametersUpdateCmd era = do
-  eon <- forEraMaybeEon era
-  let sbe = conwayEraOnwardsToShelleyBasedEra eon
-  pure
-    $ subParser "create-protocol-parameters-update"
-    $ Opt.info
-        ( fmap Cmd.GovernanceActionProtocolParametersUpdateCmd $
-            Cmd.GovernanceActionProtocolParametersUpdateCmdArgs eon
-              <$> pEpochNoUpdateProp
-              <*> pProtocolParametersUpdateGenesisKeys sbe
-              <*> dpGovActionProtocolParametersUpdate sbe
-              <*> pOutputFile
-        )
-    $ Opt.progDesc "Create a protocol parameters update."
+  w <- forEraMaybeEon era
+  pure $ Cmd.GovernanceActionProtocolParametersUpdateCmd
+    <$> pUpdateProtocolParametersCmd w
+
 
 convertToLedger :: (a -> b) -> Parser (Maybe a) -> Parser (StrictMaybe b)
 convertToLedger conv = fmap (maybeToStrictMaybe . fmap conv)
@@ -262,11 +298,8 @@ pIntroducedInConwayPParams =
     <*> convertToLedger id (optional pDRepActivity)
 
 -- Not necessary in Conway era onwards
-pProtocolParametersUpdateGenesisKeys :: ShelleyBasedEra era -> Parser [VerificationKeyFile In]
-pProtocolParametersUpdateGenesisKeys =
-  caseShelleyToBabbageOrConwayEraOnwards
-    (const (many pGenesisVerificationKeyFile))
-    (const empty)
+pProtocolParametersUpdateGenesisKeys :: Parser [VerificationKeyFile In]
+pProtocolParametersUpdateGenesisKeys = some pGenesisVerificationKeyFile
 
 dpGovActionProtocolParametersUpdate
   :: ShelleyBasedEra era -> Parser (EraBasedProtocolParametersUpdate era)

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

@@ -14,6 +14,7 @@ import           Cardano.CLI.EraBased.Options.Common
 import           Options.Applicative
 import qualified Options.Applicative as Opt
 
+
 pStakeAddressCmds :: ()
   => CardanoEra era
   -> EnvCli
@@ -99,16 +100,27 @@ pStakeAddressDeregistrationCertificateCmd :: ()
   => CardanoEra era
   -> Maybe (Parser (StakeAddressCmds era))
 pStakeAddressDeregistrationCertificateCmd era = do
-  w <- forEraMaybeEon era
-  pure
-    $ subParser "deregistration-certificate"
-    $ Opt.info
-        ( StakeAddressDeregistrationCertificateCmd w
-            <$> pStakeIdentifier
-            <*> optional pKeyRegistDeposit
-            <*> pOutputFile
-        )
-    $ Opt.progDesc "Create a stake address deregistration certificate"
+  forEraInEonMaybe era $ \sbe ->
+    caseShelleyToBabbageOrConwayEraOnwards
+      (\shelleyToBabbage -> subParser "deregistration-certificate"
+           $ Opt.info
+               ( StakeAddressDeregistrationCertificateCmd (shelleyToBabbageEraToShelleyBasedEra shelleyToBabbage)
+                   <$> pStakeIdentifier
+                   <*> pure Nothing
+                   <*> pOutputFile
+               )
+           $ Opt.progDesc "Create a stake address deregistration certificate"
+      )
+      (\conwayOnwards -> subParser "deregistration-certificate"
+           $ Opt.info
+               ( StakeAddressDeregistrationCertificateCmd (conwayEraOnwardsToShelleyBasedEra conwayOnwards)
+                   <$> pStakeIdentifier
+                   <*> fmap Just pKeyRegistDeposit
+                   <*> pOutputFile
+               )
+           $ Opt.progDesc "Create a stake address deregistration certificate"
+      )
+      sbe
 
 pStakeAddressStakeDelegationCertificateCmd :: ()
   => CardanoEra era

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

@@ -246,31 +246,62 @@ runGovernanceActionCreateNewCommitteeCmd
 runGovernanceActionCreateProtocolParametersUpdateCmd :: ()
   => Cmd.GovernanceActionProtocolParametersUpdateCmdArgs era
   -> ExceptT GovernanceActionsError IO ()
-runGovernanceActionCreateProtocolParametersUpdateCmd
-    Cmd.GovernanceActionProtocolParametersUpdateCmdArgs
-      { Cmd.eon
-      , Cmd.epochNo
-      , Cmd.genesisVkeyFiles
-      , Cmd.pparamsUpdate
-      , Cmd.outFile
-      } = do
-  let sbe = conwayEraOnwardsToShelleyBasedEra eon
+runGovernanceActionCreateProtocolParametersUpdateCmd eraBasedPParams' = do
+  let sbe = uppShelleyBasedEra eraBasedPParams'
+  caseShelleyToBabbageOrConwayEraOnwards
+    (\sToB -> do
+         let oFp = uppFilePath eraBasedPParams'
+             anyEra = AnyShelleyBasedEra $ shelleyToBabbageEraToShelleyBasedEra sToB
+         UpdateProtocolParametersPreConway _cOn expEpoch genesisVerKeys
+           <- hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra)
+                $ uppPreConway eraBasedPParams'
+         let eraBasedPParams = uppNewPParams eraBasedPParams'
+             updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams
+             apiUpdateProtocolParamsType = fromLedgerPParamsUpdate sbe updateProtocolParams
+         genVKeys <- sequence
+           [ firstExceptT GovernanceActionsCmdReadTextEnvelopeFileError . newExceptT
+               $ readFileTextEnvelope (AsVerificationKey AsGenesisKey) vkeyFile
+           | vkeyFile <- genesisVerKeys
+           ]
+         let genKeyHashes = fmap verificationKeyHash genVKeys
+             upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType genKeyHashes expEpoch
+         firstExceptT GovernanceActionsCmdWriteFileError . newExceptT
+           $ writeLazyByteStringFile oFp $ textEnvelopeToJSON Nothing upProp
+    )
+    (\conwayOnwards -> do
+        let oFp = uppFilePath eraBasedPParams'
+            anyEra = AnyShelleyBasedEra $ conwayEraOnwardsToShelleyBasedEra conwayOnwards
+
+        UpdateProtocolParametersConwayOnwards _cOnwards network deposit returnAddr proposalUrl
+                                              proposalHashSource mPrevGovActId
+          <- hoistMaybe (GovernanceActionsValueUpdateProtocolParametersNotFound anyEra)
+              $ uppConwayOnwards eraBasedPParams'
+
+        returnKeyHash <- readStakeKeyHash returnAddr
+
+        proposalHash <-
+           proposalHashSourceToHash proposalHashSource
+             & firstExceptT GovernanceActionsCmdProposalError
+
+        let eraBasedPParams = uppNewPParams eraBasedPParams'
+            updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams
+
+            prevGovActId = Ledger.maybeToStrictMaybe $ uncurry createPreviousGovernanceActionId <$> mPrevGovActId
+            proposalAnchor = Ledger.Anchor
+              { Ledger.anchorUrl = unProposalUrl proposalUrl
+              , Ledger.anchorDataHash = proposalHash
+              }
+            govAct = UpdatePParams prevGovActId updateProtocolParams
+
+
+        let proposalProcedure = createProposalProcedure sbe network deposit returnKeyHash govAct proposalAnchor
+
+        firstExceptT GovernanceActionsCmdWriteFileError . newExceptT
+          $ conwayEraOnwardsConstraints conwayOnwards
+          $ writeFileTextEnvelope oFp Nothing proposalProcedure
+    )
+    sbe
 
-  genVKeys <- sequence
-    [ firstExceptT GovernanceActionsCmdReadTextEnvelopeFileError . newExceptT
-        $ readFileTextEnvelope (AsVerificationKey AsGenesisKey) vkeyFile
-    | vkeyFile <- genesisVkeyFiles
-    ]
-
-  let updateProtocolParams = createEraBasedProtocolParamUpdate sbe pparamsUpdate
-      apiUpdateProtocolParamsType = fromLedgerPParamsUpdate sbe updateProtocolParams
-      genKeyHashes = fmap verificationKeyHash genVKeys
-      -- TODO: Update EraBasedProtocolParametersUpdate to require genesis delegate keys
-      -- depending on the era
-      upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType genKeyHashes epochNo
-
-  firstExceptT GovernanceActionsCmdWriteFileError . newExceptT
-    $ writeLazyByteStringFile outFile $ textEnvelopeToJSON Nothing upProp
 
 readStakeKeyHash :: AnyStakeIdentifier -> ExceptT GovernanceActionsError IO (Hash StakeKey)
 readStakeKeyHash anyStake =

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

@@ -162,6 +162,7 @@ createRegistrationCertRequirements sbe stakeCred mdeposit =
       return $ StakeAddrRegistrationPreConway ShelleyToBabbageEraBabbage stakeCred
     ShelleyBasedEraConway ->
       case mdeposit of
+        -- TODO: This error constructor will never be called
         Nothing -> Left StakeAddressRegistrationDepositRequired
         Just dep ->
           return $ StakeAddrRegistrationConway ConwayEraOnwardsConway dep stakeCred

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

@@ -14,6 +14,7 @@ data GovernanceActionsError
   | GovernanceActionsCmdReadFileError (FileError InputDecodeError)
   | GovernanceActionsCmdReadTextEnvelopeFileError (FileError TextEnvelopeError)
   | GovernanceActionsCmdWriteFileError (FileError ())
+  | GovernanceActionsValueUpdateProtocolParametersNotFound AnyShelleyBasedEra
   deriving Show
 
 instance Error GovernanceActionsError where
@@ -28,3 +29,8 @@ instance Error GovernanceActionsError where
       "Cannot read text envelope file: " <> displayError e
     GovernanceActionsCmdWriteFileError e ->
       "Cannot write file: " <> displayError e
+    GovernanceActionsValueUpdateProtocolParametersNotFound (AnyShelleyBasedEra expectedShelleyEra) ->
+      mconcat
+        [ "Protocol parameters update value for " <> show (toCardanoEra expectedShelleyEra)
+        , " was not found."
+        ]