Merge pull request #778 from IntersectMBO/smelc/treasury-donations

Add --current-treasury-value and --treasury-donation to transaction build and friends

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
@@ -1318,14 +1344,18 @@ pProtocolParamsFile =
     , Opt.completer (Opt.bashCompleter "file")
     ]
 
-pCalculatePlutusScriptCost :: Parser TxBuildOutputOptions
-pCalculatePlutusScriptCost =
-  OutputScriptCostOnly <$> Opt.strOption
-   ( Opt.long "calculate-plutus-script-cost" <>
-     Opt.metavar "FILE" <>
-     Opt.help "(File () Out) filepath of the script cost information." <>
-     Opt.completer (Opt.bashCompleter "file")
-   )
+pTxBuildOutputOptions :: Parser TxBuildOutputOptions
+pTxBuildOutputOptions =
+  (OutputTxBodyOnly <$> pTxBodyFileOut) <|> pCalculatePlutusScriptCost
+  where
+    pCalculatePlutusScriptCost :: Parser TxBuildOutputOptions
+    pCalculatePlutusScriptCost =
+      OutputScriptCostOnly <$> Opt.strOption
+       ( Opt.long "calculate-plutus-script-cost" <>
+         Opt.metavar "FILE" <>
+         Opt.help "(File () Out) filepath of the script cost information." <>
+         Opt.completer (Opt.bashCompleter "file")
+       )
 
 pCertificateFile
   :: BalanceTxExecUnits

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

@@ -183,7 +183,8 @@ pTransactionBuildCmd era envCli = do
           <*> pFeatured (shelleyBasedToCardanoEra sbe) (optional pUpdateProposalFile)
           <*> pVoteFiles sbe AutoBalance
           <*> pProposalFiles sbe AutoBalance
-          <*> (OutputTxBodyOnly <$> pTxBodyFileOut <|> pCalculatePlutusScriptCost)
+          <*> pTreasuryDonation sbe
+          <*> pTxBuildOutputOptions
 
 -- | Estimate the transaction fees without access to a live node.
 pTransactionBuildEstimateCmd :: MaryEraOnwards era -> EnvCli -> Maybe (Parser (TransactionCmds era))
@@ -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
@@ -655,14 +670,16 @@ constructTxBodyContent sbe mScriptValidity mPparams inputsAndMaybeScriptWits rea
 
   validatedCollateralTxIns <- validateTxInsCollateral sbe txinsc
   validatedRefInputs <- validateTxInsReference sbe allReferenceInputs
-  validatedTotCollateral <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxTotalCollateral sbe mTotCollateral
-  validatedRetCol        <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral
+  validatedTotCollateral <- first TxCmdNotSupportedInEraValidationError $ validateTxTotalCollateral sbe mTotCollateral
+  validatedRetCol        <- first TxCmdNotSupportedInEraValidationError $ validateTxReturnCollateral sbe mReturnCollateral
   let txFee = TxFeeExplicit sbe fee
-  validatedLowerBound <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxValidityLowerBound sbe mLowerBound
-  validatedReqSigners <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateRequiredSigners sbe reqSigners
+  validatedLowerBound <- first TxCmdNotSupportedInEraValidationError $ validateTxValidityLowerBound sbe mLowerBound
+  validatedReqSigners <- first TxCmdNotSupportedInEraValidationError $ validateRequiredSigners sbe reqSigners
   validatedMintValue <- createTxMintValue sbe valuesWithScriptWits
-  validatedTxScriptValidity <- first TxCmdNotSupportedInAnyCardanoEraValidationError $ validateTxScriptValidity sbe mScriptValidity
+  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
@@ -800,6 +823,7 @@ runTxBuild
                      txMetadata
                      txUpdateProposal
                      votingProcedures proposals
+                     mCurrentTreasuryValue mTreasuryDonation
 
   firstExceptT TxCmdTxInsDoNotExist
     . hoistEither $ txInsExistInUTxO allTxInputs txEraUtxo

cardano-cli/src/Cardano/CLI/Json/Friendly.hs

@@ -189,8 +189,8 @@ friendlyTxBodyImpl
          _txScriptValidity
          txProposalProcedures
          txVotingProcedures
-         _txCurrentTreasuryValue
-         _txTreasuryDonation)) =
+         txCurrentTreasuryValue
+         txTreasuryDonation)) =
   do redeemerDetails <- redeemerIfShelleyBased era tb
      return $ cardanoEraConstraints era
                 ( redeemerDetails ++
@@ -231,6 +231,8 @@ friendlyTxBodyImpl
                              Just (Featured _ (TxVotingProcedures votes _witnesses)) ->
                                friendlyVotingProcedures cOnwards votes)
                         era)
+                  , "currentTreasuryValue" .= toJSON (unFeatured <$> txCurrentTreasuryValue)
+                  , "treasuryDonation" .= toJSON (unFeatured <$> txTreasuryDonation)
                   ])
   where
     friendlyLedgerProposals :: ConwayEraOnwards era -> [L.ProposalProcedure (ShelleyLedgerEra era)] -> Aeson.Value

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