From fef1db732a12316011649c6186c04858d1b9f4ac Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 28 Mar 2023 22:03:21 +1100 Subject: [PATCH] Combinators for TxBodyContent and related types --- .../Benchmarking/GeneratorTx/SizedMetadata.hs | 31 ++- .../src/Cardano/TxGenerator/Genesis.hs | 25 +-- .../src/Cardano/TxGenerator/Tx.hs | 28 +-- cardano-api/src/Cardano/Api.hs | 26 +++ cardano-api/src/Cardano/Api/Fees.hs | 11 +- cardano-api/src/Cardano/Api/TxBody.hs | 179 +++++++++++++++--- 6 files changed, 209 insertions(+), 91 deletions(-) diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs index d7d26c6d606..c9ec3d73f57 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs @@ -9,7 +9,9 @@ where import Prelude import Cardano.Api + import qualified Data.ByteString as BS +import Data.Function ((&)) import qualified Data.Map.Strict as Map import Data.Word (Word64) @@ -112,26 +114,15 @@ dummyTxSizeInEra metadata = case createAndValidateTransactionBody dummyTx of Left err -> error $ "metaDataSize " ++ show err where dummyTx :: TxBodyContent BuildTx era - dummyTx = TxBodyContent { - txIns = [( TxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810" (TxIx 0) - , BuildTxWith $ KeyWitness KeyWitnessForSpending )] - , txInsCollateral = TxInsCollateralNone - , txInsReference = TxInsReferenceNone - , txOuts = [] - , txFee = mkTxFee 0 - , txValidityRange = (TxValidityNoLowerBound, mkTxValidityUpperBound 0) - , txMetadata = metadata - , txAuxScripts = TxAuxScriptsNone - , txExtraKeyWits = TxExtraKeyWitnessesNone - , txProtocolParams = BuildTxWith Nothing - , txWithdrawals = TxWithdrawalsNone - , txCertificates = TxCertificatesNone - , txUpdateProposal = TxUpdateProposalNone - , txMintValue = TxMintNone - , txScriptValidity = TxScriptValidityNone - , txReturnCollateral = TxReturnCollateralNone - , txTotalCollateral = TxTotalCollateralNone - } + dummyTx = defaultTxBodyContent + & setTxIns + [ ( TxIn "dbaff4e270cfb55612d9e2ac4658a27c79da4a5271c6f90853042d1403733810" (TxIx 0) + , BuildTxWith $ KeyWitness KeyWitnessForSpending + ) + ] + & setTxFee (mkTxFee 0) + & setTxValidityRange (TxValidityNoLowerBound, mkTxValidityUpperBound 0) + & setTxMetadata metadata dummyTxSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int dummyTxSize _p m = (dummyTxSizeInEra @era) $ metadataInEra m diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs index 6775e8bc72a..a07b0ca793a 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Genesis.hs @@ -19,6 +19,7 @@ module Cardano.TxGenerator.Genesis where import Data.Bifunctor (bimap, second) +import Data.Function ((&)) import Data.List (find) import qualified Data.ListMap as ListMap (toList) @@ -124,25 +125,11 @@ mkGenesisTransaction key ttl fee txins txouts (`signShelleyTransaction` [WitnessGenesisUTxOKey key]) (createAndValidateTransactionBody txBodyContent) where - txBodyContent = TxBodyContent { - txIns = zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending - , txInsCollateral = TxInsCollateralNone - , txInsReference = TxInsReferenceNone - , txOuts = txouts - , txFee = mkTxFee fee - , txValidityRange = (TxValidityNoLowerBound, mkTxValidityUpperBound ttl) - , txMetadata = TxMetadataNone - , txAuxScripts = TxAuxScriptsNone - , txExtraKeyWits = TxExtraKeyWitnessesNone - , txProtocolParams = BuildTxWith Nothing - , txWithdrawals = TxWithdrawalsNone - , txCertificates = TxCertificatesNone - , txUpdateProposal = TxUpdateProposalNone - , txMintValue = TxMintNone - , txScriptValidity = TxScriptValidityNone - , txReturnCollateral = TxReturnCollateralNone - , txTotalCollateral = TxTotalCollateralNone - } + txBodyContent = defaultTxBodyContent + & setTxIns (zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending) + & setTxOuts txouts + & setTxFee (mkTxFee fee) + & setTxValidityRange (TxValidityNoLowerBound, mkTxValidityUpperBound ttl) castKey :: SigningKey PaymentKey -> SigningKey GenesisUTxOKey castKey (PaymentSigningKey skey) = GenesisUTxOSigningKey skey diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs index 9009ba41696..ab7b2d952fc 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Tx.hs @@ -9,6 +9,7 @@ module Cardano.TxGenerator.Tx import Data.Bifunctor (bimap, second) import qualified Data.ByteString as BS (length) +import Data.Function ((&)) import Data.Maybe (mapMaybe) import Cardano.Api @@ -93,25 +94,14 @@ genTx protocolParameters (collateral, collFunds) fee metadata inFunds outputs (createAndValidateTransactionBody txBodyContent) where allKeys = mapMaybe getFundKey $ inFunds ++ collFunds - txBodyContent = TxBodyContent { - txIns = map (\f -> (getFundTxIn f, BuildTxWith $ getFundWitness f)) inFunds - , txInsCollateral = collateral - , txInsReference = TxInsReferenceNone - , txOuts = outputs - , txFee = fee - , txValidityRange = (TxValidityNoLowerBound, upperBound) - , txMetadata = metadata - , txAuxScripts = TxAuxScriptsNone - , txExtraKeyWits = TxExtraKeyWitnessesNone - , txProtocolParams = BuildTxWith $ Just protocolParameters - , txWithdrawals = TxWithdrawalsNone - , txCertificates = TxCertificatesNone - , txUpdateProposal = TxUpdateProposalNone - , txMintValue = TxMintNone - , txScriptValidity = TxScriptValidityNone - , txReturnCollateral = TxReturnCollateralNone - , txTotalCollateral = TxTotalCollateralNone - } + txBodyContent = defaultTxBodyContent + & setTxIns (map (\f -> (getFundTxIn f, BuildTxWith $ getFundWitness f)) inFunds) + & setTxInsCollateral collateral + & setTxOuts outputs + & setTxFee fee + & setTxValidityRange (TxValidityNoLowerBound, upperBound) + & setTxMetadata metadata + & setTxProtocolParams (BuildTxWith (Just protocolParameters)) upperBound :: TxValidityUpperBound era upperBound = case shelleyBasedEra @era of diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 2b7fbb61e96..8b117fc6b94 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -160,6 +160,32 @@ module Cardano.Api ( createAndValidateTransactionBody, makeTransactionBody, -- TODO: Remove TxBodyContent(..), + + -- ** Transaction body builders + defaultTxBodyContent, + defaultTxFee, + defaultTxValidityUpperBound, + setTxIns, + modTxIns, + addTxIn, + setTxInsCollateral, + setTxInsReference, + setTxOuts, + modTxOuts, + addTxOut, + setTxTotalCollateral, + setTxReturnCollateral, + setTxFee, + setTxValidityRange, + setTxMetadata, + setTxAuxScripts, + setTxExtraKeyWits, + setTxProtocolParams, + setTxWithdrawals, + setTxCertificates, + setTxUpdateProposal, + setTxMintValue, + setTxScriptValidity, TxBodyError(..), TxBodyScriptData(..), diff --git a/cardano-api/src/Cardano/Api/Fees.hs b/cardano-api/src/Cardano/Api/Fees.hs index 47e62fd373e..3c6c5da9a8a 100644 --- a/cardano-api/src/Cardano/Api/Fees.hs +++ b/cardano-api/src/Cardano/Api/Fees.hs @@ -46,6 +46,7 @@ import qualified Data.Array as Array import Data.Bifunctor (bimap, first) import qualified Data.ByteString as BS import Data.ByteString.Short (ShortByteString) +import Data.Function ((&)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, maybeToList) @@ -1233,11 +1234,11 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { mappedTxCertificates <- mapScriptWitnessesCertificates txCertificates Right $ txbodycontent - { txIns = mappedTxIns - , txMintValue = mappedMintedVals - , txCertificates = mappedTxCertificates - , txWithdrawals = mappedWithdrawals - } + & setTxIns mappedTxIns + & setTxMintValue mappedMintedVals + & setTxCertificates mappedTxCertificates + & setTxWithdrawals mappedWithdrawals + where mapScriptWitnessesTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index 73312d0adf2..5ba3a6aa0a0 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -29,6 +29,31 @@ module Cardano.Api.TxBody ( createTransactionBody, createAndValidateTransactionBody, TxBodyContent(..), + -- ** Transaction body builders + defaultTxBodyContent, + defaultTxFee, + defaultTxValidityUpperBound, + setTxIns, + modTxIns, + addTxIn, + setTxInsCollateral, + setTxInsReference, + setTxOuts, + modTxOuts, + addTxOut, + setTxTotalCollateral, + setTxReturnCollateral, + setTxFee, + setTxValidityRange, + setTxMetadata, + setTxAuxScripts, + setTxExtraKeyWits, + setTxProtocolParams, + setTxWithdrawals, + setTxCertificates, + setTxUpdateProposal, + setTxMintValue, + setTxScriptValidity, TxBodyError(..), TxBodyScriptData(..), TxScriptValidity(..), @@ -287,6 +312,7 @@ data ScriptValidity deriving (Eq, Show) + instance ToCBOR ScriptValidity where toCBOR = toCBOR . scriptValidityToIsValid @@ -1304,6 +1330,10 @@ data BuildTxWith build a where ViewTx :: BuildTxWith ViewTx a BuildTxWith :: a -> BuildTxWith BuildTx a +instance Functor (BuildTxWith build) where + fmap _ ViewTx = ViewTx + fmap f (BuildTxWith x) = BuildTxWith (f x) + deriving instance Eq a => Eq (BuildTxWith build a) deriving instance Show a => Show (BuildTxWith build a) @@ -1553,6 +1583,16 @@ data TxFee era where deriving instance Eq (TxFee era) deriving instance Show (TxFee era) +defaultTxFee :: forall era. IsCardanoEra era => TxFee era +defaultTxFee = case cardanoEra @era of + ByronEra -> TxFeeImplicit TxFeesImplicitInByronEra + ShelleyEra -> TxFeeExplicit TxFeesExplicitInShelleyEra mempty + AllegraEra -> TxFeeExplicit TxFeesExplicitInAllegraEra mempty + MaryEra -> TxFeeExplicit TxFeesExplicitInMaryEra mempty + AlonzoEra -> TxFeeExplicit TxFeesExplicitInAlonzoEra mempty + BabbageEra -> TxFeeExplicit TxFeesExplicitInBabbageEra mempty + ConwayEra -> TxFeeExplicit TxFeesExplicitInConwayEra mempty + -- ---------------------------------------------------------------------------- -- Transaction validity range @@ -1572,6 +1612,15 @@ data TxValidityUpperBound era where deriving instance Eq (TxValidityUpperBound era) deriving instance Show (TxValidityUpperBound era) +defaultTxValidityUpperBound :: forall era. IsCardanoEra era => TxValidityUpperBound era +defaultTxValidityUpperBound = case cardanoEra @era of + ByronEra -> TxValidityNoUpperBound ValidityNoUpperBoundInByronEra + ShelleyEra -> TxValidityUpperBound ValidityUpperBoundInShelleyEra maxBound + AllegraEra -> TxValidityNoUpperBound ValidityNoUpperBoundInAllegraEra + MaryEra -> TxValidityNoUpperBound ValidityNoUpperBoundInMaryEra + AlonzoEra -> TxValidityNoUpperBound ValidityNoUpperBoundInAlonzoEra + BabbageEra -> TxValidityNoUpperBound ValidityNoUpperBoundInBabbageEra + ConwayEra -> TxValidityNoUpperBound ValidityNoUpperBoundInConwayEra data TxValidityLowerBound era where @@ -1584,7 +1633,6 @@ data TxValidityLowerBound era where deriving instance Eq (TxValidityLowerBound era) deriving instance Show (TxValidityLowerBound era) - -- ---------------------------------------------------------------------------- -- Transaction metadata (era-dependent) -- @@ -1600,7 +1648,6 @@ data TxMetadataInEra era where deriving instance Eq (TxMetadataInEra era) deriving instance Show (TxMetadataInEra era) - -- ---------------------------------------------------------------------------- -- Auxiliary scripts (era-dependent) -- @@ -1647,7 +1694,6 @@ data TxWithdrawals build era where deriving instance Eq (TxWithdrawals build era) deriving instance Show (TxWithdrawals build era) - -- ---------------------------------------------------------------------------- -- Certificates within transactions (era-dependent) -- @@ -1665,7 +1711,6 @@ data TxCertificates build era where deriving instance Eq (TxCertificates build era) deriving instance Show (TxCertificates build era) - -- ---------------------------------------------------------------------------- -- Transaction update proposal (era-dependent) -- @@ -1681,7 +1726,6 @@ data TxUpdateProposal era where deriving instance Eq (TxUpdateProposal era) deriving instance Show (TxUpdateProposal era) - -- ---------------------------------------------------------------------------- -- Value minting within transactions (era-dependent) -- @@ -1699,7 +1743,6 @@ data TxMintValue build era where deriving instance Eq (TxMintValue build era) deriving instance Show (TxMintValue build era) - -- ---------------------------------------------------------------------------- -- Transaction body content -- @@ -1727,6 +1770,89 @@ data TxBodyContent build era = } deriving (Eq, Show) +defaultTxBodyContent :: IsCardanoEra era => TxBodyContent BuildTx era +defaultTxBodyContent = TxBodyContent + { txIns = [] + , txInsCollateral = TxInsCollateralNone + , txInsReference = TxInsReferenceNone + , txOuts = [] + , txTotalCollateral = TxTotalCollateralNone + , txReturnCollateral = TxReturnCollateralNone + , txFee = defaultTxFee + , txValidityRange = (TxValidityNoLowerBound, defaultTxValidityUpperBound) + , txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txExtraKeyWits = TxExtraKeyWitnessesNone + , txProtocolParams = BuildTxWith Nothing + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + , txScriptValidity = TxScriptValidityNone + } + +setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era +setTxIns v txBodyContent = txBodyContent { txIns = v } + +modTxIns :: (TxIns build era -> TxIns build era) -> TxBodyContent build era -> TxBodyContent build era +modTxIns f txBodyContent = txBodyContent { txIns = f (txIns txBodyContent) } + +addTxIn :: (TxIn, BuildTxWith build (Witness WitCtxTxIn era)) -> TxBodyContent build era -> TxBodyContent build era +addTxIn txIn = modTxIns (txIn:) + +setTxInsCollateral :: TxInsCollateral era -> TxBodyContent build era -> TxBodyContent build era +setTxInsCollateral v txBodyContent = txBodyContent { txInsCollateral = v } + +setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era +setTxInsReference v txBodyContent = txBodyContent { txInsReference = v } + +setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era +setTxOuts v txBodyContent = txBodyContent { txOuts = v } + +modTxOuts :: ([TxOut CtxTx era] -> [TxOut CtxTx era]) -> TxBodyContent build era -> TxBodyContent build era +modTxOuts f txBodyContent = txBodyContent { txOuts = f (txOuts txBodyContent) } + +addTxOut :: TxOut CtxTx era -> TxBodyContent build era -> TxBodyContent build era +addTxOut txOut = modTxOuts (txOut:) + +setTxTotalCollateral :: TxTotalCollateral era -> TxBodyContent build era -> TxBodyContent build era +setTxTotalCollateral v txBodyContent = txBodyContent { txTotalCollateral = v } + +setTxReturnCollateral :: TxReturnCollateral CtxTx era -> TxBodyContent build era -> TxBodyContent build era +setTxReturnCollateral v txBodyContent = txBodyContent { txReturnCollateral = v } + +setTxFee :: TxFee era -> TxBodyContent build era -> TxBodyContent build era +setTxFee v txBodyContent = txBodyContent { txFee = v } + +setTxValidityRange :: (TxValidityLowerBound era, TxValidityUpperBound era) -> TxBodyContent build era -> TxBodyContent build era +setTxValidityRange v txBodyContent = txBodyContent { txValidityRange = v } + +setTxMetadata :: TxMetadataInEra era -> TxBodyContent build era -> TxBodyContent build era +setTxMetadata v txBodyContent = txBodyContent { txMetadata = v } + +setTxAuxScripts :: TxAuxScripts era -> TxBodyContent build era -> TxBodyContent build era +setTxAuxScripts v txBodyContent = txBodyContent { txAuxScripts = v } + +setTxExtraKeyWits :: TxExtraKeyWitnesses era -> TxBodyContent build era -> TxBodyContent build era +setTxExtraKeyWits v txBodyContent = txBodyContent { txExtraKeyWits = v } + +setTxProtocolParams :: BuildTxWith build (Maybe ProtocolParameters) -> TxBodyContent build era -> TxBodyContent build era +setTxProtocolParams v txBodyContent = txBodyContent { txProtocolParams = v } + +setTxWithdrawals :: TxWithdrawals build era -> TxBodyContent build era -> TxBodyContent build era +setTxWithdrawals v txBodyContent = txBodyContent { txWithdrawals = v } + +setTxCertificates :: TxCertificates build era -> TxBodyContent build era -> TxBodyContent build era +setTxCertificates v txBodyContent = txBodyContent { txCertificates = v } + +setTxUpdateProposal :: TxUpdateProposal era -> TxBodyContent build era -> TxBodyContent build era +setTxUpdateProposal v txBodyContent = txBodyContent { txUpdateProposal = v } + +setTxMintValue :: TxMintValue build era -> TxBodyContent build era -> TxBodyContent build era +setTxMintValue v txBodyContent = txBodyContent { txMintValue = v } + +setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era +setTxScriptValidity v txBodyContent = txBodyContent { txScriptValidity = v } -- ---------------------------------------------------------------------------- -- Transaction bodies @@ -3307,28 +3433,25 @@ makeByronTransactionBody TxBodyContent { txIns, txOuts } = do getByronTxBodyContent :: Annotated Byron.Tx ByteString -> TxBodyContent ViewTx ByronEra getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) = - TxBodyContent { - txIns = [ (fromByronTxIn input, ViewTx) - | input <- toList txInputs], - txInsCollateral = TxInsCollateralNone, - txInsReference = TxInsReferenceNone, - txOuts = fromByronTxOut <$> toList txOutputs, - txReturnCollateral = TxReturnCollateralNone, - txTotalCollateral = TxTotalCollateralNone, - txFee = TxFeeImplicit TxFeesImplicitInByronEra, - txValidityRange = (TxValidityNoLowerBound, - TxValidityNoUpperBound - ValidityNoUpperBoundInByronEra), - txMetadata = TxMetadataNone, - txAuxScripts = TxAuxScriptsNone, - txExtraKeyWits = TxExtraKeyWitnessesNone, - txProtocolParams = ViewTx, - txWithdrawals = TxWithdrawalsNone, - txCertificates = TxCertificatesNone, - txUpdateProposal = TxUpdateProposalNone, - txMintValue = TxMintNone, - txScriptValidity = TxScriptValidityNone - } + TxBodyContent + { txIns = [(fromByronTxIn input, ViewTx) | input <- toList txInputs] + , txInsCollateral = TxInsCollateralNone + , txInsReference = TxInsReferenceNone + , txOuts = fromByronTxOut <$> toList txOutputs + , txReturnCollateral = TxReturnCollateralNone + , txTotalCollateral = TxTotalCollateralNone + , txFee = TxFeeImplicit TxFeesImplicitInByronEra + , txValidityRange = (TxValidityNoLowerBound, TxValidityNoUpperBound ValidityNoUpperBoundInByronEra) + , txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txExtraKeyWits = TxExtraKeyWitnessesNone + , txProtocolParams = ViewTx + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + , txScriptValidity = TxScriptValidityNone + } convTxIns :: TxIns BuildTx era -> Set (Shelley.TxIn StandardCrypto) convTxIns txIns = Set.fromList (map (toShelleyTxIn . fst) txIns)