Merge pull request #155 from input-output-hk/jordan/treasury-withdraw…

…al-governance-action Add conway governance action create-treasury-withdrawal
IntersectMBO · Aug 17, 2023 · 6cd10c4 · 6cd10c4
2 parents cc5b45c + 5b7eb22
commit 6cd10c4
Show file tree

Hide file tree

Showing 16 changed files with 346 additions and 39 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Governance/Actions.hs
@@ -1,10 +1,13 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 module Cardano.CLI.EraBased.Commands.Governance.Actions
   ( AnyStakeIdentifier(..)
   , GovernanceActionCmds(..)
   , EraBasedNewConstitution(..)
+  , EraBasedTreasuryWithdrawal(..)
   , renderGovernanceActionCmds
   ) where
 
@@ -22,9 +25,14 @@ data GovernanceActionCmds era
       EraBasedNewConstitution
   | GovernanceActionProtocolParametersUpdate
       (ShelleyBasedEra era)
+      EpochNo
+      [VerificationKeyFile In]
       (EraBasedProtocolParametersUpdate era)
       (File () Out)
-    deriving Show
+  | GovernanceActionTreasuryWithdrawal
+      (ConwayEraOnwards era)
+      EraBasedTreasuryWithdrawal
+  deriving Show
 
 data EraBasedNewConstitution
   = EraBasedNewConstitution
@@ -34,6 +42,16 @@ data EraBasedNewConstitution
       , encFilePath :: File () Out
       } deriving Show
 
+data EraBasedTreasuryWithdrawal where
+  EraBasedTreasuryWithdrawal
+    :: Lovelace -- ^ Deposit
+    -> AnyStakeIdentifier -- ^ Return address
+    -> [(AnyStakeIdentifier, Lovelace)]
+    -> File () Out
+    -> EraBasedTreasuryWithdrawal
+
+deriving instance Show EraBasedTreasuryWithdrawal
+
 renderGovernanceActionCmds :: GovernanceActionCmds era -> Text
 renderGovernanceActionCmds = \case
   GovernanceActionCreateConstitution {} ->
@@ -42,6 +60,8 @@ renderGovernanceActionCmds = \case
   GovernanceActionProtocolParametersUpdate {} ->
     "governance action create-protocol-parameters-update"
 
+  GovernanceActionTreasuryWithdrawal {} ->
+    "governance action create-treasury-withdrawal"
 
 data AnyStakeIdentifier
   = AnyStakeKey (VerificationKeyOrHashOrFile StakeKey)

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Options/Governance/Actions.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 
@@ -11,6 +12,7 @@ import           Cardano.Api.Shelley
 
 import           Cardano.CLI.EraBased.Commands.Governance.Actions
 import           Cardano.CLI.EraBased.Options.Common
+import           Cardano.CLI.Types.Common
 import           Cardano.Ledger.BaseTypes (NonNegativeInterval)
 import qualified Cardano.Ledger.BaseTypes as Ledger
 
@@ -31,6 +33,7 @@ pGovernanceActionCmds era =
     )
     [ pGovernanceActionNewConstitution era
     , pGovernanceActionProtocolParametersUpdate era
+    , pGovernanceActionTreasuryWithdrawal era
     ]
 
 
@@ -72,27 +75,39 @@ pGovernanceActionProtocolParametersUpdate era =
         case sbe of
          ShelleyBasedEraShelley ->
            GovernanceActionProtocolParametersUpdate sbe
-             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraShelley
+             <$> pEpochNoUpdateProp
+             <*> pProtocolParametersUpdateGenesisKeys sbe
+             <*> dpGovActionProtocolParametersUpdate ShelleyBasedEraShelley
              <*> pOutputFile
          ShelleyBasedEraAllegra ->
            GovernanceActionProtocolParametersUpdate sbe
-             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraAllegra
+             <$> pEpochNoUpdateProp
+             <*> pProtocolParametersUpdateGenesisKeys sbe
+             <*> dpGovActionProtocolParametersUpdate ShelleyBasedEraAllegra
              <*> pOutputFile
          ShelleyBasedEraMary ->
            GovernanceActionProtocolParametersUpdate sbe
-             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraMary
+             <$> pEpochNoUpdateProp
+             <*> pProtocolParametersUpdateGenesisKeys sbe
+             <*> dpGovActionProtocolParametersUpdate ShelleyBasedEraMary
              <*> pOutputFile
          ShelleyBasedEraAlonzo ->
            GovernanceActionProtocolParametersUpdate sbe
-             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraAlonzo
+             <$> pEpochNoUpdateProp
+             <*> pProtocolParametersUpdateGenesisKeys sbe
+             <*> dpGovActionProtocolParametersUpdate ShelleyBasedEraAlonzo
              <*> pOutputFile
          ShelleyBasedEraBabbage ->
            GovernanceActionProtocolParametersUpdate sbe
-             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraBabbage
+             <$> pEpochNoUpdateProp
+             <*> pProtocolParametersUpdateGenesisKeys sbe
+             <*> dpGovActionProtocolParametersUpdate ShelleyBasedEraBabbage
              <*> pOutputFile
          ShelleyBasedEraConway ->
            GovernanceActionProtocolParametersUpdate sbe
-             <$> dpGovActionProtocolParametersUpdate ShelleyBasedEraConway
+             <$> pEpochNoUpdateProp
+             <*> pProtocolParametersUpdateGenesisKeys sbe
+             <*> dpGovActionProtocolParametersUpdate ShelleyBasedEraConway
              <*> pOutputFile
 
 convertToLedger :: (a -> b) -> Parser (Maybe a) -> Parser (StrictMaybe b)
@@ -174,7 +189,19 @@ pIntroducedInBabbagePParams =
   IntroducedInBabbagePParams
     <$> convertToLedger (CoinPerByte . toShelleyLovelace) (optional pUTxOCostPerByte)
 
-dpGovActionProtocolParametersUpdate :: ShelleyBasedEra era -> Parser (EraBasedProtocolParametersUpdate era)
+-- Not necessary in Conway era onwards
+pProtocolParametersUpdateGenesisKeys :: ShelleyBasedEra era -> Parser [VerificationKeyFile In]
+pProtocolParametersUpdateGenesisKeys sbe =
+  case sbe of
+    ShelleyBasedEraShelley -> many pGenesisVerificationKeyFile
+    ShelleyBasedEraAllegra -> many pGenesisVerificationKeyFile
+    ShelleyBasedEraMary -> many pGenesisVerificationKeyFile
+    ShelleyBasedEraAlonzo -> many pGenesisVerificationKeyFile
+    ShelleyBasedEraBabbage -> many pGenesisVerificationKeyFile
+    ShelleyBasedEraConway -> empty
+
+dpGovActionProtocolParametersUpdate
+  :: ShelleyBasedEra era -> Parser (EraBasedProtocolParametersUpdate era)
 dpGovActionProtocolParametersUpdate = \case
   ShelleyBasedEraShelley ->
     ShelleyEraBasedProtocolParametersUpdate
@@ -207,3 +234,21 @@ dpGovActionProtocolParametersUpdate = \case
       <$> pCommonProtocolParameters
       <*> pAlonzoOnwardsPParams
       <*> pIntroducedInBabbagePParams
+
+pGovernanceActionTreasuryWithdrawal :: CardanoEra era -> Maybe (Parser (GovernanceActionCmds era))
+pGovernanceActionTreasuryWithdrawal =
+  featureInEra Nothing (\cOn -> Just $
+     subParser "create-treasury-withdrawal"
+        $ Opt.info (pCmd cOn)
+        $ Opt.progDesc "Create a treasury withdrawal.")
+ where
+  pCmd :: ConwayEraOnwards era -> Parser (GovernanceActionCmds era)
+  pCmd cOn =
+    fmap (GovernanceActionTreasuryWithdrawal cOn) $
+      EraBasedTreasuryWithdrawal
+        <$> pGovActionDeposit
+        <*> pAnyStakeIdentifier
+        <*> many ((,) <$> pAnyStakeIdentifier <*> pTransferAmt)
+        <*> pFileOutDirection "out-file" "Output filepath of the treasury withdrawal."
+
+
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Governance/Actions.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 module Cardano.CLI.EraBased.Run.Governance.Actions
   ( runGovernanceActionCmds
@@ -24,6 +25,7 @@ import           Data.Text.Encoding.Error
 data GovernanceActionsError
   = GovernanceActionsCmdWriteFileError (FileError ())
   | GovernanceActionsCmdReadFileError (FileError InputDecodeError)
+  | GovernanceActionsCmdReadTextEnvelopeFileError (FileError TextEnvelopeError)
   | GovernanceActionsCmdNonUtf8EncodedConstitution UnicodeException
 
 
@@ -34,25 +36,19 @@ runGovernanceActionCmds = \case
   GovernanceActionCreateConstitution cOn newConstitution ->
     runGovernanceActionCreateConstitution cOn newConstitution
 
-  GovernanceActionProtocolParametersUpdate sbe eraBasedProtocolParametersUpdate ofp ->
-    runGovernanceActionCreateProtocolParametersUpdate sbe eraBasedProtocolParametersUpdate ofp
+  GovernanceActionProtocolParametersUpdate sbe eNo genKeys eraBasedProtocolParametersUpdate ofp ->
+    runGovernanceActionCreateProtocolParametersUpdate sbe eNo genKeys eraBasedProtocolParametersUpdate ofp
+
+  GovernanceActionTreasuryWithdrawal cOn treasuryWithdrawal ->
+    runGovernanceActionTreasuryWithdrawal cOn treasuryWithdrawal
 
 runGovernanceActionCreateConstitution :: ()
   => ConwayEraOnwards era
   -> EraBasedNewConstitution
   -> ExceptT GovernanceActionsError IO ()
 runGovernanceActionCreateConstitution cOn (EraBasedNewConstitution deposit anyStake constit outFp) = do
 
-  stakeKeyHash
-    <- case anyStake of
-         AnyStakeKey stake ->
-           firstExceptT GovernanceActionsCmdReadFileError
-             . newExceptT $ readVerificationKeyOrHashOrFile AsStakeKey stake
-
-         AnyStakePoolKey stake -> do
-           StakePoolKeyHash t <- firstExceptT GovernanceActionsCmdReadFileError
-                                   . newExceptT $ readVerificationKeyOrHashOrFile AsStakePoolKey stake
-           return $ StakeKeyHash $ coerceKeyRole t
+  stakeKeyHash <- readStakeKeyHash anyStake
 
   case constit of
     ConstitutionFromFile fp  -> do
@@ -79,16 +75,66 @@ runGovernanceActionCreateConstitution cOn (EraBasedNewConstitution deposit anySt
 
 runGovernanceActionCreateProtocolParametersUpdate :: ()
   => ShelleyBasedEra era
+  -> EpochNo
+  -> [VerificationKeyFile In]
+  -- ^ Genesis verification keys
   -> EraBasedProtocolParametersUpdate era
   -> File () Out
   -> ExceptT GovernanceActionsError IO ()
-runGovernanceActionCreateProtocolParametersUpdate sbe eraBasedPParams oFp = do
+runGovernanceActionCreateProtocolParametersUpdate sbe expEpoch genesisVerKeys eraBasedPParams oFp = do
+  genVKeys <- sequence
+    [ firstExceptT GovernanceActionsCmdReadTextEnvelopeFileError . newExceptT
+        $ readFileTextEnvelope (AsVerificationKey AsGenesisKey) vkeyFile
+    | vkeyFile <- genesisVerKeys
+    ]
+
   let updateProtocolParams = createEraBasedProtocolParamUpdate sbe eraBasedPParams
       apiUpdateProtocolParamsType = fromLedgerPParamsUpdate sbe updateProtocolParams
+      genKeyHashes = fmap verificationKeyHash genVKeys
       -- TODO: Update EraBasedProtocolParametersUpdate to require genesis delegate keys
       -- depending on the era
-      -- TODO: Require expiration epoch no
-      upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType [] (error "runGovernanceActionCreateProtocolParametersUpdate")
+      upProp = makeShelleyUpdateProposal apiUpdateProtocolParamsType genKeyHashes expEpoch
 
   firstExceptT GovernanceActionsCmdWriteFileError . newExceptT
     $ writeLazyByteStringFile oFp $ textEnvelopeToJSON Nothing upProp
+
+readStakeKeyHash :: AnyStakeIdentifier -> ExceptT GovernanceActionsError IO (Hash StakeKey)
+readStakeKeyHash anyStake =
+  case anyStake of
+    AnyStakeKey stake ->
+      firstExceptT GovernanceActionsCmdReadFileError
+        . newExceptT $ readVerificationKeyOrHashOrFile AsStakeKey stake
+
+    AnyStakePoolKey stake -> do
+      StakePoolKeyHash t <- firstExceptT GovernanceActionsCmdReadFileError
+                              . newExceptT $ readVerificationKeyOrHashOrFile AsStakePoolKey stake
+      return $ StakeKeyHash $ coerceKeyRole t
+
+runGovernanceActionTreasuryWithdrawal
+  :: ConwayEraOnwards era
+  -> EraBasedTreasuryWithdrawal
+  -> ExceptT GovernanceActionsError IO ()
+runGovernanceActionTreasuryWithdrawal cOn (EraBasedTreasuryWithdrawal deposit returnAddr treasuryWithdrawal outFp) = do
+  returnKeyHash <- readStakeKeyHash returnAddr
+  withdrawals <- sequence [ (,ll) <$> stakeIdentifiertoCredential stakeIdentifier
+                          | (stakeIdentifier,ll) <- treasuryWithdrawal
+                          ]
+  let sbe = conwayEraOnwardsToShelleyBasedEra cOn
+      proposal = createProposalProcedure sbe deposit returnKeyHash (TreasuryWithdrawal withdrawals)
+
+  firstExceptT GovernanceActionsCmdWriteFileError . newExceptT
+    $ conwayEraOnwardsConstraints cOn
+    $ writeFileTextEnvelope outFp Nothing proposal
+
+stakeIdentifiertoCredential :: AnyStakeIdentifier -> ExceptT GovernanceActionsError IO StakeCredential
+stakeIdentifiertoCredential anyStake =
+  case anyStake of
+    AnyStakeKey stake -> do
+      hash <- firstExceptT GovernanceActionsCmdReadFileError
+                . newExceptT $ readVerificationKeyOrHashOrFile AsStakeKey stake
+      return $ StakeCredentialByKey hash
+    AnyStakePoolKey stake -> do
+      StakePoolKeyHash t <- firstExceptT GovernanceActionsCmdReadFileError
+                              . newExceptT $ readVerificationKeyOrHashOrFile AsStakePoolKey stake
+      -- TODO: Conway era - don't use coerceKeyRole
+      return . StakeCredentialByKey $ StakeKeyHash $ coerceKeyRole t