Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
36 changes: 22 additions & 14 deletions cardano-cli/src/Cardano/CLI/EraBased/Common/Option.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()
Expand Down Expand Up @@ -1190,21 +1191,28 @@ 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 "include-current-treasury-value"
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why deviate from the name that build-raw uses?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The reason I used a different name for the flag is that this one obtains the value from the node, while build-raw takes it from the command line (so it expects a value after the flag). But I don't have a strong opinion about it

, Opt.help "Include the current treasury value in the transaction."
]
, pure ExcludeCurrentTreasuryValue
]

pTreasuryDonation :: Parser (Maybe TxTreasuryDonation)
pTreasuryDonation =
Expand Down
26 changes: 23 additions & 3 deletions cardano-cli/src/Cardano/CLI/EraBased/Transaction/Command.hs
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ module Cardano.CLI.EraBased.Transaction.Command
, TransactionViewCmdArgs (..)
, TransactionWitnessCmdArgs (..)
, TxCborFormat (..)
, IncludeCurrentTreasuryValue (..)
, renderTransactionCmds
)
where
Expand Down Expand Up @@ -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 (TxCurrentTreasuryValue, TxTreasuryDonation))
, mCurrentTreasuryValue :: !(Maybe TxCurrentTreasuryValue)
, mTreasuryDonation :: !(Maybe TxTreasuryDonation)
, isCborOutCanonical :: !TxCborFormat
, txBodyOutFile :: !(TxBodyFile Out)
}
Expand All @@ -107,6 +109,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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why are you introducing this sum type? It's not necessary. What is wrong with (Maybe TxCurrentTreasuryValue)?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It is different because that command takes the value from the node, not from the command line, so it would be equivalent to Bool.

And the reason I don't use Bool is so that the code is more strongly-typed and self-documenting. Also not a strong opinion

deriving (Eq, Show)

-- | Like 'TransactionBuildRaw' but without the fee, and with a change output.
data TransactionBuildCmdArgs era = TransactionBuildCmdArgs
{ currentEra :: !(Exp.Era era)
Expand Down Expand Up @@ -148,7 +166,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
}
Expand Down Expand Up @@ -198,7 +217,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)
}
Expand Down
7 changes: 5 additions & 2 deletions cardano-cli/src/Cardano/CLI/EraBased/Transaction/Option.hs
Original file line number Diff line number Diff line change
Expand Up @@ -222,6 +222,7 @@ pTransactionBuildCmd envCli = do
<*> pFeatured era' (optional pUpdateProposalFile)
<*> pVoteFiles AutoBalance
<*> pProposalFiles AutoBalance
<*> pIncludeCurrentTreasuryValue
<*> pTreasuryDonation
<*> pIsCborOutCanonical
<*> pTxBuildOutputOptions
Expand Down Expand Up @@ -285,7 +286,8 @@ pTransactionBuildEstimateCmd _envCli = do
<*> many pMetadataFile
<*> pVoteFiles ManualBalance
<*> pProposalFiles ManualBalance
<*> pCurrentTreasuryValueAndDonation
<*> pCurrentTreasuryValue
<*> pTreasuryDonation
<*> pIsCborOutCanonical
<*> pTxBodyFileOut

Expand Down Expand Up @@ -324,7 +326,8 @@ pTransactionBuildRaw =
<*> pFeatured Exp.useEra (optional pUpdateProposalFile)
<*> pVoteFiles ManualBalance
<*> pProposalFiles ManualBalance
<*> pCurrentTreasuryValueAndDonation
<*> pCurrentTreasuryValue
<*> pTreasuryDonation
<*> pIsCborOutCanonical
<*> pTxBodyFileOut

Expand Down
54 changes: 33 additions & 21 deletions cardano-cli/src/Cardano/CLI/EraBased/Transaction/Run.hs
Original file line number Diff line number Diff line change
Expand Up @@ -157,7 +157,8 @@ runTransactionBuildCmd
, mUpdateProposalFile
, voteFiles
, proposalFiles
, treasuryDonation -- Maybe TxTreasuryDonation
, includeCurrentTreasuryValue
, mTreasuryDonation
, isCborOutCanonical
, buildOutputOptions
} = do
Expand Down Expand Up @@ -288,11 +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, 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 txBodyContent balancedTxBody _ _ <-
Expand Down Expand Up @@ -320,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
Expand Down Expand Up @@ -407,7 +407,8 @@ runTransactionBuildEstimateCmd -- TODO change type
, proposalFiles
, plutusCollateral
, totalReferenceScriptSize
, currentTreasuryValueAndDonation
, currentTreasuryValue
, treasuryDonation
, isCborOutCanonical
, txBodyOutFile
} = do
Expand Down Expand Up @@ -494,7 +495,8 @@ runTransactionBuildEstimateCmd -- TODO change type
TxUpdateProposalNone
votingProceduresAndMaybeScriptWits
proposals
currentTreasuryValueAndDonation
currentTreasuryValue
treasuryDonation
let stakeCredentialsToDeregisterMap = fromList $ catMaybes [getStakeDeregistrationInfo cert | (cert, _) <- certsAndMaybeScriptWits]
drepsToDeregisterMap =
fromList $
Expand Down Expand Up @@ -612,7 +614,8 @@ runTransactionBuildRawCmd
, mUpdateProprosalFile
, voteFiles
, proposalFiles
, currentTreasuryValueAndDonation
, mCurrentTreasuryValue
, mTreasuryDonation
, isCborOutCanonical
, txBodyOutFile
} = Exp.obtainCommonConstraints eon $ do
Expand Down Expand Up @@ -698,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
Expand Down Expand Up @@ -743,7 +747,8 @@ runTxBuildRaw
-> TxUpdateProposal era
-> [(VotingProcedures era, Maybe (VoteScriptWitness era))]
-> [(Proposal era, Maybe (ProposalScriptWitness era))]
-> Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)
-> Maybe TxCurrentTreasuryValue
-> Maybe TxTreasuryDonation
-> Either TxCmdError (Exp.UnsignedTx era)
runTxBuildRaw
mScriptValidity
Expand All @@ -766,7 +771,8 @@ runTxBuildRaw
txUpdateProposal
votingProcedures
proposals
mCurrentTreasuryValueAndDonation = do
mCurrentTreasuryValue
mTreasuryDonation = do
txBodyContent <-
constructTxBodyContent
mScriptValidity
Expand All @@ -789,7 +795,8 @@ runTxBuildRaw
txUpdateProposal
votingProcedures
proposals
mCurrentTreasuryValueAndDonation
mCurrentTreasuryValue
mTreasuryDonation

first TxCmdTxBodyError $ Exp.makeUnsignedTx Exp.useEra txBodyContent

Expand Down Expand Up @@ -829,7 +836,8 @@ constructTxBodyContent
-> TxUpdateProposal era
-> [(VotingProcedures era, Maybe (VoteScriptWitness era))]
-> [(Proposal era, Maybe (ProposalScriptWitness 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.
Expand All @@ -855,7 +863,8 @@ constructTxBodyContent
txUpdateProposal
votingProcedures
proposals
mCurrentTreasuryValueAndDonation =
mCurrentTreasuryValue
mTreasuryDonation =
do
let sbe = convert $ Exp.useEra @era
let allReferenceInputs =
Expand Down Expand Up @@ -891,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
Expand Down Expand Up @@ -969,7 +978,8 @@ runTxBuild
-> Maybe Word
-> [(VotingProcedures era, Maybe (VoteScriptWitness era))]
-> [(Proposal era, Maybe (ProposalScriptWitness era))]
-> Maybe (TxCurrentTreasuryValue, TxTreasuryDonation)
-> Maybe TxCurrentTreasuryValue
-> Maybe TxTreasuryDonation
-- ^ The current treasury value and the donation.
-> ExceptT TxCmdError IO (BalancedTxBody era)
runTxBuild
Expand All @@ -995,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
Expand Down Expand Up @@ -1062,7 +1073,8 @@ runTxBuild
txUpdateProposal
votingProcedures
proposals
mCurrentTreasuryValueAndDonation
mCurrentTreasuryValue
mTreasuryDonation

firstExceptT TxCmdTxInsDoNotExist
. hoistEither
Expand Down
Loading
Loading