Add --current-treasury-value and --treasury-donation to transaction b…

…uilding functions

cardano-cli/src/Cardano/CLI/EraBased/Commands/Transaction.hs

@@ -80,6 +80,8 @@ data TransactionBuildRawCmdArgs era = TransactionBuildRawCmdArgs
   , mUpdateProprosalFile  :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
   , voteFiles             :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
   , proposalFiles         :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
+  , currentTreasuryValue  :: !(Maybe TxCurrentTreasuryValue)
+  , treasuryDonation      :: !(Maybe TxTreasuryDonation)
   , txBodyOutFile         :: !(TxBodyFile Out)
   } deriving Show
 
@@ -126,6 +128,7 @@ data TransactionBuildCmdArgs era = TransactionBuildCmdArgs
   , mUpdateProposalFile     :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
   , voteFiles               :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
   , proposalFiles           :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
+  , treasuryDonation        :: !(Maybe TxTreasuryDonation)
   , buildOutputOptions      :: !TxBuildOutputOptions
   } deriving Show
 
@@ -174,6 +177,8 @@ data TransactionBuildEstimateCmdArgs era = TransactionBuildEstimateCmdArgs
   , mUpdateProposalFile      :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
   , voteFiles                :: ![(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
   , proposalFiles            :: ![(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
+  , currentTreasuryValue     :: !(Maybe TxCurrentTreasuryValue)
+  , treasuryDonation         :: !(Maybe TxTreasuryDonation)
   , txBodyOutFile            :: !(TxBodyFile Out)
   }
 

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

@@ -1223,6 +1223,32 @@ pProposalFile balExUnits =
        Nothing
        "a proposal"
 
+pCurrentTreasuryValue :: ShelleyBasedEra era -> Parser (Maybe TxCurrentTreasuryValue)
+pCurrentTreasuryValue =
+  caseShelleyToBabbageOrConwayEraOnwards
+    (const $ pure Nothing)
+    (const $ optional $ TxCurrentTreasuryValue <$> coinParser)
+  where
+    coinParser :: Parser L.Coin =
+      Opt.option (readerFromParsecParser parseLovelace) $ mconcat
+        [ Opt.long "current-treasury-value"
+        , Opt.metavar "LOVELACE"
+        , Opt.help "The current treasury value."
+        ]
+
+pTreasuryDonation :: ShelleyBasedEra era -> Parser (Maybe TxTreasuryDonation)
+pTreasuryDonation =
+  caseShelleyToBabbageOrConwayEraOnwards
+    (const $ pure Nothing)
+    (const $ optional $ TxTreasuryDonation <$> coinParser)
+  where
+    coinParser :: Parser L.Coin =
+      Opt.option (readerFromParsecParser parseLovelace) $ mconcat
+        [ Opt.long "treasury-donation"
+        , Opt.metavar "LOVELACE"
+        , Opt.help "The donation to the treasury to perform."
+        ]
+
 --------------------------------------------------------------------------------
 
 pPaymentVerifier :: Parser PaymentVerifier

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

@@ -183,6 +183,7 @@ pTransactionBuildCmd era envCli = do
           <*> pFeatured (shelleyBasedToCardanoEra sbe) (optional pUpdateProposalFile)
           <*> pVoteFiles sbe AutoBalance
           <*> pProposalFiles sbe AutoBalance
+          <*> pTreasuryDonation sbe
           <*> (OutputTxBodyOnly <$> pTxBodyFileOut <|> pCalculatePlutusScriptCost)
 
 -- | Estimate the transaction fees without access to a live node.
@@ -237,6 +238,8 @@ pTransactionBuildEstimateCmd era _envCli = do
           <*> pFeatured (shelleyBasedToCardanoEra sbe) (optional pUpdateProposalFile)
           <*> pVoteFiles sbe ManualBalance
           <*> pProposalFiles sbe ManualBalance
+          <*> pCurrentTreasuryValue sbe
+          <*> pTreasuryDonation sbe
           <*> pTxBodyFileOut
 
 pChangeAddress :: Parser TxOutChangeAddress
@@ -272,6 +275,8 @@ pTransactionBuildRaw era =
       <*> pFeatured era (optional pUpdateProposalFile)
       <*> pVoteFiles era ManualBalance
       <*> pProposalFiles era ManualBalance
+      <*> pCurrentTreasuryValue era
+      <*> pTreasuryDonation era
       <*> pTxBodyFileOut
 
 pTransactionSign  :: EnvCli -> Parser (TransactionCmds era)

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

@@ -128,6 +128,7 @@ runTransactionBuildCmd
       , mUpdateProposalFile
       , voteFiles
       , proposalFiles
+      , treasuryDonation
       , buildOutputOptions
       } = shelleyBasedEraConstraints eon $ do
   let era = shelleyBasedToCardanoEra eon
@@ -184,18 +185,7 @@ runTransactionBuildCmd
   -- the same collateral input can be used for several plutus scripts
   let filteredTxinsc = Set.toList $ Set.fromList txinsc
 
-  -- We need to construct the txBodycontent outside of runTxBuild
-  BalancedTxBody txBodyContent balancedTxBody _ _ <-
-    runTxBuild
-      eon nodeSocketPath networkId mScriptValidity inputsAndMaybeScriptWits readOnlyReferenceInputs
-      filteredTxinsc mReturnCollateral mTotalCollateral txOuts changeAddresses valuesWithScriptWits
-      mValidityLowerBound mValidityUpperBound certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits
-      requiredSigners txAuxScripts txMetadata mProp mOverrideWitnesses votingProceduresAndMaybeScriptWits
-      proposals buildOutputOptions
-
-  let mScriptWits =
-        forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent
-      allReferenceInputs = getAllReferenceInputs
+  let allReferenceInputs = getAllReferenceInputs
                              inputsAndMaybeScriptWits
                              (snd valuesWithScriptWits)
                              certsAndMaybeScriptWits
@@ -207,6 +197,26 @@ runTransactionBuildCmd
   let inputsThatRequireWitnessing = [input | (input,_) <- inputsAndMaybeScriptWits]
       allTxInputs = inputsThatRequireWitnessing ++ allReferenceInputs ++ filteredTxinsc
 
+  AnyCardanoEra nodeEra <- lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra)
+    & onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
+    & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion)
+
+  (txEraUtxo, _, eraHistory, systemStart, _, _, _, featuredCurrentTreasuryValueM) <-
+    lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip (queryStateForBalancedTx nodeEra allTxInputs []))
+      & onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
+      & onLeft (left . TxCmdQueryConvenienceError)
+
+  -- We need to construct the txBodycontent outside of runTxBuild
+  BalancedTxBody txBodyContent balancedTxBody _ _ <-
+    runTxBuild
+      eon nodeSocketPath networkId mScriptValidity inputsAndMaybeScriptWits readOnlyReferenceInputs
+      filteredTxinsc mReturnCollateral mTotalCollateral txOuts changeAddresses valuesWithScriptWits
+      mValidityLowerBound mValidityUpperBound certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits
+      requiredSigners txAuxScripts txMetadata mProp mOverrideWitnesses votingProceduresAndMaybeScriptWits
+      proposals
+      (unFeatured <$> featuredCurrentTreasuryValueM) treasuryDonation
+      buildOutputOptions
+
   -- TODO: Calculating the script cost should live as a different command.
   -- Why? Because then we can simply read a txbody and figure out
   -- the script cost vs having to build the tx body each time
@@ -217,15 +227,6 @@ runTransactionBuildCmd
       pparams <- pure mTxProtocolParams & onNothing (left TxCmdProtocolParametersNotPresentInTxBody)
       executionUnitPrices <- pure (getExecutionUnitPrices era pparams) & onNothing (left TxCmdPParamExecutionUnitsNotAvailable)
 
-      AnyCardanoEra nodeEra <- lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip queryCurrentEra)
-        & onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
-        & onLeft (left . TxCmdQueryConvenienceError . QceUnsupportedNtcVersion)
-
-      (txEraUtxo, _, eraHistory, systemStart, _, _, _) <-
-        lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip (queryStateForBalancedTx nodeEra allTxInputs []))
-          & onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
-          & onLeft (left . TxCmdQueryConvenienceError)
-
       Refl <- testEquality era nodeEra
         & hoistMaybe (TxCmdTxNodeEraMismatchError $ NodeEraMismatchError era nodeEra)
 
@@ -235,6 +236,8 @@ runTransactionBuildCmd
               systemStart (toLedgerEpochInfo eraHistory)
               pparams txEraUtxo balancedTxBody
 
+      let mScriptWits = forEraInEon era [] $ \sbe -> collectTxBodyScriptWitnesses sbe txBodyContent
+
       scriptCostOutput <-
         firstExceptT TxCmdPlutusScriptCostErr $ hoistEither
           $ renderScriptCosts
@@ -281,6 +284,8 @@ runTransactionBuildEstimateCmd
     , proposalFiles
     , plutusCollateral
     , totalReferenceScriptSize
+    , currentTreasuryValue
+    , treasuryDonation
     , txBodyOutFile
     } = do
   let sbe = maryEraOnwardsToShelleyBasedEra eon
@@ -354,6 +359,8 @@ runTransactionBuildEstimateCmd
                      txUpdateProposal
                      votingProceduresAndMaybeScriptWits
                      proposals
+                     currentTreasuryValue
+                     treasuryDonation
   let stakeCredentialsToDeregisterMap = Map.fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert,_) <- certsAndMaybeScriptWits]
       drepsToDeregisterMap = Map.fromList $ catMaybes [getDRepDeregistrationInfo cert | (cert,_) <- certsAndMaybeScriptWits]
       poolsToDeregister = Set.fromList $ catMaybes [getPoolDeregistrationInfo cert | (cert,_) <- certsAndMaybeScriptWits]
@@ -487,6 +494,8 @@ runTransactionBuildRawCmd
       , voteFiles
       , proposalFiles
       , txBodyOutFile
+      , currentTreasuryValue
+      , treasuryDonation
       } = do
   inputsAndMaybeScriptWits <- firstExceptT TxCmdScriptWitnessError
                                 $ readScriptWitnessFiles eon txIns
@@ -545,6 +554,7 @@ runTransactionBuildRawCmd
       mReturnCollateral mTotalCollateral txOuts mValidityLowerBound mValidityUpperBound fee valuesWithScriptWits
       certsAndMaybeScriptWits withdrawalsAndMaybeScriptWits requiredSigners txAuxScripts
       txMetadata mLedgerPParams txUpdateProposal votingProceduresAndMaybeScriptWits proposals
+      currentTreasuryValue treasuryDonation
 
   let noWitTx = makeSignedTransaction [] txBody
   lift (writeTxFileTextEnvelopeCddl eon txBodyOutFile noWitTx)
@@ -585,6 +595,8 @@ runTxBuildRaw :: ()
   -> TxUpdateProposal era
   -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
   -> [(Proposal era, Maybe (ScriptWitness WitCtxStake era))]
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -> Either TxCmdError (TxBody era)
 runTxBuildRaw sbe
               mScriptValidity inputsAndMaybeScriptWits
@@ -593,12 +605,13 @@ runTxBuildRaw sbe
               mLowerBound mUpperBound
               fee valuesWithScriptWits
               certsAndMaybeSriptWits withdrawals reqSigners
-              txAuxScripts txMetadata mpparams txUpdateProposal votingProcedures proposals = do
+              txAuxScripts txMetadata mpparams txUpdateProposal votingProcedures proposals
+              mCurrentTreasuryValue mTreasuryDonation = do
 
     txBodyContent <- constructTxBodyContent sbe mScriptValidity (unLedgerProtocolParameters <$> mpparams) inputsAndMaybeScriptWits readOnlyRefIns txinsc
                       mReturnCollateral mTotCollateral txouts mLowerBound mUpperBound valuesWithScriptWits
                       certsAndMaybeSriptWits withdrawals reqSigners fee txAuxScripts txMetadata txUpdateProposal
-                      votingProcedures proposals
+                      votingProcedures proposals mCurrentTreasuryValue mTreasuryDonation
 
     first TxCmdTxBodyError $ createAndValidateTransactionBody sbe txBodyContent
 
@@ -637,12 +650,14 @@ constructTxBodyContent
   -> TxUpdateProposal era
   -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
   -> [(Proposal era, Maybe (ScriptWitness WitCtxStake era))]
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -> Either TxCmdError (TxBodyContent BuildTx era)
 constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits readOnlyRefIns txinsc
                        mReturnCollateral mTotCollateral txouts mLowerBound mUpperBound
                        valuesWithScriptWits certsAndMaybeScriptWits withdrawals
                        reqSigners fee txAuxScripts txMetadata txUpdateProposal
-                       votingProcedures proposals
+                       votingProcedures proposals mCurrentTreasuryValue mTreasuryDonation
                        = do
   let allReferenceInputs = getAllReferenceInputs
                              inputsAndMaybeScriptWits
@@ -663,6 +678,8 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea
   validatedMintValue <- createTxMintValue sbe valuesWithScriptWits
   validatedTxScriptValidity <- first TxCmdNotSupportedInEraValidationError $ validateTxScriptValidity sbe mScriptValidity
   validatedVotingProcedures <- first TxCmdTxGovDuplicateVotes $ convertToTxVotingProcedures votingProcedures
+  validatedCurrentTreasuryValue <- first TxCmdNotSupportedInEraValidationError (validateTxCurrentTreasuryValue sbe mCurrentTreasuryValue)
+  validatedTreasuryDonation <- first TxCmdNotSupportedInEraValidationError (validateTxTreasuryDonation sbe mTreasuryDonation)
   return $ shelleyBasedEraConstraints sbe $ (defaultTxBodyContent sbe
              & setTxIns (validateTxIns inputsAndMaybeScriptWits)
              & setTxInsCollateral validatedCollateralTxIns
@@ -686,6 +703,8 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea
              { txProposalProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` convToTxProposalProcedures proposals)
              , txVotingProcedures = forShelleyBasedEraInEonMaybe sbe (`Featured` validatedVotingProcedures)
              }
+             & setTxCurrentTreasuryValue validatedCurrentTreasuryValue
+             & setTxTreasuryDonation validatedTreasuryDonation
  where
   convertWithdrawals
     :: (StakeAddress, L.Coin, Maybe (ScriptWitness WitCtxStake era))
@@ -732,14 +751,18 @@ runTxBuild :: ()
   -> Maybe Word
   -> [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))]
   -> [(Proposal era, Maybe (ScriptWitness WitCtxStake era))]
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -> TxBuildOutputOptions
   -> ExceptT TxCmdError IO (BalancedTxBody era)
 runTxBuild
     sbe socketPath networkId mScriptValidity
     inputsAndMaybeScriptWits readOnlyRefIns txinsc mReturnCollateral mTotCollateral txouts
     (TxOutChangeAddress changeAddr) valuesWithScriptWits mLowerBound mUpperBound
     certsAndMaybeScriptWits withdrawals reqSigners txAuxScripts txMetadata
-    txUpdateProposal mOverrideWits votingProcedures proposals _outputOptions = shelleyBasedEraConstraints sbe $ do
+    txUpdateProposal mOverrideWits votingProcedures proposals
+    mCurrentTreasuryValue mTreasuryDonation
+    _outputOptions = shelleyBasedEraConstraints sbe $ do
 
   -- TODO: All functions should be parameterized by ShelleyBasedEra
   -- as it's not possible to call this function with ByronEra
@@ -775,7 +798,7 @@ runTxBuild
           TxCertificates _ cs _ -> cs
           _ -> []
 
-  (txEraUtxo, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits) <-
+  (txEraUtxo, pparams, eraHistory, systemStart, stakePools, stakeDelegDeposits, drepDelegDeposits, _) <-
     lift (executeLocalStateQueryExpr localNodeConnInfo Consensus.VolatileTip $ queryStateForBalancedTx nodeEra allTxInputs certs)
       & onLeft (left . TxCmdQueryConvenienceError . AcqFailure)
       & onLeft (left . TxCmdQueryConvenienceError)
@@ -800,6 +823,7 @@ runTxBuild
                      txMetadata
                      txUpdateProposal
                      votingProcedures proposals
+                     mCurrentTreasuryValue mTreasuryDonation
 
   firstExceptT TxCmdTxInsDoNotExist
     . hoistEither $ txInsExistInUTxO allTxInputs txEraUtxo

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

@@ -93,6 +93,7 @@ data LegacyTransactionCmds
       (Maybe UpdateProposalFile)
       [(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
       [(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
+      (Maybe TxTreasuryDonation)
       TxBuildOutputOptions
   | TransactionSignCmd
       InputTxBodyOrTxFile

cardano-cli/src/Cardano/CLI/Legacy/Options.hs

@@ -339,6 +339,7 @@ pTransaction envCli =
       <*> optional pUpdateProposalFile
       <*> pVoteFiles ShelleyBasedEraConway AutoBalance
       <*> pProposalFiles ShelleyBasedEraConway AutoBalance
+      <*> pTreasuryDonation ShelleyBasedEraConway
       <*> (OutputTxBodyOnly <$> pTxBodyFileOut <|> pCalculatePlutusScriptCost)
 
   pChangeAddress :: Parser TxOutChangeAddress

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

@@ -29,11 +29,11 @@ runLegacyTransactionCmds = \case
   TransactionBuildCmd mNodeSocketPath era consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns
             reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound
             mUpperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpProp mconwayVote
-            mNewConstitution outputOptions -> do
+            mNewConstitution mTreasuryDonation outputOptions -> do
       runLegacyTransactionBuildCmd mNodeSocketPath era consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns
             reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound
             mUpperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpProp mconwayVote
-            mNewConstitution outputOptions
+            mNewConstitution mTreasuryDonation outputOptions
   TransactionBuildRawCmd era mScriptValidity txins readOnlyRefIns txinsc mReturnColl
                mTotColl reqSigners txouts mValue mLowBound mUpperBound fee certs wdrls
                metadataSchema scriptFiles metadataFiles mProtocolParamsFile mUpProp out -> do
@@ -91,14 +91,17 @@ runLegacyTransactionBuildCmd :: ()
   -> Maybe UpdateProposalFile
   -> [(VoteFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
   -> [(ProposalFile In, Maybe (ScriptWitnessFiles WitCtxStake))]
+  -> Maybe TxTreasuryDonation
   -> TxBuildOutputOptions
   -> ExceptT TxCmdError IO ()
 runLegacyTransactionBuildCmd
     socketPath (EraInEon sbe)
     consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns
     reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound
     mUpperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpdateProposal voteFiles
-    proposalFiles outputOptions = do
+    proposalFiles
+    mTreasuryDonation
+    outputOptions = do
 
   mUpdateProposalFile <-
     validateUpdateProposalFile (shelleyBasedToCardanoEra sbe) mUpdateProposal
@@ -112,7 +115,7 @@ runLegacyTransactionBuildCmd
         consensusModeParams nid mScriptValidity mOverrideWits txins readOnlyRefIns
         reqSigners txinsc mReturnColl mTotCollateral txouts changeAddr mValue mLowBound
         upperBound certs wdrls metadataSchema scriptFiles metadataFiles mUpdateProposalFile voteFiles
-        proposalFiles outputOptions
+        proposalFiles mTreasuryDonation outputOptions
     )
 
 -- TODO: Neither QA nor Sam is using `cardano-cli byron transaction build-raw`
@@ -178,6 +181,7 @@ runLegacyTransactionBuildRawCmd
              sbe mScriptValidity txins readOnlyRefIns txinsc mReturnColl
              mTotColl reqSigners txouts mValue mLowBound upperBound (fromMaybe 0 fee) certs wdrls
              metadataSchema scriptFiles metadataFiles mProtocolParamsFile mUpdateProposalFile [] []
+             Nothing Nothing
              outFile
          )
          )

cardano-cli/src/Cardano/CLI/Types/Common.hs

@@ -66,6 +66,7 @@ module Cardano.CLI.Types.Common
   , TxBuildOutputOptions(..)
   , TxByronWitnessCount(..)
   , TxFile
+  , TxTreasuryDonation(..)
   , TxInCount(..)
   , TxMempoolQuery (..)
   , TxOutAnyEra (..)
@@ -468,6 +469,9 @@ type TxBodyFile = File (TxBody ())
 
 type TxFile = File (Tx ())
 
+newtype TxTreasuryDonation = TxTreasuryDonation { unTxTreasuryDonation :: L.Coin }
+  deriving Show
+
 data TxMempoolQuery =
       TxMempoolQueryTxExists TxId
     | TxMempoolQueryNextTx