Remove requirement of donation for "current treasury value"

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 ()
@@ -1190,10 +1191,9 @@ pProposalReferencePlutusScriptWitness prefix autoBalanceExecUnits =
                 ManualBalance -> pExecutionUnits $ appendedPrefix ++ "reference-tx-in"
             )
 
-pCurrentTreasuryValueAndDonation
-  :: Parser (Maybe (Maybe TxCurrentTreasuryValue, TxTreasuryDonation))
-pCurrentTreasuryValueAndDonation =
-  optional ((,) <$> optional pCurrentTreasuryValue' <*> pTreasuryDonation')
+pCurrentTreasuryValue :: Parser (Maybe TxCurrentTreasuryValue)
+pCurrentTreasuryValue =
+  optional pCurrentTreasuryValue'
 
 pCurrentTreasuryValue' :: Parser TxCurrentTreasuryValue
 pCurrentTreasuryValue' =
@@ -1206,6 +1206,17 @@ pCurrentTreasuryValue' =
               ]
         )
 
+pIncludeCurrentTreasuryValue :: Parser IncludeCurrentTreasuryValue
+pIncludeCurrentTreasuryValue =
+  asum
+    [ Opt.flag' IncludeCurrentTreasuryValue $
+        mconcat
+          [ Opt.long "include-current-treasury-value"
+          , Opt.help "Include the current treasury value in the transaction."
+          ]
+    , pure ExcludeCurrentTreasuryValue
+    ]
+
 pTreasuryDonation :: Parser (Maybe TxTreasuryDonation)
 pTreasuryDonation =
   optional 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
@@ -92,7 +93,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 (Maybe TxCurrentTreasuryValue, TxTreasuryDonation))
+  , mCurrentTreasuryValue :: !(Maybe TxCurrentTreasuryValue)
+  , mTreasuryDonation :: !(Maybe TxTreasuryDonation)
   , isCborOutCanonical :: !TxCborFormat
   , txBodyOutFile :: !(TxBodyFile Out)
   }
@@ -107,6 +109,9 @@ data TxCborFormat
   | TxCborNotCanonical
   deriving (Eq, Show)
 
+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)
@@ -148,7 +153,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
   }
@@ -198,7 +204,8 @@ data TransactionBuildEstimateCmdArgs era = TransactionBuildEstimateCmdArgs
   , metadataFiles :: ![MetadataFile]
   , voteFiles :: ![(VoteFile In, Maybe (ScriptRequirements Exp.VoterItem))]
   , proposalFiles :: ![(ProposalFile In, Maybe (ScriptRequirements Exp.ProposalItem))]
-  , currentTreasuryValueAndDonation :: !(Maybe (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

@@ -157,7 +157,8 @@ runTransactionBuildCmd
     , mUpdateProposalFile
     , voteFiles
     , proposalFiles
-    , treasuryDonation -- Maybe TxTreasuryDonation
+    , includeCurrentTreasuryValue
+    , mTreasuryDonation
     , isCborOutCanonical
     , buildOutputOptions
     } = do
@@ -288,14 +289,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, mctv) -> Just (mctv, td) -- Current treasury value is not mandatory for donations, see:
-            -- \* https://intersectmbo.github.io/formal-ledger-specifications/site/Ledger.Conway.Specification.Utxo.html#sec:the-utxo-transition-system
-            -- \* https://intersectmbo.github.io/formal-ledger-specifications/site/Notation.html#the-maybe-type
-            -- And discussion:
-            -- \* https://discord.com/channels/1136727663583698984/1239888777015590913/1364244737602879498
+    let mCurrenTreasuryValue = case includeCurrentTreasuryValue of
+          IncludeCurrentTreasuryValue -> unFeatured <$> featuredCurrentTreasuryValueM
+          ExcludeCurrentTreasuryValue -> Nothing
 
     -- We need to construct the txBodycontent outside of runTxBuild
     BalancedTxBody txBodyContent balancedTxBody _ _ <-
@@ -323,7 +319,8 @@ runTransactionBuildCmd
           mOverrideWitnesses
           votingProceduresAndMaybeScriptWits
           proposals
-          currentTreasuryValueAndDonation
+          mCurrenTreasuryValue
+          mTreasuryDonation
 
     -- TODO: Calculating the script cost should live as a different command.
     -- Why? Because then we can simply read a txbody and figure out
@@ -410,7 +407,8 @@ runTransactionBuildEstimateCmd -- TODO change type
     , proposalFiles
     , plutusCollateral
     , totalReferenceScriptSize
-    , currentTreasuryValueAndDonation
+    , currentTreasuryValue
+    , treasuryDonation
     , isCborOutCanonical
     , txBodyOutFile
     } = do
@@ -497,7 +495,8 @@ runTransactionBuildEstimateCmd -- TODO change type
           TxUpdateProposalNone
           votingProceduresAndMaybeScriptWits
           proposals
-          currentTreasuryValueAndDonation
+          currentTreasuryValue
+          treasuryDonation
     let stakeCredentialsToDeregisterMap = fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits]
         drepsToDeregisterMap =
           fromList $
@@ -615,7 +614,8 @@ runTransactionBuildRawCmd
     , mUpdateProprosalFile
     , voteFiles
     , proposalFiles
-    , currentTreasuryValueAndDonation
+    , mCurrentTreasuryValue
+    , mTreasuryDonation
     , isCborOutCanonical
     , txBodyOutFile
     } = Exp.obtainCommonConstraints eon $ do
@@ -701,7 +701,8 @@ runTransactionBuildRawCmd
           txUpdateProposal
           votingProceduresAndMaybeScriptWits
           proposals
-          currentTreasuryValueAndDonation
+          mCurrentTreasuryValue
+          mTreasuryDonation
 
     let Exp.SignedTx tx = Exp.signTx eon [] [] txBody
         -- TODO: Create equivalent write text envelope functions for
@@ -746,7 +747,8 @@ runTxBuildRaw
   -> TxUpdateProposal era
   -> [(VotingProcedures era, Maybe (VoteScriptWitness era))]
   -> [(Proposal era, Maybe (ProposalScriptWitness era))]
-  -> Maybe (Maybe TxCurrentTreasuryValue, TxTreasuryDonation)
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -> Either TxCmdError (Exp.UnsignedTx era)
 runTxBuildRaw
   mScriptValidity
@@ -769,7 +771,8 @@ runTxBuildRaw
   txUpdateProposal
   votingProcedures
   proposals
-  mCurrentTreasuryValueAndDonation = do
+  mCurrentTreasuryValue
+  mTreasuryDonation = do
     txBodyContent <-
       constructTxBodyContent
         mScriptValidity
@@ -792,7 +795,8 @@ runTxBuildRaw
         txUpdateProposal
         votingProcedures
         proposals
-        mCurrentTreasuryValueAndDonation
+        mCurrentTreasuryValue
+        mTreasuryDonation
 
     first TxCmdTxBodyError $ Exp.makeUnsignedTx Exp.useEra txBodyContent
 
@@ -832,7 +836,8 @@ constructTxBodyContent
   -> TxUpdateProposal era
   -> [(VotingProcedures era, Maybe (VoteScriptWitness era))]
   -> [(Proposal era, Maybe (ProposalScriptWitness era))]
-  -> Maybe (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.
@@ -858,7 +863,8 @@ constructTxBodyContent
   txUpdateProposal
   votingProcedures
   proposals
-  mCurrentTreasuryValueAndDonation =
+  mCurrentTreasuryValue
+  mTreasuryDonation =
     do
       let sbe = convert $ Exp.useEra @era
       let allReferenceInputs =
@@ -894,8 +900,8 @@ constructTxBodyContent
                       [(prop, pswScriptWitness <$> mSwit) | (Proposal prop, mSwit) <- proposals]
             Featured w txp
 
-      let validatedCurrentTreasuryValue = validateTxCurrentTreasuryValue @era (fst =<< mCurrentTreasuryValueAndDonation)
-          validatedTreasuryDonation = validateTxTreasuryDonation @era (snd <$> mCurrentTreasuryValueAndDonation)
+      let validatedCurrentTreasuryValue = validateTxCurrentTreasuryValue @era mCurrentTreasuryValue
+          validatedTreasuryDonation = validateTxTreasuryDonation @era mTreasuryDonation
       return $
         shelleyBasedEraConstraints
           sbe
@@ -972,7 +978,8 @@ runTxBuild
   -> Maybe Word
   -> [(VotingProcedures era, Maybe (VoteScriptWitness era))]
   -> [(Proposal era, Maybe (ProposalScriptWitness era))]
-  -> Maybe (Maybe TxCurrentTreasuryValue, TxTreasuryDonation)
+  -> Maybe TxCurrentTreasuryValue
+  -> Maybe TxTreasuryDonation
   -- ^ The current treasury value and the donation.
   -> ExceptT TxCmdError IO (BalancedTxBody era)
 runTxBuild
@@ -998,7 +1005,8 @@ runTxBuild
   mOverrideWits
   votingProcedures
   proposals
-  mCurrentTreasuryValueAndDonation = do
+  mCurrentTreasuryValue
+  mTreasuryDonation = do
     let sbe = convert (Exp.useEra @era)
     shelleyBasedEraConstraints sbe $ do
       -- TODO: All functions should be parameterized by ShelleyBasedEra
@@ -1065,7 +1073,8 @@ runTxBuild
             txUpdateProposal
             votingProcedures
             proposals
-            mCurrentTreasuryValueAndDonation
+            mCurrentTreasuryValue
+            mTreasuryDonation
 
       firstExceptT TxCmdTxInsDoNotExist
         . hoistEither

cardano-cli/test/cardano-cli-golden/Test/Golden/Conway/Transaction/BuildRaw.hs

@@ -3,13 +3,10 @@
 module Test.Golden.Conway.Transaction.BuildRaw where
 
 import Control.Monad (void)
-import Data.List (isInfixOf)
-import System.Exit (ExitCode (..))
 
 import Test.Cardano.CLI.Util
 
 import Hedgehog
-import Hedgehog qualified as H
 import Hedgehog.Extras.Test qualified as H
 
 -- | Execute me with:
@@ -81,35 +78,36 @@ hprop_golden_conway_build_raw_donation_no_current_treasury_value =
 
     H.diffFileVsGoldenFile outFile goldenFile
 
--- Negative test: Missing --treasury-donation
+-- Donations is not mandatory for current treasury value, see formal spec:
+-- \* https://intersectmbo.github.io/formal-ledger-specifications/site/Ledger.Conway.Specification.Utxo.html#sec:the-utxos-transition-rule
+-- \* https://intersectmbo.github.io/formal-ledger-specifications/site/Notation.html#the-maybe-type
 
 -- | Execute me with:
 -- @cabal test cardano-cli-golden --test-options '-p "/golden conway build raw donation no treasury donation/"'@
 hprop_golden_conway_build_raw_donation_no_treasury_donation :: Property
 hprop_golden_conway_build_raw_donation_no_treasury_donation =
   watchdogProp . propertyOnce . H.moduleWorkspace "tmp" $ \tempDir -> do
+    let goldenFile = "test/cardano-cli-golden/files/golden/conway/current-val-no-donation.tx"
     -- Key filepaths
     outFile <- noteTempFile tempDir "out.json"
 
-    (exitCode, _stdout, stderr) <-
-      H.noteShowM $
-        execDetailCardanoCLI
-          [ "conway"
-          , "transaction"
-          , "build-raw"
-          , "--tx-in"
-          , "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0"
-          , "--tx-out"
-          , "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223"
-          , "--tx-out"
-          , "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000"
-          , "--current-treasury-value"
-          , "1000343"
-          , "--fee"
-          , "166777"
-          , "--out-file"
-          , outFile
-          ]
-
-    exitCode H.=== ExitFailure 1
-    H.assertWith stderr ("Missing: --treasury-donation LOVELACE" `isInfixOf`)
+    void $
+      execCardanoCLI
+        [ "conway"
+        , "transaction"
+        , "build-raw"
+        , "--tx-in"
+        , "f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d#0"
+        , "--tx-out"
+        , "addr_test1qpmxr8d8jcl25kyz2tz9a9sxv7jxglhddyf475045y8j3zxjcg9vquzkljyfn3rasfwwlkwu7hhm59gzxmsyxf3w9dps8832xh+1199989833223"
+        , "--tx-out"
+        , "addr_test1vpqgspvmh6m2m5pwangvdg499srfzre2dd96qq57nlnw6yctpasy4+10000000"
+        , "--current-treasury-value"
+        , "1000343"
+        , "--fee"
+        , "166777"
+        , "--out-file"
+        , outFile
+        ]
+
+    H.diffFileVsGoldenFile outFile goldenFile

cardano-cli/test/cardano-cli-golden/files/golden/conway/current-val-no-donation.tx

@@ -0,0 +1,5 @@
+{
+    "type": "Tx ConwayEra",
+    "description": "Ledger Cddl Format",
+    "cborHex": "84a400d9010281825820f62cd7bc15d8c6d2c8519fb8d13c57c0157ab6bab50af62bc63706feb966393d0001828258390076619da7963eaa588252c45e960667a4647eed69135f51f5a10f2888d2c20ac07056fc8899c47d825cefd9dcf5efba150236e043262e2b431b0000011764f7be0782581d604088059bbeb6add02eecd0c6a2a52c06910f2a6b4ba0029e9fe6ed131a00989680021a00028b79151a000f4397a0f5f6"
+}