From 879e48c49a935628c1152910c3d3c6306114b0a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Thu, 23 May 2024 14:13:56 +0200 Subject: [PATCH 1/6] Comment for future proofing --- cardano-api/internal/Cardano/Api/Tx/Body.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index b395f25f0f..64bf7d3e8d 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -1188,6 +1188,8 @@ deriving instance Show (TxProposalProcedures build era) -- Transaction body content -- +-- If you extend this type, consider updating the @friendly*@ family of functions +-- in cardano-cli. data TxBodyContent build era = TxBodyContent { txIns :: TxIns build era, From 1085354a6847cf98ad19af28f52a3551994fe08c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Fri, 24 May 2024 10:22:05 +0200 Subject: [PATCH 2/6] TxBodyContent: support treasury donations --- cardano-api/internal/Cardano/Api/Tx/Body.hs | 40 +++++++++++++++++++-- cardano-api/src/Cardano/Api.hs | 2 ++ 2 files changed, 40 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 64bf7d3e8d..bd88fb6b5a 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -54,6 +54,8 @@ module Cardano.Api.Tx.Body ( setTxUpdateProposal, setTxMintValue, setTxScriptValidity, + setTxCurrentTreasuryValue, + setTxTreasuryDonation, TxBodyError(..), TxBodyScriptData(..), TxScriptValidity(..), @@ -205,6 +207,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 @@ -1211,7 +1214,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) @@ -1239,6 +1246,8 @@ defaultTxBodyContent era = TxBodyContent , txScriptValidity = TxScriptValidityNone , txProposalProcedures = Nothing , txVotingProcedures = Nothing + , txCurrentTreasuryValue = Nothing + , txTreasuryDonation = Nothing } setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era @@ -1307,8 +1316,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 }) = @@ -1666,6 +1678,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 @@ -1694,6 +1708,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 diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 036d540134..c24d43f046 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -329,6 +329,8 @@ module Cardano.Api ( setTxUpdateProposal, setTxMintValue, setTxScriptValidity, + setTxCurrentTreasuryValue, + setTxTreasuryDonation, TxBodyError(..), TxBodyScriptData(..), From 0462e56cf68d3612f424a52ed2e9b841c81fea56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Fri, 24 May 2024 16:25:38 +0200 Subject: [PATCH 3/6] Make cardano-api/gen support currentTreasuryValue and treasuryDonation --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) 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 From 9daacc51a08df2d24afc0f69c9fe95a65bf4bffa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Thu, 30 May 2024 16:46:40 +0200 Subject: [PATCH 4/6] Add a missing export --- cardano-api/src/Cardano/Api.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index c24d43f046..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, From 5eca9140f9594f493d68e0fd3a9f2502aa712ee6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Tue, 4 Jun 2024 16:32:58 +0200 Subject: [PATCH 5/6] Update makeShelleyTransactionBody with the new fields in the Conway era --- cardano-api/internal/Cardano/Api/Ledger/Lens.hs | 9 +++++++++ cardano-api/internal/Cardano/Api/Tx/Body.hs | 13 ++++++++++--- 2 files changed, 19 insertions(+), 3 deletions(-) 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 bd88fb6b5a..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, @@ -1191,8 +1193,9 @@ deriving instance Show (TxProposalProcedures build era) -- Transaction body content -- --- If you extend this type, consider updating the @friendly*@ family of functions --- in cardano-cli. +-- 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, @@ -2637,7 +2640,9 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway txMintValue, txScriptValidity, txProposalProcedures, - txVotingProcedures + txVotingProcedures, + txCurrentTreasuryValue, + txTreasuryDonation } = do let aOn = AllegraEraOnwardsConway let cOn = ConwayEraOnwardsConway @@ -2663,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 From 2451fac7356c076fe2ead27026fd628d57dc6631 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= Date: Tue, 4 Jun 2024 16:50:11 +0200 Subject: [PATCH 6/6] Add a missing Show instance --- cardano-api/internal/Cardano/Api/Fees.hs | 1 + 1 file changed, 1 insertion(+) 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 }