From 512a1ba65d50045110c32c0ac7ab55597978ed21 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 12:31:44 +1100 Subject: [PATCH 01/22] Simplify with lenses --- cardano-api/internal/Cardano/Api/TxBody.hs | 62 +++++++++++----------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 5a47ab872f..252100c2bf 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -169,7 +169,7 @@ import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Byron import Cardano.Api.Keys.Shelley -import qualified Cardano.Api.Ledger.Lens as L +import qualified Cardano.Api.Ledger.Lens as A import Cardano.Api.NetworkId import Cardano.Api.ProtocolParameters import qualified Cardano.Api.ReexposeLedger as Ledger @@ -1844,7 +1844,7 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData & L.certsTxBodyL .~ certs - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.updateTxBodyL .~ update sData = convScriptData sbe apiTxOuts apiScriptWitnesses @@ -1863,8 +1863,8 @@ createTransactionBody sbe txBodyContent = mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) pure $ ShelleyTxBody sbe ledgerTxBody @@ -1880,8 +1880,8 @@ createTransactionBody sbe txBodyContent = mkTxBody ShelleyBasedEraMary txBodyContent txAuxData & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.mintTxBodyL .~ convMintValue apiMintValue pure $ ShelleyTxBody sbe ledgerTxBody @@ -1901,14 +1901,14 @@ createTransactionBody sbe txBodyContent = convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData - & L.certsTxBodyL .~ certs - & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & L.collateralInputsTxBodyL .~ collTxIns - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash + & L.certsTxBodyL .~ certs + & L.updateTxBodyL .~ update + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & L.collateralInputsTxBodyL .~ collTxIns + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses + & L.mintTxBodyL .~ convMintValue apiMintValue + & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... pure $ ShelleyTxBody sbe @@ -1931,8 +1931,8 @@ createTransactionBody sbe txBodyContent = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.mintTxBodyL .~ convMintValue apiMintValue @@ -1960,8 +1960,8 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & L.certsTxBodyL .~ certs - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.mintTxBodyL .~ convMintValue apiMintValue @@ -2379,7 +2379,7 @@ fromLedgerTxValidityLowerBound sbe body = caseShelleyEraOnlyOrAllegraEraOnwards (const TxValidityNoLowerBound) (\w -> - let mInvalidBefore = body ^. L.vldtTxBodyL . L.invalidBeforeL in + let mInvalidBefore = body ^. L.vldtTxBodyL . A.invalidBeforeL in case mInvalidBefore of Nothing -> TxValidityNoLowerBound Just s -> TxValidityLowerBound w s @@ -2391,7 +2391,7 @@ fromLedgerTxValidityUpperBound -> Ledger.TxBody (ShelleyLedgerEra era) -> TxValidityUpperBound era fromLedgerTxValidityUpperBound sbe body = - TxValidityUpperBound sbe $ body ^. L.invalidHereAfterTxBodyL sbe + TxValidityUpperBound sbe $ body ^. A.invalidHereAfterTxBodyL sbe fromLedgerAuxiliaryData :: ShelleyBasedEra era @@ -2797,7 +2797,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraShelley (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.certsTxBodyL .~ convCertificates sbe txCertificates & L.updateTxBodyL .~ update - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound ) scripts_ TxBodyNoScriptData @@ -2834,8 +2834,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAllegra ShelleyTxBody sbe (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update ) scripts_ @@ -2874,8 +2874,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraMary ShelleyTxBody sbe (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update & L.mintTxBodyL .~ convMintValue txMintValue ) @@ -2922,8 +2922,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraAlonzo (mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData & L.collateralInputsTxBodyL .~ convCollateralTxIns txInsCollateral & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue @@ -3017,8 +3017,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraBabbage & L.collateralReturnTxBodyL .~ convReturnCollateral sbe txReturnCollateral & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.updateTxBodyL .~ update & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue @@ -3121,8 +3121,8 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway & L.collateralReturnTxBodyL .~ convReturnCollateral sbe txReturnCollateral & L.totalCollateralTxBodyL .~ convTotalCollateral txTotalCollateral & L.certsTxBodyL .~ convCertificates sbe txCertificates - & L.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound - & L.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound + & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound txValidityLowerBound + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe txValidityUpperBound & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash From a660043adc9655aced947ba4feef1b2332e612fd Mon Sep 17 00:00:00 2001 From: John Ky Date: Sat, 21 Oct 2023 14:15:03 +1100 Subject: [PATCH 02/22] New modifyWith function --- cardano-api/internal/Cardano/Api/Utils.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/cardano-api/internal/Cardano/Api/Utils.hs b/cardano-api/internal/Cardano/Api/Utils.hs index 84af05f123..67147d1d4f 100644 --- a/cardano-api/internal/Cardano/Api/Utils.hs +++ b/cardano-api/internal/Cardano/Api/Utils.hs @@ -5,7 +5,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} #if !defined(mingw32_HOST_OS) #define UNIX @@ -26,6 +25,7 @@ module Cardano.Api.Utils , renderEra , runParsecParser , textShow + , modifyWith -- ** CLI option parsing , bounded @@ -133,3 +133,10 @@ bounded t = eitherReader $ \s -> do when (i < fromIntegral (minBound @a)) $ Left $ t <> " must not be less than " <> show (minBound @a) when (i > fromIntegral (maxBound @a)) $ Left $ t <> " must not greater than " <> show (maxBound @a) pure (fromIntegral i) + +-- | Aids type inference. Use this function to ensure the value is a function +-- that modifies a value. +modifyWith :: () + => (a -> a) + -> (a -> a) +modifyWith = id From 4957f4f164dab11fa5a6bbae05bb88c722a90f3d Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 14:44:45 +1100 Subject: [PATCH 03/22] New setTxBodyFields binding --- cardano-api/internal/Cardano/Api/TxBody.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 252100c2bf..d77511245d 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1825,6 +1825,8 @@ createTransactionBody sbe txBodyContent = scripts = convScripts apiScriptWitnesses languages = convLanguages apiScriptWitnesses + setTxBodyFields = id + mkTxBody :: () => ShelleyBasedEra era -> TxBodyContent BuildTx era @@ -1843,6 +1845,7 @@ createTransactionBody sbe txBodyContent = update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let ledgerTxBody = mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData + & setTxBodyFields & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.updateTxBodyL .~ update @@ -1861,6 +1864,7 @@ createTransactionBody sbe txBodyContent = update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let ledgerTxBody = mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData + & setTxBodyFields & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) @@ -1878,6 +1882,7 @@ createTransactionBody sbe txBodyContent = update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let ledgerTxBody = mkTxBody ShelleyBasedEraMary txBodyContent txAuxData + & setTxBodyFields & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) @@ -1901,6 +1906,7 @@ createTransactionBody sbe txBodyContent = convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData + & setTxBodyFields & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) @@ -1929,6 +1935,7 @@ createTransactionBody sbe txBodyContent = convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData + & setTxBodyFields & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) @@ -1959,6 +1966,7 @@ createTransactionBody sbe txBodyContent = convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData + & setTxBodyFields & L.certsTxBodyL .~ certs & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) From cd602d62cb0ba03333ad8fa45e6589368c5059e6 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 15:19:33 +1100 Subject: [PATCH 04/22] Use setTxBodyFields more --- cardano-api/internal/Cardano/Api/TxBody.hs | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index d77511245d..9d89c2d5c4 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1804,6 +1804,7 @@ createTransactionBody -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) createTransactionBody sbe txBodyContent = + shelleyBasedEraConstraints sbe $ let apiTxOuts = txOuts txBodyContent apiScriptWitnesses = collectTxBodyScriptWitnesses sbe txBodyContent apiScriptValidity = txScriptValidity txBodyContent @@ -1825,7 +1826,9 @@ createTransactionBody sbe txBodyContent = scripts = convScripts apiScriptWitnesses languages = convLanguages apiScriptWitnesses - setTxBodyFields = id + setTxBodyFields txBody = txBody + & L.certsTxBodyL .~ certs + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) mkTxBody :: () => ShelleyBasedEra era @@ -1846,8 +1849,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData & setTxBodyFields - & L.certsTxBodyL .~ certs - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.updateTxBodyL .~ update sData = convScriptData sbe apiTxOuts apiScriptWitnesses @@ -1865,10 +1866,8 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData & setTxBodyFields - & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) pure $ ShelleyTxBody sbe ledgerTxBody @@ -1883,10 +1882,8 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraMary txBodyContent txAuxData & setTxBodyFields - & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.mintTxBodyL .~ convMintValue apiMintValue pure $ ShelleyTxBody sbe ledgerTxBody @@ -1907,10 +1904,8 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData & setTxBodyFields - & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.mintTxBodyL .~ convMintValue apiMintValue @@ -1936,10 +1931,8 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & L.certsTxBodyL .~ certs & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.mintTxBodyL .~ convMintValue apiMintValue @@ -1967,9 +1960,7 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields - & L.certsTxBodyL .~ certs & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.mintTxBodyL .~ convMintValue apiMintValue From ece0f5e526a03bfcda1553c2e98835a800003e82 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 15:34:03 +1100 Subject: [PATCH 05/22] Introduce do block --- cardano-api/internal/Cardano/Api/TxBody.hs | 80 +++++++++++----------- 1 file changed, 40 insertions(+), 40 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 9d89c2d5c4..d605d4b199 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1804,46 +1804,46 @@ createTransactionBody -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) createTransactionBody sbe txBodyContent = - shelleyBasedEraConstraints sbe $ - let apiTxOuts = txOuts txBodyContent - apiScriptWitnesses = collectTxBodyScriptWitnesses sbe txBodyContent - apiScriptValidity = txScriptValidity txBodyContent - apiMintValue = txMintValue txBodyContent - apiProtocolParameters = txProtocolParams txBodyContent - apiCollateralTxIns = txInsCollateral txBodyContent - apiReferenceInputs = txInsReference txBodyContent - apiExtraKeyWitnesses = txExtraKeyWits txBodyContent - apiReturnCollateral = txReturnCollateral txBodyContent - apiTotalCollateral = txTotalCollateral txBodyContent - - -- Ledger types - collTxIns = convCollateralTxIns apiCollateralTxIns - refTxIns = convReferenceInputs apiReferenceInputs - returnCollateral = convReturnCollateral sbe apiReturnCollateral - totalCollateral = convTotalCollateral apiTotalCollateral - certs = convCertificates sbe $ txCertificates txBodyContent - txAuxData = toAuxiliaryData sbe (txMetadata txBodyContent) (txAuxScripts txBodyContent) - scripts = convScripts apiScriptWitnesses - languages = convLanguages apiScriptWitnesses - - setTxBodyFields txBody = txBody - & L.certsTxBodyL .~ certs - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - - mkTxBody :: () - => ShelleyBasedEra era - -> TxBodyContent BuildTx era - -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) - -> L.TxBody (ShelleyLedgerEra era) - mkTxBody sbe' bc = - mkCommonTxBody - sbe' - (txIns bc) - (txOuts bc) - (txFee bc) - (txWithdrawals bc) - - in case sbe of + shelleyBasedEraConstraints sbe $ do + let apiTxOuts = txOuts txBodyContent + apiScriptWitnesses = collectTxBodyScriptWitnesses sbe txBodyContent + apiScriptValidity = txScriptValidity txBodyContent + apiMintValue = txMintValue txBodyContent + apiProtocolParameters = txProtocolParams txBodyContent + apiCollateralTxIns = txInsCollateral txBodyContent + apiReferenceInputs = txInsReference txBodyContent + apiExtraKeyWitnesses = txExtraKeyWits txBodyContent + apiReturnCollateral = txReturnCollateral txBodyContent + apiTotalCollateral = txTotalCollateral txBodyContent + + -- Ledger types + collTxIns = convCollateralTxIns apiCollateralTxIns + refTxIns = convReferenceInputs apiReferenceInputs + returnCollateral = convReturnCollateral sbe apiReturnCollateral + totalCollateral = convTotalCollateral apiTotalCollateral + certs = convCertificates sbe $ txCertificates txBodyContent + txAuxData = toAuxiliaryData sbe (txMetadata txBodyContent) (txAuxScripts txBodyContent) + scripts = convScripts apiScriptWitnesses + languages = convLanguages apiScriptWitnesses + + setTxBodyFields txBody = txBody + & L.certsTxBodyL .~ certs + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + + mkTxBody :: () + => ShelleyBasedEra era + -> TxBodyContent BuildTx era + -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) + -> L.TxBody (ShelleyLedgerEra era) + mkTxBody sbe' bc = + mkCommonTxBody + sbe' + (txIns bc) + (txOuts bc) + (txFee bc) + (txWithdrawals bc) + + case sbe of ShelleyBasedEraShelley -> do update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let ledgerTxBody = From a0385ade7920e86b34e2d27ff5479146f3b3feff Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 16:22:40 +1100 Subject: [PATCH 06/22] Set update proposal in common area --- .../internal/Cardano/Api/Ledger/Lens.hs | 6 +++++ cardano-api/internal/Cardano/Api/TxBody.hs | 24 ++++++++++--------- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs index 7aa58f28cb..707cc4a17c 100644 --- a/cardano-api/internal/Cardano/Api/Ledger/Lens.hs +++ b/cardano-api/internal/Cardano/Api/Ledger/Lens.hs @@ -11,16 +11,19 @@ module Cardano.Api.Ledger.Lens , invalidBeforeTxBodyL , invalidHereAfterTxBodyL , ttlAsInvalidHereAfterTxBodyL + , apiUpdateTxBodyL ) where import Cardano.Api.Eon.AllegraEraOnwards 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.Api as L import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (..)) +import qualified Cardano.Ledger.Shelley.PParams as L import Lens.Micro @@ -95,3 +98,6 @@ 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 diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index d605d4b199..6429c32d8c 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -19,6 +19,7 @@ {- HLINT ignore "Avoid lambda using `infix`" -} {- HLINT ignore "Redundant flip" -} +{- HLINT ignore "Use let" -} {- HLINT ignore "Use section" -} -- | Transaction bodies @@ -1800,7 +1801,7 @@ instance Error TxBodyError where "Errors in protocol parameters conversion: " ++ displayError ppces createTransactionBody - :: ShelleyBasedEra era + :: forall era. ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) createTransactionBody sbe txBodyContent = @@ -1826,9 +1827,19 @@ createTransactionBody sbe txBodyContent = scripts = convScripts apiScriptWitnesses languages = convLanguages apiScriptWitnesses + setUpdateProposal <- + caseShelleyToBabbageOrConwayEraOnwards + (\w -> do + update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) + pure $ A.apiUpdateTxBodyL w .~ update) + (const $ pure id) + sbe + + let setTxBodyFields :: Ledger.TxBody (ShelleyLedgerEra era) -> Ledger.TxBody (ShelleyLedgerEra era) setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & setUpdateProposal mkTxBody :: () => ShelleyBasedEra era @@ -1845,11 +1856,10 @@ createTransactionBody sbe txBodyContent = case sbe of ShelleyBasedEraShelley -> do - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let ledgerTxBody = mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData & setTxBodyFields - & L.updateTxBodyL .~ update + -- & setUpdateProposal sData = convScriptData sbe apiTxOuts apiScriptWitnesses @@ -1862,11 +1872,9 @@ createTransactionBody sbe txBodyContent = ShelleyBasedEraAllegra -> do let aOn = AllegraEraOnwardsAllegra - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let ledgerTxBody = mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData & setTxBodyFields - & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) pure $ ShelleyTxBody sbe @@ -1878,11 +1886,9 @@ createTransactionBody sbe txBodyContent = ShelleyBasedEraMary -> do let aOn = AllegraEraOnwardsMary - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let ledgerTxBody = mkTxBody ShelleyBasedEraMary txBodyContent txAuxData & setTxBodyFields - & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) & L.mintTxBodyL .~ convMintValue apiMintValue pure $ ShelleyTxBody sbe @@ -1894,7 +1900,6 @@ createTransactionBody sbe txBodyContent = ShelleyBasedEraAlonzo -> do let aOn = AllegraEraOnwardsAlonzo - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of @@ -1904,7 +1909,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData & setTxBodyFields - & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses @@ -1921,7 +1925,6 @@ createTransactionBody sbe txBodyContent = ShelleyBasedEraBabbage -> do let aOn = AllegraEraOnwardsBabbage - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of @@ -1931,7 +1934,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & L.updateTxBodyL .~ update & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses From 6070289e7da0a5a294ff81ba9dddb83e709f54d2 Mon Sep 17 00:00:00 2001 From: John Ky Date: Sat, 21 Oct 2023 14:19:22 +1100 Subject: [PATCH 07/22] Set update proposal in common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 6429c32d8c..0621504704 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1829,9 +1829,7 @@ createTransactionBody sbe txBodyContent = setUpdateProposal <- caseShelleyToBabbageOrConwayEraOnwards - (\w -> do - update <- convTxUpdateProposal sbe (txUpdateProposal txBodyContent) - pure $ A.apiUpdateTxBodyL w .~ update) + (\w -> (A.apiUpdateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal txBodyContent)) (const $ pure id) sbe @@ -1839,7 +1837,7 @@ createTransactionBody sbe txBodyContent = setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & setUpdateProposal + & modifyWith setUpdateProposal mkTxBody :: () => ShelleyBasedEra era From df44de9db2edd55783eedbc95545c0436ab043a2 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 16:23:00 +1100 Subject: [PATCH 08/22] Move setting of invalidBefore to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 29 +++++++++------------- 1 file changed, 12 insertions(+), 17 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 0621504704..4f563fcb38 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1833,11 +1833,17 @@ createTransactionBody sbe txBodyContent = (const $ pure id) sbe - let setTxBodyFields :: Ledger.TxBody (ShelleyLedgerEra era) -> Ledger.TxBody (ShelleyLedgerEra era) - setTxBodyFields txBody = txBody + setInvalidBefore <- + caseShelleyEraOnlyOrAllegraEraOnwards + (const $ pure id) + (\aOn -> pure $ A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent)) + sbe + + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & modifyWith setUpdateProposal + & modifyWith setInvalidBefore mkTxBody :: () => ShelleyBasedEra era @@ -1857,7 +1863,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData & setTxBodyFields - -- & setUpdateProposal sData = convScriptData sbe apiTxOuts apiScriptWitnesses @@ -1869,11 +1874,9 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraAllegra -> do - let aOn = AllegraEraOnwardsAllegra let ledgerTxBody = mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData & setTxBodyFields - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) pure $ ShelleyTxBody sbe ledgerTxBody @@ -1883,11 +1886,9 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraMary -> do - let aOn = AllegraEraOnwardsMary let ledgerTxBody = mkTxBody ShelleyBasedEraMary txBodyContent txAuxData & setTxBodyFields - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) & L.mintTxBodyL .~ convMintValue apiMintValue pure $ ShelleyTxBody sbe ledgerTxBody @@ -1897,7 +1898,6 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraAlonzo -> do - let aOn = AllegraEraOnwardsAlonzo let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of @@ -1907,11 +1907,10 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData & setTxBodyFields - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) - & L.collateralInputsTxBodyL .~ collTxIns - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash + & L.collateralInputsTxBodyL .~ collTxIns + & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses + & L.mintTxBodyL .~ convMintValue apiMintValue + & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... pure $ ShelleyTxBody sbe @@ -1922,7 +1921,6 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraBabbage -> do - let aOn = AllegraEraOnwardsBabbage let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of @@ -1932,7 +1930,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.mintTxBodyL .~ convMintValue apiMintValue @@ -1950,7 +1947,6 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraConway -> do - let aOn = AllegraEraOnwardsConway let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of @@ -1960,7 +1956,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields - & A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent) & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.mintTxBodyL .~ convMintValue apiMintValue From 66edacfc538b81c24f365a58d0ed6dc8ad1e1cc9 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 16:27:07 +1100 Subject: [PATCH 09/22] Move sData to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 4f563fcb38..9b07aef1dd 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1826,6 +1826,7 @@ createTransactionBody sbe txBodyContent = txAuxData = toAuxiliaryData sbe (txMetadata txBodyContent) (txAuxScripts txBodyContent) scripts = convScripts apiScriptWitnesses languages = convLanguages apiScriptWitnesses + sData = convScriptData sbe apiTxOuts apiScriptWitnesses setUpdateProposal <- caseShelleyToBabbageOrConwayEraOnwards @@ -1864,8 +1865,6 @@ createTransactionBody sbe txBodyContent = mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData & setTxBodyFields - sData = convScriptData sbe apiTxOuts apiScriptWitnesses - pure $ ShelleyTxBody sbe ledgerTxBody scripts @@ -1881,7 +1880,7 @@ createTransactionBody sbe txBodyContent = pure $ ShelleyTxBody sbe ledgerTxBody scripts - (convScriptData sbe apiTxOuts apiScriptWitnesses) + sData txAuxData apiScriptValidity @@ -1893,12 +1892,11 @@ createTransactionBody sbe txBodyContent = pure $ ShelleyTxBody sbe ledgerTxBody scripts - (convScriptData sbe apiTxOuts apiScriptWitnesses) + sData txAuxData apiScriptValidity ShelleyBasedEraAlonzo -> do - let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of TxBodyNoScriptData -> SNothing @@ -1916,12 +1914,11 @@ createTransactionBody sbe txBodyContent = pure $ ShelleyTxBody sbe ledgerTxBody scripts - (convScriptData sbe apiTxOuts apiScriptWitnesses) + sData txAuxData apiScriptValidity ShelleyBasedEraBabbage -> do - let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of TxBodyNoScriptData -> SNothing @@ -1947,7 +1944,6 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraConway -> do - let sData = convScriptData sbe apiTxOuts apiScriptWitnesses let scriptIntegrityHash = case sData of TxBodyNoScriptData -> SNothing From c27a5128d2644165d08973ca9e51be7ae4bfbd5f Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 16:34:32 +1100 Subject: [PATCH 10/22] Move setMint to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 9b07aef1dd..b529e5758a 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1840,11 +1840,18 @@ createTransactionBody sbe txBodyContent = (\aOn -> pure $ A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent)) sbe + setMint <- + caseShelleyToAllegraOrMaryEraOnwards + (const $ pure id) + (const $ pure $ L.mintTxBodyL .~ convMintValue apiMintValue) + sbe + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & modifyWith setUpdateProposal & modifyWith setInvalidBefore + & modifyWith setMint mkTxBody :: () => ShelleyBasedEra era @@ -1888,7 +1895,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraMary txBodyContent txAuxData & setTxBodyFields - & L.mintTxBodyL .~ convMintValue apiMintValue pure $ ShelleyTxBody sbe ledgerTxBody scripts @@ -1907,7 +1913,6 @@ createTransactionBody sbe txBodyContent = & setTxBodyFields & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... @@ -1929,7 +1934,6 @@ createTransactionBody sbe txBodyContent = & setTxBodyFields & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral @@ -1954,7 +1958,6 @@ createTransactionBody sbe txBodyContent = & setTxBodyFields & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.mintTxBodyL .~ convMintValue apiMintValue & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral From 56de35f4691b276770c9f775eab2927ceb7fc6cc Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 16:51:28 +1100 Subject: [PATCH 11/22] New getScriptIntegrityHash function --- cardano-api/internal/Cardano/Api/TxBody.hs | 28 ++++++++++------------ 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index b529e5758a..d5c053b46e 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1903,11 +1903,7 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraAlonzo -> do - let scriptIntegrityHash = - case sData of - TxBodyNoScriptData -> SNothing - TxBodyScriptData w datums redeemers -> - convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages + let scriptIntegrityHash = getScriptIntegrityHash apiProtocolParameters languages sData let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData & setTxBodyFields @@ -1924,11 +1920,7 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraBabbage -> do - let scriptIntegrityHash = - case sData of - TxBodyNoScriptData -> SNothing - TxBodyScriptData w datums redeemers -> - convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages + let scriptIntegrityHash = getScriptIntegrityHash apiProtocolParameters languages sData let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields @@ -1948,11 +1940,7 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraConway -> do - let scriptIntegrityHash = - case sData of - TxBodyNoScriptData -> SNothing - TxBodyScriptData w datums redeemers -> - convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages + let scriptIntegrityHash = getScriptIntegrityHash apiProtocolParameters languages sData let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields @@ -1971,6 +1959,16 @@ createTransactionBody sbe txBodyContent = txAuxData apiScriptValidity +getScriptIntegrityHash :: () + => BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era)) + -> Set Alonzo.Language + -> TxBodyScriptData era + -> StrictMaybe (L.ScriptIntegrityHash (Ledger.EraCrypto (ShelleyLedgerEra era))) +getScriptIntegrityHash apiProtocolParameters languages = \case + TxBodyNoScriptData -> SNothing + TxBodyScriptData w datums redeemers -> + convPParamsToScriptIntegrityHash w apiProtocolParameters redeemers datums languages + validateTxBodyContent :: ShelleyBasedEra era -> TxBodyContent BuildTx era From 7e367af4baa2cb175f4e0184e74e88844df3f7da Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:04:20 +1100 Subject: [PATCH 12/22] Move setScriptIntegrityHash to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index d5c053b46e..bdd45bddda 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1846,12 +1846,19 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.mintTxBodyL .~ convMintValue apiMintValue) sbe + setScriptIntegrityHash <- + caseShelleyToMaryOrAlonzoEraOnwards + (const $ pure id) + (const $ pure $ L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData) + sbe + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) & modifyWith setUpdateProposal & modifyWith setInvalidBefore & modifyWith setMint + & modifyWith setScriptIntegrityHash mkTxBody :: () => ShelleyBasedEra era @@ -1903,13 +1910,11 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraAlonzo -> do - let scriptIntegrityHash = getScriptIntegrityHash apiProtocolParameters languages sData let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData & setTxBodyFields & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... pure $ ShelleyTxBody sbe @@ -1920,13 +1925,11 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraBabbage -> do - let scriptIntegrityHash = getScriptIntegrityHash apiProtocolParameters languages sData let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral @@ -1940,13 +1943,11 @@ createTransactionBody sbe txBodyContent = apiScriptValidity ShelleyBasedEraConway -> do - let scriptIntegrityHash = getScriptIntegrityHash apiProtocolParameters languages sData let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses - & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral From 38087ab57a865e8eaf975d10d775c7e87ce7f534 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:12:19 +1100 Subject: [PATCH 13/22] Add missing constraints --- .../Cardano/Api/Eon/AlonzoEraOnwards.hs | 2 + .../Cardano/Api/Eon/BabbageEraOnly.hs | 57 ++++++++++++++++++- .../Cardano/Api/Eon/BabbageEraOnwards.hs | 2 + .../Cardano/Api/Eon/ConwayEraOnwards.hs | 2 + 4 files changed, 62 insertions(+), 1 deletion(-) diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index 43e3ca61ab..faee076dca 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -79,6 +79,7 @@ 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) @@ -90,6 +91,7 @@ type AlonzoEraOnwardsConstraints era = , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs index e9acf19c6c..cc73715877 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnly.hs @@ -1,10 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Eon.BabbageEraOnly ( BabbageEraOnly(..) @@ -14,8 +16,30 @@ module Cardano.Api.Eon.BabbageEraOnly , BabbageEraOnlyConstraints ) where +import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras.Core +import Cardano.Api.Modes +import Cardano.Api.Query.Types +import Cardano.Binary +import qualified Cardano.Crypto.Hash.Blake2b as Blake2b +import qualified Cardano.Crypto.Hash.Class as C +import qualified Cardano.Crypto.VRF as C +import qualified Cardano.Ledger.Alonzo.Language as L +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.BaseTypes as L +import qualified Cardano.Ledger.Core as L +import qualified Cardano.Ledger.Mary.Value as L +import qualified Cardano.Ledger.SafeHash as L +import qualified Cardano.Ledger.UTxO as L +import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus +import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus +import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus + +import Data.Aeson import Data.Typeable (Typeable) data BabbageEraOnly era where @@ -39,7 +63,38 @@ instance ToCardanoEra BabbageEraOnly where BabbageEraOnlyBabbage -> BabbageEra type BabbageEraOnlyConstraints era = - ( IsCardanoEra era + ( L.AlonzoEraTxOut (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) + , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.AlonzoEraTxOut (ShelleyLedgerEra era) + , L.BabbageEraPParams (ShelleyLedgerEra era) + , L.BabbageEraTxBody (ShelleyLedgerEra era) + , L.BabbageEraTxOut (ShelleyLedgerEra era) + , L.Crypto (L.EraCrypto (ShelleyLedgerEra era)) + , L.Era (ShelleyLedgerEra era) + , L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto + , L.EraPlutusContext 'L.PlutusV1 (ShelleyLedgerEra era) + , L.EraPParams (ShelleyLedgerEra era) + , L.EraTx (ShelleyLedgerEra era) + , L.EraTxBody (ShelleyLedgerEra era) + , L.EraUTxO (ShelleyLedgerEra era) + , L.ExtendedUTxO (ShelleyLedgerEra era) + , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) + , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) + , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) + , L.ShelleyEraTxBody (ShelleyLedgerEra era) + , L.ShelleyEraTxCert (ShelleyLedgerEra era) + , L.Value (ShelleyLedgerEra era) ~ L.MaryValue L.StandardCrypto + + , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era)) + , FromCBOR (DebugLedgerState era) + , IsCardanoEra era + , IsShelleyBasedEra era + , ToJSON (DebugLedgerState era) , Typeable era ) diff --git a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs index 6bc8aa9062..06695f3778 100644 --- a/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/BabbageEraOnwards.hs @@ -71,6 +71,7 @@ type BabbageEraOnwardsConstraints era = , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.AlonzoEraTxOut (ShelleyLedgerEra era) , L.BabbageEraPParams (ShelleyLedgerEra era) , L.BabbageEraTxBody (ShelleyLedgerEra era) , L.BabbageEraTxOut (ShelleyLedgerEra era) @@ -84,6 +85,7 @@ type BabbageEraOnwardsConstraints era = , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 5d97ea0247..d10a88420b 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -72,6 +72,7 @@ type ConwayEraOnwardsConstraints era = , Consensus.PraosProtocolSupportsNode (ConsensusProtocol era) , Consensus.ShelleyCompatible (ConsensusProtocol era) (ShelleyLedgerEra era) , L.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224 + , L.AlonzoEraTxOut (ShelleyLedgerEra era) , L.BabbageEraTxBody (ShelleyLedgerEra era) , L.ConwayEraGov (ShelleyLedgerEra era) , L.ConwayEraPParams (ShelleyLedgerEra era) @@ -88,6 +89,7 @@ type ConwayEraOnwardsConstraints era = , L.EraUTxO (ShelleyLedgerEra era) , L.ExtendedUTxO (ShelleyLedgerEra era) , L.HashAnnotated (L.TxBody (ShelleyLedgerEra era)) L.EraIndependentTxBody L.StandardCrypto + , L.MaryEraTxBody (ShelleyLedgerEra era) , L.Script (ShelleyLedgerEra era) ~ L.AlonzoScript (ShelleyLedgerEra era) , L.ScriptsNeeded (ShelleyLedgerEra era) ~ L.AlonzoScriptsNeeded (ShelleyLedgerEra era) , L.ShelleyEraTxBody (ShelleyLedgerEra era) From 3cd65201de76072516bdf74be5696912cf8863c3 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:13:46 +1100 Subject: [PATCH 14/22] Move setCollateralInputs to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index bdd45bddda..c96a7192c6 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1852,6 +1852,12 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.scriptIntegrityHashTxBodyL .~ getScriptIntegrityHash apiProtocolParameters languages sData) sbe + setCollateralInputs <- + caseShelleyToMaryOrAlonzoEraOnwards + (const $ pure id) + (const $ pure $ L.collateralInputsTxBodyL .~ collTxIns) + sbe + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) @@ -1859,6 +1865,7 @@ createTransactionBody sbe txBodyContent = & modifyWith setInvalidBefore & modifyWith setMint & modifyWith setScriptIntegrityHash + & modifyWith setCollateralInputs mkTxBody :: () => ShelleyBasedEra era @@ -1913,7 +1920,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData & setTxBodyFields - & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... @@ -1928,7 +1934,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral @@ -1946,7 +1951,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields - & L.collateralInputsTxBodyL .~ collTxIns & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral From 712a22159910fb821662794ff46f9837029d9441 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:19:41 +1100 Subject: [PATCH 15/22] Move setReqSignerHashes to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index c96a7192c6..e8d460047f 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1858,6 +1858,12 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.collateralInputsTxBodyL .~ collTxIns) sbe + setReqSignerHashes <- + caseShelleyToMaryOrAlonzoEraOnwards + (const $ pure id) + (const $ pure $ L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses) + sbe + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) @@ -1866,6 +1872,7 @@ createTransactionBody sbe txBodyContent = & modifyWith setMint & modifyWith setScriptIntegrityHash & modifyWith setCollateralInputs + & modifyWith setReqSignerHashes mkTxBody :: () => ShelleyBasedEra era @@ -1920,7 +1927,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData & setTxBodyFields - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... pure $ ShelleyTxBody sbe @@ -1934,7 +1940,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral @@ -1951,7 +1956,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields - & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral From 6dae58507e3a500a9391befad93ea6d83d4e13d5 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:21:47 +1100 Subject: [PATCH 16/22] Move setReferenceInputs to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index e8d460047f..8aeb8d6a0a 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1864,6 +1864,12 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses apiExtraKeyWitnesses) sbe + setReferenceInputs <- + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ pure id) + (const $ pure $ L.referenceInputsTxBodyL .~ refTxIns) + sbe + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) @@ -1873,6 +1879,7 @@ createTransactionBody sbe txBodyContent = & modifyWith setScriptIntegrityHash & modifyWith setCollateralInputs & modifyWith setReqSignerHashes + & modifyWith setReferenceInputs mkTxBody :: () => ShelleyBasedEra era @@ -1940,7 +1947,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral -- TODO: NetworkId for hardware wallets. We don't always want this @@ -1956,7 +1962,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields - & L.referenceInputsTxBodyL .~ refTxIns & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral -- TODO: NetworkId for hardware wallets. We don't always want this From b7d0a26b43f32529bada829a5a68ec5fd73a7a94 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:24:17 +1100 Subject: [PATCH 17/22] Move setCollateralReturn to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 8aeb8d6a0a..12df581747 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1870,6 +1870,12 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.referenceInputsTxBodyL .~ refTxIns) sbe + setCollateralReturn <- + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ pure id) + (const $ pure $ L.collateralReturnTxBodyL .~ returnCollateral) + sbe + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) @@ -1880,6 +1886,7 @@ createTransactionBody sbe txBodyContent = & modifyWith setCollateralInputs & modifyWith setReqSignerHashes & modifyWith setReferenceInputs + & modifyWith setCollateralReturn mkTxBody :: () => ShelleyBasedEra era @@ -1947,7 +1954,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... @@ -1962,7 +1968,6 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields - & L.collateralReturnTxBodyL .~ returnCollateral & L.totalCollateralTxBodyL .~ totalCollateral -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... From 63576738ae6572ef64002010f2fd1a47f81cf9ac Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:25:53 +1100 Subject: [PATCH 18/22] Move setTotalCollateral to common area --- cardano-api/internal/Cardano/Api/TxBody.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 12df581747..7df3475100 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1876,6 +1876,12 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.collateralReturnTxBodyL .~ returnCollateral) sbe + setTotalCollateral <- + caseShelleyToAlonzoOrBabbageEraOnwards + (const $ pure id) + (const $ pure $ L.totalCollateralTxBodyL .~ totalCollateral) + sbe + let setTxBodyFields txBody = txBody & L.certsTxBodyL .~ certs & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) @@ -1887,6 +1893,7 @@ createTransactionBody sbe txBodyContent = & modifyWith setReqSignerHashes & modifyWith setReferenceInputs & modifyWith setCollateralReturn + & modifyWith setTotalCollateral mkTxBody :: () => ShelleyBasedEra era @@ -1954,7 +1961,7 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData & setTxBodyFields - & L.totalCollateralTxBodyL .~ totalCollateral + -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... pure $ ShelleyTxBody sbe @@ -1968,7 +1975,7 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody ShelleyBasedEraConway txBodyContent txAuxData & setTxBodyFields - & L.totalCollateralTxBodyL .~ totalCollateral + -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... pure $ ShelleyTxBody sbe From 93d9653776e1d6a246da456f1f48dced515ce49e Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:28:41 +1100 Subject: [PATCH 19/22] Remove redundant case --- cardano-api/internal/Cardano/Api/TxBody.hs | 80 ++-------------------- 1 file changed, 6 insertions(+), 74 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 7df3475100..c4247ea638 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1908,82 +1908,14 @@ createTransactionBody sbe txBodyContent = (txFee bc) (txWithdrawals bc) - case sbe of - ShelleyBasedEraShelley -> do - let ledgerTxBody = - mkTxBody ShelleyBasedEraShelley txBodyContent txAuxData - & setTxBodyFields - - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity - - ShelleyBasedEraAllegra -> do - let ledgerTxBody = - mkTxBody ShelleyBasedEraAllegra txBodyContent txAuxData - & setTxBodyFields - - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity + let ledgerTxBody = + mkTxBody sbe txBodyContent txAuxData + & setTxBodyFields - ShelleyBasedEraMary -> do - let ledgerTxBody = - mkTxBody ShelleyBasedEraMary txBodyContent txAuxData - & setTxBodyFields - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity + -- TODO: NetworkId for hardware wallets. We don't always want this + -- & L.networkIdTxBodyL .~ ... - ShelleyBasedEraAlonzo -> do - let ledgerTxBody = - mkTxBody ShelleyBasedEraAlonzo txBodyContent txAuxData - & setTxBodyFields - -- TODO: NetworkId for hardware wallets. We don't always want this - -- & L.networkIdTxBodyL .~ ... - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity - - ShelleyBasedEraBabbage -> do - let ledgerTxBody = - mkTxBody ShelleyBasedEraBabbage txBodyContent txAuxData - & setTxBodyFields - - -- TODO: NetworkId for hardware wallets. We don't always want this - -- & L.networkIdTxBodyL .~ ... - pure $ ShelleyTxBody sbe - ledgerTxBody - scripts - sData - txAuxData - apiScriptValidity - - ShelleyBasedEraConway -> do - let ledgerTxBody = - mkTxBody ShelleyBasedEraConway txBodyContent txAuxData - & setTxBodyFields - - -- 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 scripts sData txAuxData apiScriptValidity getScriptIntegrityHash :: () => BuildTxWith BuildTx (Maybe (LedgerProtocolParameters era)) From 3718a6d675d80c2bc6aac038a69f259f24840a92 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:30:22 +1100 Subject: [PATCH 20/22] Inline setTxBodyFields --- cardano-api/internal/Cardano/Api/TxBody.hs | 27 ++++++++++------------ 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index c4247ea638..964345adb7 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1882,20 +1882,7 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.totalCollateralTxBodyL .~ totalCollateral) sbe - let setTxBodyFields txBody = txBody - & L.certsTxBodyL .~ certs - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) - & modifyWith setUpdateProposal - & modifyWith setInvalidBefore - & modifyWith setMint - & modifyWith setScriptIntegrityHash - & modifyWith setCollateralInputs - & modifyWith setReqSignerHashes - & modifyWith setReferenceInputs - & modifyWith setCollateralReturn - & modifyWith setTotalCollateral - - mkTxBody :: () + let mkTxBody :: () => ShelleyBasedEra era -> TxBodyContent BuildTx era -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) @@ -1910,7 +1897,17 @@ createTransactionBody sbe txBodyContent = let ledgerTxBody = mkTxBody sbe txBodyContent txAuxData - & setTxBodyFields + & L.certsTxBodyL .~ certs + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & modifyWith setUpdateProposal + & modifyWith setInvalidBefore + & modifyWith setMint + & modifyWith setScriptIntegrityHash + & modifyWith setCollateralInputs + & modifyWith setReqSignerHashes + & modifyWith setReferenceInputs + & modifyWith setCollateralReturn + & modifyWith setTotalCollateral -- TODO: NetworkId for hardware wallets. We don't always want this -- & L.networkIdTxBodyL .~ ... From 64d0e5eb6b23156fb993e54a8cfed0423dfe603d Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 20:59:58 +1100 Subject: [PATCH 21/22] Inline mkTxBody --- cardano-api/internal/Cardano/Api/TxBody.hs | 47 ++++++++-------------- 1 file changed, 17 insertions(+), 30 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 964345adb7..d9e2613ffd 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1804,40 +1804,40 @@ createTransactionBody :: forall era. ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) -createTransactionBody sbe txBodyContent = +createTransactionBody sbe bc = shelleyBasedEraConstraints sbe $ do - let apiTxOuts = txOuts txBodyContent - apiScriptWitnesses = collectTxBodyScriptWitnesses sbe txBodyContent - apiScriptValidity = txScriptValidity txBodyContent - apiMintValue = txMintValue txBodyContent - apiProtocolParameters = txProtocolParams txBodyContent - apiCollateralTxIns = txInsCollateral txBodyContent - apiReferenceInputs = txInsReference txBodyContent - apiExtraKeyWitnesses = txExtraKeyWits txBodyContent - apiReturnCollateral = txReturnCollateral txBodyContent - apiTotalCollateral = txTotalCollateral txBodyContent + let apiTxOuts = txOuts bc + apiScriptWitnesses = collectTxBodyScriptWitnesses sbe bc + apiScriptValidity = txScriptValidity bc + apiMintValue = txMintValue bc + apiProtocolParameters = txProtocolParams bc + apiCollateralTxIns = txInsCollateral bc + apiReferenceInputs = txInsReference bc + apiExtraKeyWitnesses = txExtraKeyWits bc + apiReturnCollateral = txReturnCollateral bc + apiTotalCollateral = txTotalCollateral bc -- Ledger types collTxIns = convCollateralTxIns apiCollateralTxIns refTxIns = convReferenceInputs apiReferenceInputs returnCollateral = convReturnCollateral sbe apiReturnCollateral totalCollateral = convTotalCollateral apiTotalCollateral - certs = convCertificates sbe $ txCertificates txBodyContent - txAuxData = toAuxiliaryData sbe (txMetadata txBodyContent) (txAuxScripts txBodyContent) + certs = convCertificates sbe $ txCertificates bc + txAuxData = toAuxiliaryData sbe (txMetadata bc) (txAuxScripts bc) scripts = convScripts apiScriptWitnesses languages = convLanguages apiScriptWitnesses sData = convScriptData sbe apiTxOuts apiScriptWitnesses setUpdateProposal <- caseShelleyToBabbageOrConwayEraOnwards - (\w -> (A.apiUpdateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal txBodyContent)) + (\w -> (A.apiUpdateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc)) (const $ pure id) sbe setInvalidBefore <- caseShelleyEraOnlyOrAllegraEraOnwards (const $ pure id) - (\aOn -> pure $ A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound txBodyContent)) + (\aOn -> pure $ A.invalidBeforeTxBodyL aOn .~ convValidityLowerBound (txValidityLowerBound bc)) sbe setMint <- @@ -1882,23 +1882,10 @@ createTransactionBody sbe txBodyContent = (const $ pure $ L.totalCollateralTxBodyL .~ totalCollateral) sbe - let mkTxBody :: () - => ShelleyBasedEra era - -> TxBodyContent BuildTx era - -> Maybe (L.TxAuxData (ShelleyLedgerEra era)) - -> L.TxBody (ShelleyLedgerEra era) - mkTxBody sbe' bc = - mkCommonTxBody - sbe' - (txIns bc) - (txOuts bc) - (txFee bc) - (txWithdrawals bc) - let ledgerTxBody = - mkTxBody sbe txBodyContent txAuxData + mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData & L.certsTxBodyL .~ certs - & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound txBodyContent) + & A.invalidHereAfterTxBodyL sbe .~ convValidityUpperBound sbe (txValidityUpperBound bc) & modifyWith setUpdateProposal & modifyWith setInvalidBefore & modifyWith setMint From 2aeb30b8649e6f30822a219b90aed8d878790b41 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 20 Oct 2023 17:48:21 +1100 Subject: [PATCH 22/22] Remove unnecessary forall --- cardano-api/internal/Cardano/Api/TxBody.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index d9e2613ffd..5763e4a197 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1800,8 +1800,8 @@ instance Error TxBodyError where displayError (TxBodyProtocolParamsConversionError ppces) = "Errors in protocol parameters conversion: " ++ displayError ppces -createTransactionBody - :: forall era. ShelleyBasedEra era +createTransactionBody :: () + => ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) createTransactionBody sbe bc =