Merge pull request #543 from IntersectMBO/smelc/treasury-donation

TxBodyContent: support treasury donations

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

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 }

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)

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

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(..),