Update makeShelleyTransactionBody with the new fields in the Conway era

IntersectMBO · Jun 5, 2024 · b7308a2 · b7308a2
1 parent 56383f2
commit b7308a2
Show file tree

Hide file tree

Showing 2 changed files with 19 additions and 3 deletions.
diff --git 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
@@ -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