Merge pull request #1322 from IntersectMBO/1149-remove-requirement-of-current-treasury-withdrawal-for-transaction-in-build-raw-command

Remove requirement of "current treasury value" for transactions

Author: palas

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

@@ -24,6 +24,7 @@ import Cardano.CLI.EraBased.Script.Type
 import Cardano.CLI.EraBased.Script.Type qualified as PlutusSpend
 import Cardano.CLI.EraBased.Script.Vote.Type qualified as Voting
 import Cardano.CLI.EraBased.Script.Withdrawal.Type qualified as Withdrawal
+import Cardano.CLI.EraBased.Transaction.Command (IncludeCurrentTreasuryValue (..))
 import Cardano.CLI.Option.Flag
 import Cardano.CLI.Option.Flag.Type qualified as Z
 import Cardano.CLI.Orphan ()
@@ -1191,21 +1192,30 @@ pProposalReferencePlutusScriptWitness prefix autoBalanceExecUnits =
                 ManualBalance -> pExecutionUnits $ appendedPrefix ++ "reference-tx-in"
             )
 
-pCurrentTreasuryValueAndDonation
-  :: Parser (Maybe (TxCurrentTreasuryValue, TxTreasuryDonation))
-pCurrentTreasuryValueAndDonation =
-  optional ((,) <$> pCurrentTreasuryValue' <*> pTreasuryDonation')
+pCurrentTreasuryValue :: Parser (Maybe TxCurrentTreasuryValue)
+pCurrentTreasuryValue =
+  optional $
+    TxCurrentTreasuryValue
+      <$> ( Opt.option (readerFromParsecParser parseLovelace) $
+              mconcat
+                [ Opt.long "current-treasury-value"
+                , Opt.metavar "LOVELACE"
+                , Opt.help "The current treasury value."
+                ]
+          )
 
-pCurrentTreasuryValue' :: Parser TxCurrentTreasuryValue
-pCurrentTreasuryValue' =
-  TxCurrentTreasuryValue
-    <$> ( Opt.option (readerFromParsecParser parseLovelace) $
-            mconcat
-              [ Opt.long "current-treasury-value"
-              , Opt.metavar "LOVELACE"
-              , Opt.help "The current treasury value."
-              ]
-        )
+pIncludeCurrentTreasuryValue :: Parser IncludeCurrentTreasuryValue
+pIncludeCurrentTreasuryValue =
+  asum
+    [ Opt.flag' IncludeCurrentTreasuryValue $
+        mconcat
+          [ Opt.long "current-treasury-value"
+          , Opt.help
+              "Include the current treasury value in the transaction. \
+              \The value is obtained from the node."
+          ]
+    , pure ExcludeCurrentTreasuryValue
+    ]
 
 pTreasuryDonation :: Parser (Maybe TxTreasuryDonation)
 pTreasuryDonation =

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

@@ -24,6 +24,7 @@ module Cardano.CLI.EraBased.Transaction.Command
   , TransactionViewCmdArgs (..)
   , TransactionWitnessCmdArgs (..)
   , TxCborFormat (..)
+  , IncludeCurrentTreasuryValue (..)
   , renderTransactionCmds
   )
 where
@@ -91,7 +92,8 @@ data TransactionBuildRawCmdArgs era = TransactionBuildRawCmdArgs
   , mUpdateProprosalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
   , voteFiles :: ![(VoteFile In, Maybe (ScriptRequirements Exp.VoterItem))]
   , proposalFiles :: ![(ProposalFile In, Maybe (ScriptRequirements Exp.ProposalItem))]
-  , currentTreasuryValueAndDonation :: !(Maybe (TxCurrentTreasuryValue, TxTreasuryDonation))
+  , mCurrentTreasuryValue :: !(Maybe TxCurrentTreasuryValue)
+  , mTreasuryDonation :: !(Maybe TxTreasuryDonation)
   , isCborOutCanonical :: !TxCborFormat
   , txBodyOutFile :: !(TxBodyFile Out)
   }
@@ -106,6 +108,22 @@ data TxCborFormat
   | TxCborNotCanonical
   deriving (Eq, Show)
 
+-- | Whether to include the current treasury value in the transaction body.
+--
+-- If included, the current treasury value will be obtained from the node.
+--
+-- The current treasury value serves as a precondition to executing Plutus
+-- scripts that access the value of the treasury.
+--
+-- See: https://intersectmbo.github.io/formal-ledger-specifications/site/Ledger.Conway.Specification.Transaction.html#sec:transactions
+--
+-- If a transaction contains any votes, proposals, a treasury donation or
+-- asserts the treasury amount, it is only allowed to contain Plutus V3 scripts.
+--
+-- See: https://intersectmbo.github.io/formal-ledger-specifications/site/Ledger.Conway.Specification.Utxow.html#sec:witnessing-functions
+data IncludeCurrentTreasuryValue = IncludeCurrentTreasuryValue | ExcludeCurrentTreasuryValue
+  deriving (Eq, Show)
+
 -- | Like 'TransactionBuildRaw' but without the fee, and with a change output.
 data TransactionBuildCmdArgs era = TransactionBuildCmdArgs
   { currentEra :: !(Exp.Era era)
@@ -147,7 +165,8 @@ data TransactionBuildCmdArgs era = TransactionBuildCmdArgs
   , mUpdateProposalFile :: !(Maybe (Featured ShelleyToBabbageEra era (Maybe UpdateProposalFile)))
   , voteFiles :: ![(VoteFile In, Maybe (ScriptRequirements Exp.VoterItem))]
   , proposalFiles :: ![(ProposalFile In, Maybe (ScriptRequirements Exp.ProposalItem))]
-  , treasuryDonation :: !(Maybe TxTreasuryDonation)
+  , includeCurrentTreasuryValue :: !IncludeCurrentTreasuryValue
+  , mTreasuryDonation :: !(Maybe TxTreasuryDonation)
   , isCborOutCanonical :: !TxCborFormat
   , buildOutputOptions :: !TxBuildOutputOptions
   }
@@ -197,7 +216,8 @@ data TransactionBuildEstimateCmdArgs era = TransactionBuildEstimateCmdArgs
   , metadataFiles :: ![MetadataFile]
   , voteFiles :: ![(VoteFile In, Maybe (ScriptRequirements Exp.VoterItem))]
   , proposalFiles :: ![(ProposalFile In, Maybe (ScriptRequirements Exp.ProposalItem))]
-  , currentTreasuryValueAndDonation :: !(Maybe (TxCurrentTreasuryValue, TxTreasuryDonation))
+  , currentTreasuryValue :: !(Maybe TxCurrentTreasuryValue)
+  , treasuryDonation :: !(Maybe TxTreasuryDonation)
   , isCborOutCanonical :: !TxCborFormat
   , txBodyOutFile :: !(TxBodyFile Out)
   }

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

@@ -222,6 +222,7 @@ pTransactionBuildCmd envCli = do
         <*> pFeatured era' (optional pUpdateProposalFile)
         <*> pVoteFiles AutoBalance
         <*> pProposalFiles AutoBalance
+        <*> pIncludeCurrentTreasuryValue
         <*> pTreasuryDonation
         <*> pIsCborOutCanonical
         <*> pTxBuildOutputOptions
@@ -285,7 +286,8 @@ pTransactionBuildEstimateCmd _envCli = do
         <*> many pMetadataFile
         <*> pVoteFiles ManualBalance
         <*> pProposalFiles ManualBalance
-        <*> pCurrentTreasuryValueAndDonation
+        <*> pCurrentTreasuryValue
+        <*> pTreasuryDonation
         <*> pIsCborOutCanonical
         <*> pTxBodyFileOut
 
@@ -324,7 +326,8 @@ pTransactionBuildRaw =
       <*> pFeatured Exp.useEra (optional pUpdateProposalFile)
       <*> pVoteFiles ManualBalance
       <*> pProposalFiles ManualBalance
-      <*> pCurrentTreasuryValueAndDonation
+      <*> pCurrentTreasuryValue
+      <*> pTreasuryDonation
       <*> pIsCborOutCanonical
       <*> pTxBodyFileOut
 

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

@@ -156,7 +156,8 @@ runTransactionBuildCmd
     , mUpdateProposalFile
     , voteFiles
     , proposalFiles
-    , treasuryDonation -- Maybe TxTreasuryDonation
+    , includeCurrentTreasuryValue
+    , mTreasuryDonation
     , isCborOutCanonical
     , buildOutputOptions
     } = do
@@ -290,11 +291,9 @@ runTransactionBuildCmd
         )
         & fromEitherCIOCli
 
-    let currentTreasuryValueAndDonation =
-          case (treasuryDonation, unFeatured <$> featuredCurrentTreasuryValueM) of
-            (Nothing, _) -> Nothing -- We shouldn't specify the treasury value when no donation is being done
-            (Just _td, Nothing) -> Nothing -- TODO: Current treasury value couldn't be obtained but is required: we should fail suggesting that the node's version is too old
-            (Just td, Just ctv) -> Just (ctv, td)
+    let mCurrenTreasuryValue = case includeCurrentTreasuryValue of
+          IncludeCurrentTreasuryValue -> unFeatured <$> featuredCurrentTreasuryValueM
+          ExcludeCurrentTreasuryValue -> Nothing
 
     -- We need to construct the txBodycontent outside of runTxBuild
     (balancedTxBody@(Exp.UnsignedTx tx), txBodyContent) <-
@@ -322,7 +321,8 @@ runTransactionBuildCmd
           mOverrideWitnesses
           votingProceduresAndMaybeScriptWits
           proposals
-          currentTreasuryValueAndDonation
+          mCurrenTreasuryValue
+          mTreasuryDonation
           supplementalDatums
 
     -- TODO: Calculating the script cost should live as a different command.
@@ -415,7 +415,8 @@ runTransactionBuildEstimateCmd -- TODO change type
     , proposalFiles
     , plutusCollateral
     , totalReferenceScriptSize
-    , currentTreasuryValueAndDonation
+    , currentTreasuryValue
+    , treasuryDonation
     , isCborOutCanonical
     , txBodyOutFile
     } = do
@@ -504,7 +505,8 @@ runTransactionBuildEstimateCmd -- TODO change type
           txMetadata
           votingProceduresAndMaybeScriptWits
           proposals
-          currentTreasuryValueAndDonation
+          currentTreasuryValue
+          treasuryDonation
           supplementalDatums
 
     let stakeCredentialsToDeregisterMap = fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits]
@@ -621,7 +623,8 @@ runTransactionBuildRawCmd
     , mUpdateProprosalFile
     , voteFiles
     , proposalFiles
-    , currentTreasuryValueAndDonation
+    , mCurrentTreasuryValue
+    , mTreasuryDonation
     , isCborOutCanonical
     , txBodyOutFile
     } = Exp.obtainCommonConstraints eon $ do
@@ -711,7 +714,8 @@ runTransactionBuildRawCmd
           mLedgerPParams
           votingProceduresAndMaybeScriptWits
           proposals
-          currentTreasuryValueAndDonation
+          mCurrentTreasuryValue
+          mTreasuryDonation
           supplementalDatums
     let Exp.UnsignedTx lTx = txBody
         noWitTx = ShelleyTx (convert eon) lTx
@@ -753,7 +757,8 @@ runTxBuildRaw
   -> Maybe (LedgerProtocolParameters era)
   -> [(VotingProcedures era, Exp.AnyWitness (Exp.LedgerEra era))]
   -> [(Proposal era, Exp.AnyWitness (Exp.LedgerEra era))]
-  -> Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -> Map.Map DataHash (L.Data (Exp.LedgerEra era))
   -- ^ Supplemental datums
   -> Either TxCmdError (Exp.UnsignedTx (Exp.LedgerEra era))
@@ -777,7 +782,8 @@ runTxBuildRaw
   mpparams
   votingProcedures
   proposals
-  mCurrentTreasuryValueAndDonation
+  mCurrentTreasury
+  mTreasuryDonation
   suppDatums = do
     txBodyContent <-
       constructTxBodyContent
@@ -800,7 +806,8 @@ runTxBuildRaw
         txMetadata
         votingProcedures
         proposals
-        mCurrentTreasuryValueAndDonation
+        mCurrentTreasury
+        mTreasuryDonation
         suppDatums
 
     return $ Exp.makeUnsignedTx Exp.useEra txBodyContent
@@ -840,7 +847,8 @@ constructTxBodyContent
   -> TxMetadataInEra era
   -> [(VotingProcedures era, Exp.AnyWitness (Exp.LedgerEra era))]
   -> [(Proposal era, Exp.AnyWitness (Exp.LedgerEra era))]
-  -> Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -- ^ The current treasury value and the donation. This is a stop gap as the
   -- semantics of the donation and treasury value depend on the script languages
   -- being used.
@@ -867,7 +875,8 @@ constructTxBodyContent
   txMetadata
   votingProcedures
   proposals
-  mCurrentTreasuryValueAndDonation
+  mCurrentTreasury
+  mTreasuryDonation
   suppDatums =
     do
       let allReferenceInputs =
@@ -905,8 +914,8 @@ constructTxBodyContent
       let txProposals = [(obtainCommonConstraints (Exp.useEra @era) p, w) | (Proposal p, w) <- proposals]
       let validatedTxProposals =
             Exp.mkTxProposalProcedures txProposals
-      let validatedCurrentTreasuryValue = unTxCurrentTreasuryValue . fst <$> mCurrentTreasuryValueAndDonation
-          validatedTreasuryDonation = unTxTreasuryDonation . snd <$> mCurrentTreasuryValueAndDonation
+      let validatedCurrentTreasuryValue = unTxCurrentTreasuryValue <$> mCurrentTreasury
+          validatedTreasuryDonation = unTxTreasuryDonation <$> mTreasuryDonation
       let validatedWithdrawals = convertWithdrawals withdrawals
       return
         ( Exp.defaultTxBodyContent
@@ -997,7 +1006,8 @@ runTxBuild
   -> Maybe Word
   -> [(VotingProcedures era, Exp.AnyWitness (Exp.LedgerEra era))]
   -> [(Proposal era, Exp.AnyWitness (Exp.LedgerEra era))]
-  -> Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -- ^ The current treasury value and the donation.
   -> Map.Map DataHash (L.Data (Exp.LedgerEra era))
   -- ^ Supplemental datums
@@ -1025,7 +1035,8 @@ runTxBuild
   mOverrideWits
   votingProcedures
   proposals
-  mCurrentTreasuryValueAndDonation
+  mCurrentTreasury
+  mTreasuryDonation
   suppDatums = do
     let sbe = convert (Exp.useEra @era)
     shelleyBasedEraConstraints sbe $ do
@@ -1091,7 +1102,8 @@ runTxBuild
             txMetadata
             votingProcedures
             proposals
-            mCurrentTreasuryValueAndDonation
+            mCurrentTreasury
+            mTreasuryDonation
             suppDatums
 
       firstExceptT TxCmdTxInsDoNotExist