From fb3bad194a7fe28ffcbe54e30102ac846cbb0d43 Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 30 Oct 2023 22:14:45 +1100 Subject: [PATCH 1/6] Remove redundant constraints --- cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs | 1 - cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index faee076dca..471c5d0800 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -79,7 +79,6 @@ type AlonzoEraOnwardsConstraints era = , L.AlonzoEraTx (ShelleyLedgerEra era) , L.AlonzoEraTxBody (ShelleyLedgerEra era) , L.AlonzoEraTxOut (ShelleyLedgerEra era) - , L.AlonzoEraTxOut (ShelleyLedgerEra era) , L.AlonzoEraTxWits (ShelleyLedgerEra era) , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) , L.Era (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs index cc73715877..cf0d3a1504 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs @@ -63,8 +63,7 @@ instance ToCardanoEra BabbageEraOnly where BabbageEraOnlyBabbage -> BabbageEra type BabbageEraOnlyConstraints era = - ( L.AlonzoEraTxOut (ShelleyLedgerEra era) - , C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) + ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era))) , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) From e5759808a2687a382a7c840339cd69fbed34767f Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 21:03:47 +1100 Subject: [PATCH 2/6] New ApiTxBody type --- cardano-api/internal/Cardano/Api/Ledger/Lens.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index 707cc4a17c..759d380166 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -12,6 +12,9 @@ module Cardano.Api.Ledger.Lens , invalidHereAfterTxBodyL , ttlAsInvalidHereAfterTxBodyL , apiUpdateTxBodyL + + , TxBody(..) + , txBodyL ) where import Cardano.Api.Eon.AllegraEraOnwards @@ -27,6 +30,10 @@ import qualified Cardano.Ledger.Shelley.PParams as L import Lens.Micro +newtype TxBody era = TxBody + { unTxBody :: L.TxBody (ShelleyLedgerEra era) + } + strictMaybeL :: Lens' (StrictMaybe a) (Maybe a) strictMaybeL = lens g s where @@ -37,6 +44,9 @@ strictMaybeL = lens g s s :: StrictMaybe a -> Maybe a -> StrictMaybe a s _ = maybe SNothing SJust +txBodyL :: Lens' (TxBody era) (L.TxBody (ShelleyLedgerEra era)) +txBodyL = lens unTxBody (\_ x -> TxBody x) + invalidBeforeTxBodyL :: AllegraEraOnwards era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo) invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ L.vldtTxBodyL . L.invalidBeforeL From dfcca53d8eb08f10a4e22ebc7ef760ad66860d91 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 22:16:15 +1100 Subject: [PATCH 3/6] Switch to use newtype wrapper --- .../Cardano/Api/Eon/BabbageEraOnwards.hs | 2 + .../internal/Cardano/Api/Ledger/Lens.hs | 80 ++++++-- cardano-api/internal/Cardano/Api/TxBody.hs | 194 ++++++++++-------- 3 files changed, 179 insertions(+), 97 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index 06695f3778..f8c41c4299 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -31,6 +31,7 @@ import qualified Cardano.Ledger.Alonzo.Scripts as L import qualified Cardano.Ledger.Alonzo.TxInfo as L import qualified Cardano.Ledger.Alonzo.UTxO as L import qualified Cardano.Ledger.Api as L +import qualified Cardano.Ledger.Babbage.TxOut as L import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.Mary.Value as L @@ -90,6 +91,7 @@ type BabbageEraOnwardsConstraints era = , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) , L.ShelleyEraTxCert (ShelleyLedgerEra era) + , L.TxOut (ShelleyLedgerEra era) ~ L.BabbageTxOut (ShelleyLedgerEra era) , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index 759d380166..0fa906f874 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {- HLINT ignore "Eta reduce" -} @@ -11,23 +12,45 @@ module Cardano.Api.Ledger.Lens , invalidBeforeTxBodyL , invalidHereAfterTxBodyL , ttlAsInvalidHereAfterTxBodyL - , apiUpdateTxBodyL + , updateTxBodyL , TxBody(..) , txBodyL + , mintTxBodyL + , scriptIntegrityHashTxBodyL + , collateralInputsTxBodyL + , reqSignerHashesTxBodyL + , referenceInputsTxBodyL + , collateralReturnTxBodyL + , totalCollateralTxBodyL + , certsTxBodyL + , votingProceduresTxBodyL + , proposalProceduresTxBodyL ) where import Cardano.Api.Eon.AllegraEraOnwards +import Cardano.Api.Eon.AlonzoEraOnwards +import Cardano.Api.Eon.BabbageEraOnwards +import Cardano.Api.Eon.ConwayEraOnwards +import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eon.ShelleyEraOnly import Cardano.Api.Eon.ShelleyToBabbageEra import Cardano.Api.Eras.Case import qualified Cardano.Ledger.Allegra.Core as L +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.Keys as L +import qualified Cardano.Ledger.Mary.Value as L import qualified Cardano.Ledger.Shelley.PParams as L +import qualified Cardano.Ledger.TxIn as L +import qualified Data.OSet.Strict as L +import qualified Data.Sequence.Strict as L +import Data.Set (Set) import Lens.Micro newtype TxBody era = TxBody @@ -47,8 +70,8 @@ strictMaybeL = lens g s txBodyL :: Lens' (TxBody era) (L.TxBody (ShelleyLedgerEra era)) txBodyL = lens unTxBody (\_ x -> TxBody x) -invalidBeforeTxBodyL :: AllegraEraOnwards era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo) -invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ L.vldtTxBodyL . L.invalidBeforeL +invalidBeforeTxBodyL :: AllegraEraOnwards era -> Lens' (TxBody era) (Maybe SlotNo) +invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ txBodyL . L.vldtTxBodyL . L.invalidBeforeL -- | Compatibility lens that provides a consistent interface over 'ttlTxBodyL' and -- 'vldtTxBodyL . invalidHereAfterStrictL' across all shelley based eras. @@ -65,27 +88,27 @@ invalidBeforeTxBodyL w = allegraEraOnwardsConstraints w $ L.vldtTxBodyL . L.inva -- -- 'invalidHereAfterTxBodyL' lens over both with a 'Maybe SlotNo' type representation. Withing the -- Shelley era, setting Nothing will set the ttl to 'maxBound' in the underlying ledger type. -invalidHereAfterTxBodyL :: ShelleyBasedEra era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo) +invalidHereAfterTxBodyL :: ShelleyBasedEra era -> Lens' (TxBody era) (Maybe SlotNo) invalidHereAfterTxBodyL = caseShelleyEraOnlyOrAllegraEraOnwards ttlAsInvalidHereAfterTxBodyL - (const $ L.vldtTxBodyL . L.invalidHereAfterL) + (const $ txBodyL . L.vldtTxBodyL . L.invalidHereAfterL) -- | Compatibility lens over 'ttlTxBodyL' which represents 'maxBound' as Nothing and all other values as 'Just'. -ttlAsInvalidHereAfterTxBodyL :: ShelleyEraOnly era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (Maybe SlotNo) +ttlAsInvalidHereAfterTxBodyL :: ShelleyEraOnly era -> Lens' (TxBody era) (Maybe SlotNo) ttlAsInvalidHereAfterTxBodyL w = lens (g w) (s w) where - g :: ShelleyEraOnly era -> L.TxBody (ShelleyLedgerEra era) -> Maybe SlotNo + g :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo g w' txBody = shelleyEraOnlyConstraints w' $ - let ttl = txBody ^. L.ttlTxBodyL in if ttl == maxBound then Nothing else Just ttl + let ttl = txBody ^. txBodyL . L.ttlTxBodyL in if ttl == maxBound then Nothing else Just ttl - s :: ShelleyEraOnly era -> L.TxBody (ShelleyLedgerEra era) -> Maybe SlotNo -> L.TxBody (ShelleyLedgerEra era) + s :: ShelleyEraOnly era -> TxBody era -> Maybe SlotNo -> TxBody era s w' txBody mSlotNo = shelleyEraOnlyConstraints w' $ case mSlotNo of - Nothing -> txBody & L.ttlTxBodyL .~ maxBound - Just ttl -> txBody & L.ttlTxBodyL .~ ttl + Nothing -> txBody & txBodyL . L.ttlTxBodyL .~ maxBound + Just ttl -> txBody & txBodyL . L.ttlTxBodyL .~ ttl -- | Lens to access the 'invalidBefore' field of a 'ValidityInterval' as a 'StrictMaybe SlotNo'. -- Ideally this should be defined in cardano-ledger @@ -109,5 +132,36 @@ invalidHereAfterStrictL = lens g s s :: L.ValidityInterval -> StrictMaybe SlotNo -> L.ValidityInterval s (L.ValidityInterval a _) b = L.ValidityInterval a b -apiUpdateTxBodyL :: ShelleyToBabbageEra era -> Lens' (L.TxBody (ShelleyLedgerEra era)) (StrictMaybe (L.Update (ShelleyLedgerEra era))) -apiUpdateTxBodyL w = shelleyToBabbageEraConstraints w L.updateTxBodyL +updateTxBodyL :: ShelleyToBabbageEra era -> Lens' (TxBody era) (StrictMaybe (L.Update (ShelleyLedgerEra era))) +updateTxBodyL w = shelleyToBabbageEraConstraints w $ txBodyL . L.updateTxBodyL + +mintTxBodyL :: MaryEraOnwards era -> Lens' (TxBody era) (L.MultiAsset L.StandardCrypto) +mintTxBodyL w = maryEraOnwardsConstraints w $ txBodyL . L.mintTxBodyL + +scriptIntegrityHashTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.ScriptIntegrityHash L.StandardCrypto)) +scriptIntegrityHashTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.scriptIntegrityHashTxBodyL + +collateralInputsTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto)) +collateralInputsTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.collateralInputsTxBodyL + +reqSignerHashesTxBodyL :: AlonzoEraOnwards era -> Lens' (TxBody era) (Set (L.KeyHash L.Witness L.StandardCrypto)) +reqSignerHashesTxBodyL w = alonzoEraOnwardsConstraints w $ txBodyL . L.reqSignerHashesTxBodyL + +referenceInputsTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (Set (L.TxIn L.StandardCrypto)) +referenceInputsTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.referenceInputsTxBodyL + +collateralReturnTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (StrictMaybe (L.TxOut (ShelleyLedgerEra era))) +collateralReturnTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.collateralReturnTxBodyL + +totalCollateralTxBodyL :: BabbageEraOnwards era -> Lens' (TxBody era) (StrictMaybe L.Coin) +totalCollateralTxBodyL w = babbageEraOnwardsConstraints w $ txBodyL . L.totalCollateralTxBodyL + +certsTxBodyL :: ShelleyBasedEra era -> Lens' (TxBody era) (L.StrictSeq (L.TxCert (ShelleyLedgerEra era))) +certsTxBodyL w = shelleyBasedEraConstraints w $ txBodyL . L.certsTxBodyL + +votingProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.VotingProcedures (ShelleyLedgerEra era)) +votingProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.votingProceduresTxBodyL + +proposalProceduresTxBodyL :: ConwayEraOnwards era -> Lens' (TxBody era) (L.OSet (L.ProposalProcedure (ShelleyLedgerEra era))) +proposalProceduresTxBodyL w = conwayEraOnwardsConstraints w $ txBodyL . L.proposalProceduresTxBodyL + diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 65cb6b4909..a8f78bb50a 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -190,6 +190,8 @@ import qualified Cardano.Chain.Common as Byron import qualified Cardano.Chain.UTxO as Byron import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.Hashing as Byron +import qualified Cardano.Ledger.Allegra.Core as L +import qualified Cardano.Ledger.Alonzo.Core as L import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo (hashScriptIntegrity) @@ -200,7 +202,6 @@ import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Binary (Annotated (..), reAnnotate, recoverBytes) import qualified Cardano.Ledger.Binary as CBOR import qualified Cardano.Ledger.Block as Ledger -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 @@ -238,7 +239,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, maybeToList) -import Data.OSet.Strict as OSet (fromStrictSeq) +import qualified Data.OSet.Strict as OSet import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq import Data.Set (Set) @@ -1831,7 +1832,7 @@ createTransactionBody sbe bc = setUpdateProposal <- caseShelleyToBabbageOrConwayEraOnwards - (\w -> (A.apiUpdateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc)) + (\w -> (A.updateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc)) (const $ pure id) sbe @@ -1844,48 +1845,48 @@ createTransactionBody sbe bc = setMint <- caseShelleyToAllegraOrMaryEraOnwards (const $ pure id) - (const $ pure $ L.mintTxBodyL .~ convMintValue apiMintValue) + (\w -> pure $ A.mintTxBodyL w .~ convMintValue apiMintValue) sbe setScriptIntegrityHash <- caseShelleyToMaryOrAlonzoEraOnwards (const $ pure id) - (const $ pure $ L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData) + (\w -> pure $ A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData) sbe setCollateralInputs <- caseShelleyToMaryOrAlonzoEraOnwards (const $ pure id) - (const $ pure $ L.collateralInputsTxBodyL .~ collTxIns) + (\w -> pure $ A.collateralInputsTxBodyL w .~ collTxIns) sbe setReqSignerHashes <- caseShelleyToMaryOrAlonzoEraOnwards (const $ pure id) - (const $ pure $ L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses) + (\w -> pure $ A.reqSignerHashesTxBodyL w .~ convExtraKeyWitnesses apiExtraKeyWitnesses) sbe setReferenceInputs <- caseShelleyToAlonzoOrBabbageEraOnwards (const $ pure id) - (const $ pure $ L.referenceInputsTxBodyL .~ refTxIns) + (\w -> pure $ A.referenceInputsTxBodyL w .~ refTxIns) sbe setCollateralReturn <- caseShelleyToAlonzoOrBabbageEraOnwards (const $ pure id) - (const $ pure $ L.collateralReturnTxBodyL .~ returnCollateral) + (\w -> pure $ A.collateralReturnTxBodyL w .~ returnCollateral) sbe setTotalCollateral <- caseShelleyToAlonzoOrBabbageEraOnwards (const $ pure id) - (const $ pure $ L.totalCollateralTxBodyL .~ totalCollateral) + (\w -> pure $ A.totalCollateralTxBodyL w .~ totalCollateral) sbe let ledgerTxBody = mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData - & L.certsTxBodyL .~ certs + & A.certsTxBodyL sbe .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) & modifyWith setUpdateProposal & modifyWith setInvalidBefore @@ -1900,7 +1901,7 @@ createTransactionBody sbe bc = -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... - pure $ ShelleyTxBody sbe ledgerTxBody scripts sData txAuxData apiScriptValidity + pure $ ShelleyTxBody sbe (ledgerTxBody ^. A.txBodyL) scripts sData txAuxData apiScriptValidity getScriptIntegrityHash :: () => BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era)) @@ -2088,8 +2089,8 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux = , txTotalCollateral = fromLedgerTxTotalCollateral sbe body , txReturnCollateral = fromLedgerTxReturnCollateral sbe body , txFee = fromLedgerTxFee sbe body - , txValidityLowerBound = fromLedgerTxValidityLowerBound sbe body - , txValidityUpperBound = fromLedgerTxValidityUpperBound sbe body + , txValidityLowerBound = fromLedgerTxValidityLowerBound sbe (A.TxBody body) + , txValidityUpperBound = fromLedgerTxValidityUpperBound sbe (A.TxBody body) , txWithdrawals = fromLedgerTxWithdrawals sbe body , txCertificates = fromLedgerTxCertificates sbe body , txUpdateProposal = maybeFromLedgerTxUpdateProposal sbe body @@ -2307,13 +2308,13 @@ fromLedgerTxFee sbe body = fromLedgerTxValidityLowerBound :: ShelleyBasedEra era - -> Ledger.TxBody (ShelleyLedgerEra era) + -> A.TxBody era -> TxValidityLowerBound era fromLedgerTxValidityLowerBound sbe body = caseShelleyEraOnlyOrAllegraEraOnwards (const TxValidityNoLowerBound) (\w -> - let mInvalidBefore = body ^. L.vldtTxBodyL . A.invalidBeforeL in + let mInvalidBefore = body ^. A.invalidBeforeTxBodyL w in case mInvalidBefore of Nothing -> TxValidityNoLowerBound Just s -> TxValidityLowerBound w s @@ -2322,7 +2323,7 @@ fromLedgerTxValidityLowerBound sbe body = fromLedgerTxValidityUpperBound :: ShelleyBasedEra era - -> Ledger.TxBody (ShelleyLedgerEra era) + -> A.TxBody era -> TxValidityUpperBound era fromLedgerTxValidityUpperBound sbe body = TxValidityUpperBound sbe $ body ^. A.invalidHereAfterTxBodyL sbe @@ -2701,9 +2702,9 @@ mkCommonTxBody :: () -> TxFee era -> TxWithdrawals build era -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) - -> L.TxBody (ShelleyLedgerEra era) + -> A.TxBody era mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData = - shelleyBasedEraConstraints sbe $ + shelleyBasedEraConstraints sbe $ A.TxBody $ L.mkBasicTxBody & L.inputsTxBodyL .~ convTxIns txIns & L.outputsTxBodyL .~ convTxOuts sbe txOuts @@ -2727,16 +2728,18 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraShelley txCertificates, txUpdateProposal } = do - + let s2b = ShelleyToBabbageEraShelley validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal + let txbody = + ( mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.updateTxBodyL s2b .~ update + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + ) ^. A.txBodyL return $ ShelleyTxBody sbe - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.updateTxBodyL .~ update - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - ) + txbody scripts_ TxBodyNoScriptData txAuxData @@ -2766,16 +2769,19 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAllegra txUpdateProposal } = do let aOn = AllegraEraOnwardsAllegra + let s2b = ShelleyToBabbageEraAllegra validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal - return $ - ShelleyTxBody sbe - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & L.certsTxBodyL .~ convCertificates sbe txCertificates + let txbody = + (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & L.updateTxBodyL .~ update - ) + & A.updateTxBodyL s2b .~ update + ) ^. A.txBodyL + return $ + ShelleyTxBody sbe + txbody scripts_ TxBodyNoScriptData txAuxData @@ -2806,17 +2812,21 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraMary txMintValue } = do let aOn = AllegraEraOnwardsMary + let s2b = ShelleyToBabbageEraMary + let mOn = MaryEraOnwardsMary validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal - return $ - ShelleyTxBody sbe - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & L.certsTxBodyL .~ convCertificates sbe txCertificates + let txbody = + (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & L.updateTxBodyL .~ update - & L.mintTxBodyL .~ convMintValue txMintValue - ) + & A.updateTxBodyL s2b .~ update + & A.mintTxBodyL mOn .~ convMintValue txMintValue + ) ^. A.txBodyL + return $ + ShelleyTxBody sbe + txbody scripts TxBodyNoScriptData txAuxData @@ -2851,24 +2861,29 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo txScriptValidity } = do let aOn = AllegraEraOnwardsAlonzo + let s2b = ShelleyToBabbageEraAlonzo + let mOn = MaryEraOnwardsAlonzo + let azOn = AlonzoEraOnwardsAlonzo validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal let scriptIntegrityHash = convPParamsToScriptIntegrityHash AlonzoEraOnwardsAlonzo txProtocolParams redeemers datums languages + let txbody = + (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.collateralInputsTxBodyL azOn .~ convCollateralTxIns txInsCollateral + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.updateTxBodyL s2b .~ update + & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits + & A.mintTxBodyL mOn .~ convMintValue txMintValue + & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash + -- TODO Alonzo: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) ^. A.txBodyL return $ ShelleyTxBody sbe - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & L.collateralInputsTxBodyL .~ convCollateralTxIns txInsCollateral - & L.certsTxBodyL .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & L.updateTxBodyL .~ update - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits - & L.mintTxBodyL .~ convMintValue txMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - -- TODO Alonzo: support optional network id in TxBodyContent - -- & L.networkIdTxBodyL .~ SNothing - ) + txbody scripts (TxBodyScriptData AlonzoEraOnwardsAlonzo datums redeemers) txAuxData @@ -2940,30 +2955,36 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage txScriptValidity } = do let aOn = AllegraEraOnwardsBabbage + let mOn = MaryEraOnwardsBabbage + let azOn = AlonzoEraOnwardsBabbage + let bOn = BabbageEraOnwardsBabbage + let s2b = ShelleyToBabbageEraBabbage validateTxBodyContent sbe txbodycontent update <- convTxUpdateProposal sbe txUpdateProposal let scriptIntegrityHash = convPParamsToScriptIntegrityHash AlonzoEraOnwardsBabbage txProtocolParams redeemers datums languages - return $ - ShelleyTxBody sbe - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & L.collateralInputsTxBodyL .~ + let txbody = + (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.collateralInputsTxBodyL azOn .~ case txInsCollateral of TxInsCollateralNone -> Set.empty TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) - & L.referenceInputsTxBodyL .~ convReferenceInputs txInsReference - & L.collateralReturnTxBodyL .~ convReturnCollateral sbe txReturnCollateral - & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral - & L.certsTxBodyL .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & L.updateTxBodyL .~ update - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits - & L.mintTxBodyL .~ convMintValue txMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash + & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference + & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral + & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.updateTxBodyL s2b .~ update + & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits + & A.mintTxBodyL mOn .~ convMintValue txMintValue + & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash -- TODO Babbage: support optional network id in TxBodyContent -- & L.networkIdTxBodyL .~ SNothing - ) + ) ^. A.txBodyL + return $ + ShelleyTxBody sbe + txbody scripts (TxBodyScriptData AlonzoEraOnwardsBabbage datums redeemers) @@ -3045,31 +3066,36 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway txVotingProcedures } = do let aOn = AllegraEraOnwardsConway + let cOn = ConwayEraOnwardsConway + let mOn = MaryEraOnwardsConway + let bOn = BabbageEraOnwardsConway + let azOn = AlonzoEraOnwardsConway validateTxBodyContent sbe txbodycontent let scriptIntegrityHash = convPParamsToScriptIntegrityHash AlonzoEraOnwardsConway txProtocolParams redeemers datums languages - return $ - ShelleyTxBody sbe - (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData - & L.collateralInputsTxBodyL .~ + let txbody = + (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData + & A.collateralInputsTxBodyL azOn .~ case txInsCollateral of TxInsCollateralNone -> Set.empty TxInsCollateral _ txins -> Set.fromList (map toShelleyTxIn txins) - & L.referenceInputsTxBodyL .~ convReferenceInputs txInsReference - & L.collateralReturnTxBodyL .~ convReturnCollateral sbe txReturnCollateral - & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral - & L.certsTxBodyL .~ convCertificates sbe txCertificates - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits - & L.mintTxBodyL .~ convMintValue txMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - & L.votingProceduresTxBodyL .~ unVotingProcedures @era (maybe emptyVotingProcedures unFeatured txVotingProcedures) - & L.proposalProceduresTxBodyL .~ - OSet.fromStrictSeq (Seq.fromList (fmap unProposal (maybe [] unFeatured txProposalProcedures))) - -- TODO Conway: support optional network id in TxBodyContent - -- & L.networkIdTxBodyL .~ SNothing - ) + & A.referenceInputsTxBodyL bOn .~ convReferenceInputs txInsReference + & A.collateralReturnTxBodyL bOn .~ convReturnCollateral sbe txReturnCollateral + & A.totalCollateralTxBodyL bOn .~ convTotalCollateral txTotalCollateral + & A.certsTxBodyL sbe .~ convCertificates sbe txCertificates + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.reqSignerHashesTxBodyL azOn .~ convExtraKeyWitnesses txExtraKeyWits + & A.mintTxBodyL mOn .~ convMintValue txMintValue + & A.scriptIntegrityHashTxBodyL azOn .~ scriptIntegrityHash + & A.votingProceduresTxBodyL cOn .~ unVotingProcedures @era (maybe emptyVotingProcedures unFeatured txVotingProcedures) + & A.proposalProceduresTxBodyL cOn .~ OSet.fromSet (Set.fromList (fmap unProposal (maybe [] unFeatured txProposalProcedures))) + -- TODO Conway: support optional network id in TxBodyContent + -- & L.networkIdTxBodyL .~ SNothing + ) ^. A.txBodyL + return $ + ShelleyTxBody sbe + txbody scripts (TxBodyScriptData AlonzoEraOnwardsConway datums redeemers) From 60585aef09cb171fbf01d23f29790aacc7c4af44 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sat, 21 Oct 2023 15:11:00 +1100 Subject: [PATCH 4/6] Automatically switch on the eon for setting fields in ledger tx body --- cardano-api/internal/Cardano/Api/TxBody.hs | 63 +++++++--------------- 1 file changed, 18 insertions(+), 45 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index a8f78bb50a..d3d8f9e3f8 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1830,59 +1830,32 @@ createTransactionBody sbe bc = languages = convLanguages apiScriptWitnesses sData = convScriptData sbe apiTxOuts apiScriptWitnesses - setUpdateProposal <- - caseShelleyToBabbageOrConwayEraOnwards - (\w -> (A.updateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc)) - (const $ pure id) - sbe + setUpdateProposal <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + (A.updateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc) - setInvalidBefore <- - caseShelleyEraOnlyOrAllegraEraOnwards - (const $ pure id) - (\aOn -> pure $ A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound bc)) - sbe + setInvalidBefore <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.invalidBeforeTxBodyL w .~ convValidityLowerBound (txValidityLowerBound bc) - setMint <- - caseShelleyToAllegraOrMaryEraOnwards - (const $ pure id) - (\w -> pure $ A.mintTxBodyL w .~ convMintValue apiMintValue) - sbe + setMint <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.mintTxBodyL w .~ convMintValue apiMintValue - setScriptIntegrityHash <- - caseShelleyToMaryOrAlonzoEraOnwards - (const $ pure id) - (\w -> pure $ A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData) - sbe + setScriptIntegrityHash <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData - setCollateralInputs <- - caseShelleyToMaryOrAlonzoEraOnwards - (const $ pure id) - (\w -> pure $ A.collateralInputsTxBodyL w .~ collTxIns) - sbe + setCollateralInputs <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.collateralInputsTxBodyL w .~ collTxIns - setReqSignerHashes <- - caseShelleyToMaryOrAlonzoEraOnwards - (const $ pure id) - (\w -> pure $ A.reqSignerHashesTxBodyL w .~ convExtraKeyWitnesses apiExtraKeyWitnesses) - sbe + setReqSignerHashes <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.reqSignerHashesTxBodyL w .~ convExtraKeyWitnesses apiExtraKeyWitnesses - setReferenceInputs <- - caseShelleyToAlonzoOrBabbageEraOnwards - (const $ pure id) - (\w -> pure $ A.referenceInputsTxBodyL w .~ refTxIns) - sbe + setReferenceInputs <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.referenceInputsTxBodyL w .~ refTxIns - setCollateralReturn <- - caseShelleyToAlonzoOrBabbageEraOnwards - (const $ pure id) - (\w -> pure $ A.collateralReturnTxBodyL w .~ returnCollateral) - sbe + setCollateralReturn <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.collateralReturnTxBodyL w .~ returnCollateral - setTotalCollateral <- - caseShelleyToAlonzoOrBabbageEraOnwards - (const $ pure id) - (\w -> pure $ A.totalCollateralTxBodyL w .~ totalCollateral) - sbe + setTotalCollateral <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + pure $ A.totalCollateralTxBodyL w .~ totalCollateral let ledgerTxBody = mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData From fc98c468b1f9103f5ec0069da455377db0834165 Mon Sep 17 00:00:00 2001 From: John Ky Date: Mon, 30 Oct 2023 22:21:37 +1100 Subject: [PATCH 5/6] Prefer forEraInEon to forShelleyBasedEraInEon --- cardano-api/internal/Cardano/Api/TxBody.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index d3d8f9e3f8..1e528d2433 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1808,7 +1808,8 @@ createTransactionBody :: () -> Either TxBodyError (TxBody era) createTransactionBody sbe bc = shelleyBasedEraConstraints sbe $ do - let apiTxOuts = txOuts bc + let era = shelleyBasedToCardanoEra sbe + apiTxOuts = txOuts bc apiScriptWitnesses = collectTxBodyScriptWitnesses sbe bc apiScriptValidity = txScriptValidity bc apiMintValue = txMintValue bc @@ -1830,31 +1831,31 @@ createTransactionBody sbe bc = languages = convLanguages apiScriptWitnesses sData = convScriptData sbe apiTxOuts apiScriptWitnesses - setUpdateProposal <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setUpdateProposal <- forEraInEon era (pure id) $ \w -> (A.updateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc) - setInvalidBefore <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setInvalidBefore <- forEraInEon era (pure id) $ \w -> pure $ A.invalidBeforeTxBodyL w .~ convValidityLowerBound (txValidityLowerBound bc) - setMint <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setMint <- forEraInEon era (pure id) $ \w -> pure $ A.mintTxBodyL w .~ convMintValue apiMintValue - setScriptIntegrityHash <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setScriptIntegrityHash <- forEraInEon era (pure id) $ \w -> pure $ A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData - setCollateralInputs <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setCollateralInputs <- forEraInEon era (pure id) $ \w -> pure $ A.collateralInputsTxBodyL w .~ collTxIns - setReqSignerHashes <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setReqSignerHashes <- forEraInEon era (pure id) $ \w -> pure $ A.reqSignerHashesTxBodyL w .~ convExtraKeyWitnesses apiExtraKeyWitnesses - setReferenceInputs <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setReferenceInputs <- forEraInEon era (pure id) $ \w -> pure $ A.referenceInputsTxBodyL w .~ refTxIns - setCollateralReturn <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setCollateralReturn <- forEraInEon era (pure id) $ \w -> pure $ A.collateralReturnTxBodyL w .~ returnCollateral - setTotalCollateral <- forShelleyBasedEraInEon sbe (pure id) $ \w -> + setTotalCollateral <- forEraInEon era (pure id) $ \w -> pure $ A.totalCollateralTxBodyL w .~ totalCollateral let ledgerTxBody = From 22414a4a6422ad0f5d3f23ec0c4f867a4bb1452c Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 31 Oct 2023 21:21:47 +1100 Subject: [PATCH 6/6] New monoidForEraInEon and monoidForEraInEonA functions --- cardano-api/internal/Cardano/Api/Eras.hs | 2 + cardano-api/internal/Cardano/Api/Eras/Core.hs | 19 ++++++ cardano-api/internal/Cardano/Api/TxBody.hs | 59 ++++++++++--------- cardano-api/src/Cardano/Api.hs | 3 + 4 files changed, 56 insertions(+), 27 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Eras.hs b/cardano-api/internal/Cardano/Api/Eras.hs index f84f75bff0..0b2a389604 100644 --- a/cardano-api/internal/Cardano/Api/Eras.hs +++ b/cardano-api/internal/Cardano/Api/Eras.hs @@ -30,6 +30,8 @@ module Cardano.Api.Eras , forEraInEonMaybe , forEraMaybeEon , maybeEon + , monoidForEraInEon + , monoidForEraInEonA -- * Data family instances , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra) diff --git a/cardano-api/internal/Cardano/Api/Eras/Core.hs b/cardano-api/internal/Cardano/Api/Eras/Core.hs index 7c0d42f997..e5cf2229ae 100644 --- a/cardano-api/internal/Cardano/Api/Eras/Core.hs +++ b/cardano-api/internal/Cardano/Api/Eras/Core.hs @@ -38,6 +38,8 @@ module Cardano.Api.Eras.Core , forEraInEonMaybe , forEraMaybeEon , maybeEon + , monoidForEraInEon + , monoidForEraInEonA -- * Data family instances , AsType(AsByronEra, AsShelleyEra, AsAllegraEra, AsMaryEra, AsAlonzoEra, AsBabbageEra, AsConwayEra) @@ -164,6 +166,23 @@ maybeEon :: () maybeEon = inEonForEra Nothing Just cardanoEra +monoidForEraInEon :: () + => Eon eon + => Monoid a + => CardanoEra era + -> (eon era -> a) + -> a +monoidForEraInEon sbe = forEraInEon sbe mempty + +monoidForEraInEonA :: () + => Applicative f + => Eon eon + => Monoid a + => CardanoEra era + -> (eon era -> f a) + -> f a +monoidForEraInEonA sbe = forEraInEon sbe (pure mempty) + -- ---------------------------------------------------------------------------- -- Era and eon existential types diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 1e528d2433..588f695f12 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -18,6 +18,7 @@ {-# LANGUAGE ViewPatterns #-} {- HLINT ignore "Avoid lambda using `infix`" -} +{- HLINT ignore "Move brackets to avoid $." -} {- HLINT ignore "Redundant flip" -} {- HLINT ignore "Use let" -} {- HLINT ignore "Use section" -} @@ -239,6 +240,7 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Monoid import qualified Data.OSet.Strict as OSet import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq @@ -1831,46 +1833,49 @@ createTransactionBody sbe bc = languages = convLanguages apiScriptWitnesses sData = convScriptData sbe apiTxOuts apiScriptWitnesses - setUpdateProposal <- forEraInEon era (pure id) $ \w -> - (A.updateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc) + setUpdateProposal <- monoidForEraInEonA era $ \w -> + Endo . (A.updateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc) - setInvalidBefore <- forEraInEon era (pure id) $ \w -> - pure $ A.invalidBeforeTxBodyL w .~ convValidityLowerBound (txValidityLowerBound bc) + setInvalidBefore <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.invalidBeforeTxBodyL w .~ convValidityLowerBound (txValidityLowerBound bc) - setMint <- forEraInEon era (pure id) $ \w -> - pure $ A.mintTxBodyL w .~ convMintValue apiMintValue + setMint <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.mintTxBodyL w .~ convMintValue apiMintValue - setScriptIntegrityHash <- forEraInEon era (pure id) $ \w -> - pure $ A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData + setScriptIntegrityHash <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.scriptIntegrityHashTxBodyL w .~ getScriptIntegrityHash apiProtocolParameters languages sData - setCollateralInputs <- forEraInEon era (pure id) $ \w -> - pure $ A.collateralInputsTxBodyL w .~ collTxIns + setCollateralInputs <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.collateralInputsTxBodyL w .~ collTxIns - setReqSignerHashes <- forEraInEon era (pure id) $ \w -> - pure $ A.reqSignerHashesTxBodyL w .~ convExtraKeyWitnesses apiExtraKeyWitnesses + setReqSignerHashes <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.reqSignerHashesTxBodyL w .~ convExtraKeyWitnesses apiExtraKeyWitnesses - setReferenceInputs <- forEraInEon era (pure id) $ \w -> - pure $ A.referenceInputsTxBodyL w .~ refTxIns + setReferenceInputs <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.referenceInputsTxBodyL w .~ refTxIns - setCollateralReturn <- forEraInEon era (pure id) $ \w -> - pure $ A.collateralReturnTxBodyL w .~ returnCollateral + setCollateralReturn <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.collateralReturnTxBodyL w .~ returnCollateral - setTotalCollateral <- forEraInEon era (pure id) $ \w -> - pure $ A.totalCollateralTxBodyL w .~ totalCollateral + setTotalCollateral <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.totalCollateralTxBodyL w .~ totalCollateral let ledgerTxBody = mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData & A.certsTxBodyL sbe .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) - & modifyWith setUpdateProposal - & modifyWith setInvalidBefore - & modifyWith setMint - & modifyWith setScriptIntegrityHash - & modifyWith setCollateralInputs - & modifyWith setReqSignerHashes - & modifyWith setReferenceInputs - & modifyWith setCollateralReturn - & modifyWith setTotalCollateral + & ( appEndo $ mconcat + [ setUpdateProposal + , setInvalidBefore + , setMint + , setScriptIntegrityHash + , setCollateralInputs + , setReqSignerHashes + , setReferenceInputs + , setCollateralReturn + , setTotalCollateral + ] + ) -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 08e8b5fc30..d9a2884192 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -37,6 +37,9 @@ module Cardano.Api ( forEraInEonMaybe, forEraMaybeEon, maybeEon, + monoidForEraInEon, + monoidForEraInEonA, + inEonForShelleyBasedEra, inEonForShelleyBasedEraMaybe,