diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 9e7c72aa31..7c92c7a062 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -655,6 +655,8 @@ genTxBodyContent sbe = do txScriptValidity <- genTxScriptValidity era txProposalProcedures <- genMaybeFeaturedInEra genProposals era txVotingProcedures <- genMaybeFeaturedInEra genVotingProcedures era + txCurrentTreasuryValue <- genMaybeFeaturedInEra genCurrentTreasuryValue era + txTreasuryDonation <- genMaybeFeaturedInEra genTreasuryDonation era pure $ TxBodyContent { Api.txIns , Api.txInsCollateral @@ -676,6 +678,8 @@ genTxBodyContent sbe = do , Api.txScriptValidity , Api.txProposalProcedures , Api.txVotingProcedures + , Api.txCurrentTreasuryValue + , Api.txTreasuryDonation } @@ -1102,3 +1106,9 @@ genVotingProcedures :: ConwayEraOnwards era -> Gen (Api.TxVotingProcedures Build genVotingProcedures w = conwayEraOnwardsConstraints w $ Api.TxVotingProcedures <$> Q.arbitrary <*> return (BuildTxWith mempty) + +genCurrentTreasuryValue :: ConwayEraOnwards era -> Gen L.Coin +genCurrentTreasuryValue _era = Q.arbitrary + +genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin +genTreasuryDonation _era = Q.arbitrary \ No newline at end of file diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 820692c8cb..6765081a16 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -895,6 +895,7 @@ data BalancedTxBody era (TxBody era) (TxOut CtxTx era) -- ^ Transaction balance (change output) L.Coin -- ^ Estimated transaction fee + deriving Show newtype RequiredShelleyKeyWitnesses = RequiredShelleyKeyWitnesses { unRequiredShelleyKeyWitnesses :: Int } diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index d6413ffa11..12dd53e60b 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -33,6 +33,8 @@ module Cardano.Api.Ledger.Lens , certsTxBodyL , votingProceduresTxBodyL , proposalProceduresTxBodyL + , currentTreasuryValueTxBodyL + , treasuryDonationTxBodyL , adaAssetL , multiAssetL , valueTxOutL @@ -56,6 +58,7 @@ import qualified Cardano.Ledger.Alonzo.Core as L import qualified Cardano.Ledger.Api as L import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..)) import qualified Cardano.Ledger.Coin as L +import qualified Cardano.Ledger.Conway.Core as L import qualified Cardano.Ledger.Keys as L import qualified Cardano.Ledger.Mary.Value as L import qualified Cardano.Ledger.Shelley.PParams as L @@ -178,6 +181,12 @@ votingProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.votingPr proposalProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.OSet (L.ProposalProcedure (ShelleyLedgerEra era))) proposalProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.proposalProceduresTxBodyL +currentTreasuryValueTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (StrictMaybe L.Coin) +currentTreasuryValueTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.currentTreasuryValueTxBodyL + +treasuryDonationTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) L.Coin +treasuryDonationTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.treasuryDonationTxBodyL + mkAdaOnlyTxOut :: ShelleyBasedEra era -> L.Addr (L.EraCrypto (ShelleyLedgerEra era)) -> L.Coin -> L.TxOut (ShelleyLedgerEra era) mkAdaOnlyTxOut sbe addr coin = mkBasicTxOut sbe addr (mkAdaValue sbe coin) diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index b395f25f0f..d6c2492326 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -16,6 +16,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} +{- HLINT ignore "Redundant bracket" -} + -- | Transaction bodies module Cardano.Api.Tx.Body ( parseTxId, @@ -54,6 +56,8 @@ module Cardano.Api.Tx.Body ( setTxUpdateProposal, setTxMintValue, setTxScriptValidity, + setTxCurrentTreasuryValue, + setTxTreasuryDonation, TxBodyError(..), TxBodyScriptData(..), TxScriptValidity(..), @@ -205,6 +209,7 @@ import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Binary (Annotated (..)) import qualified Cardano.Ledger.Binary as CBOR import qualified Cardano.Ledger.Coin as L +import qualified Cardano.Ledger.Conway.Core as L import Cardano.Ledger.Core () import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger @@ -1188,6 +1193,9 @@ deriving instance Show (TxProposalProcedures build era) -- Transaction body content -- +-- If you extend this type, consider updating: +-- - the 'makeShelleyTransactionBody' function of the relevant era below, and +-- - the @friendly*@ family of functions in cardano-cli. data TxBodyContent build era = TxBodyContent { txIns :: TxIns build era, @@ -1209,7 +1217,11 @@ data TxBodyContent build era = txMintValue :: TxMintValue build era, txScriptValidity :: TxScriptValidity era, txProposalProcedures :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)), - txVotingProcedures :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)) + txVotingProcedures :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)), + -- | Current treasury value + txCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards era L.Coin), + -- | Treasury donation to perform + txTreasuryDonation :: Maybe (Featured ConwayEraOnwards era L.Coin) } deriving (Eq, Show) @@ -1237,6 +1249,8 @@ defaultTxBodyContent era = TxBodyContent , txScriptValidity = TxScriptValidityNone , txProposalProcedures = Nothing , txVotingProcedures = Nothing + , txCurrentTreasuryValue = Nothing + , txTreasuryDonation = Nothing } setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era @@ -1305,8 +1319,11 @@ setTxMintValue v txBodyContent = txBodyContent { txMintValue = v } setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era setTxScriptValidity v txBodyContent = txBodyContent { txScriptValidity = v } +setTxCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards era L.Coin) -> TxBodyContent build era -> TxBodyContent build era +setTxCurrentTreasuryValue v txBodyContent = txBodyContent { txCurrentTreasuryValue = v } - +setTxTreasuryDonation :: Maybe (Featured ConwayEraOnwards era L.Coin) -> TxBodyContent build era -> TxBodyContent build era +setTxTreasuryDonation v txBodyContent = txBodyContent { txTreasuryDonation = v } getTxIdByron :: Byron.ATxAux ByteString -> TxId getTxIdByron (Byron.ATxAux { Byron.aTaTx = txbody }) = @@ -1664,6 +1681,8 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux = , txScriptValidity = scriptValidity , txProposalProcedures = fromLedgerProposalProcedures sbe body , txVotingProcedures = fromLedgerVotingProcedures sbe body + , txCurrentTreasuryValue = fromLedgerCurrentTreasuryValue sbe body + , txTreasuryDonation = fromLedgerTreasuryDonation sbe body } where (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux @@ -1692,6 +1711,28 @@ fromLedgerVotingProcedures sbe body = (body ^. L.votingProceduresTxBodyL) ViewTx +fromLedgerCurrentTreasuryValue :: () + => ShelleyBasedEra era + -> Ledger.TxBody (ShelleyLedgerEra era) + -> Maybe (Featured ConwayEraOnwards era Coin) +fromLedgerCurrentTreasuryValue sbe body = + caseShelleyToBabbageOrConwayEraOnwards + (const Nothing) + (\cOnwards -> conwayEraOnwardsConstraints cOnwards $ + case body ^. L.currentTreasuryValueTxBodyL of + SNothing -> Nothing + SJust currentTreasuryValue -> Just $ Featured cOnwards currentTreasuryValue) + sbe + +fromLedgerTreasuryDonation :: () + => ShelleyBasedEra era + -> L.TxBody (ShelleyLedgerEra era) + -> Maybe (Featured ConwayEraOnwards era Coin) +fromLedgerTreasuryDonation sbe body = + forShelleyBasedEraInEonMaybe sbe $ \w -> + conwayEraOnwardsConstraints w + $ Featured w (body ^. L.treasuryDonationTxBodyL) + fromLedgerTxIns :: forall era. ShelleyBasedEra era @@ -2599,7 +2640,9 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway txMintValue, txScriptValidity, txProposalProcedures, - txVotingProcedures + txVotingProcedures, + txCurrentTreasuryValue, + txTreasuryDonation } = do let aOn = AllegraEraOnwardsConway let cOn = ConwayEraOnwardsConway @@ -2625,6 +2668,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash & A.votingProceduresTxBodyL cOn .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured txVotingProcedures) & A.proposalProceduresTxBodyL cOn .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured txProposalProcedures) + & A.currentTreasuryValueTxBodyL cOn .~ (Ledger.maybeToStrictMaybe (unFeatured <$> txCurrentTreasuryValue)) + & A.treasuryDonationTxBodyL cOn .~ (maybe (L.Coin 0) unFeatured txTreasuryDonation) -- TODO Conway: support optional network id in TxBodyContent -- & L.networkIdTxBodyL .~ SNothing ) ^. A.txBodyL diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 036d540134..acd6514e5f 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -50,6 +50,7 @@ module Cardano.Api ( forShelleyBasedEraMaybeEon, Featured(..), + unFeatured, asFeaturedInEra, asFeaturedInShelleyBasedEra, @@ -329,6 +330,8 @@ module Cardano.Api ( setTxUpdateProposal, setTxMintValue, setTxScriptValidity, + setTxCurrentTreasuryValue, + setTxTreasuryDonation, TxBodyError(..), TxBodyScriptData(..),