From b7308a293afded47637d408fd9b8ea89d7f9dae1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Cl=C3=A9ment=20Hurlin?= <clement.hurlin@moduscreate.com>
Date: Tue, 4 Jun 2024 16:32:58 +0200
Subject: [PATCH] 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