From 13913f961ff8d6249f8f36acdb0a3acce292c655 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 2 May 2024 06:06:25 +0000 Subject: [PATCH 01/12] Add dependency on package `either`. --- lib/balance-tx/cardano-balance-tx.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/balance-tx/cardano-balance-tx.cabal b/lib/balance-tx/cardano-balance-tx.cabal index 719818aaf8b..ad169402db9 100644 --- a/lib/balance-tx/cardano-balance-tx.cabal +++ b/lib/balance-tx/cardano-balance-tx.cabal @@ -68,6 +68,7 @@ library internal , cborg , containers , deepseq + , either , fmt , generic-lens , groups From 4662cee1ae54a1fac2175554026dde4dfe99c38f Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 9 May 2024 03:56:54 +0000 Subject: [PATCH 02/12] Add dependency on package `cardano-wallet-test-utils`. --- lib/balance-tx/cardano-balance-tx.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/balance-tx/cardano-balance-tx.cabal b/lib/balance-tx/cardano-balance-tx.cabal index ad169402db9..6a9cda944a8 100644 --- a/lib/balance-tx/cardano-balance-tx.cabal +++ b/lib/balance-tx/cardano-balance-tx.cabal @@ -65,6 +65,7 @@ library internal , cardano-slotting , cardano-strict-containers , cardano-wallet-primitive + , cardano-wallet-test-utils , cborg , containers , deepseq From fcb81655e926d87a121b80e2ed997b6ee8983e26 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 9 May 2024 03:57:59 +0000 Subject: [PATCH 03/12] Add module `Cardano.Write.Tx.TxWithUTxO`. --- lib/balance-tx/cardano-balance-tx.cabal | 1 + .../Internal/Cardano/Write/Tx/TxWithUTxO.hs | 143 ++++++++++++++++++ 2 files changed, 144 insertions(+) create mode 100644 lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO.hs diff --git a/lib/balance-tx/cardano-balance-tx.cabal b/lib/balance-tx/cardano-balance-tx.cabal index 6a9cda944a8..464762cc380 100644 --- a/lib/balance-tx/cardano-balance-tx.cabal +++ b/lib/balance-tx/cardano-balance-tx.cabal @@ -97,6 +97,7 @@ library internal Internal.Cardano.Write.Tx.Sign Internal.Cardano.Write.Tx.SizeEstimation Internal.Cardano.Write.Tx.TimeTranslation + Internal.Cardano.Write.Tx.TxWithUTxO Internal.Cardano.Write.UTxOAssumptions test-suite test diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO.hs new file mode 100644 index 00000000000..e9d8cad115e --- /dev/null +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | +-- Copyright: © 2024 Cardano Foundation +-- License: Apache-2.0 +-- +-- Provides the 'TxWithUTxO' data type. +-- +module Internal.Cardano.Write.Tx.TxWithUTxO + ( type TxWithUTxO + , pattern TxWithUTxO + , construct + , constructFiltered + , isValid + ) + where + +import Prelude + +import Cardano.Ledger.Api + ( AlonzoEraTxBody (collateralInputsTxBodyL) + , BabbageEraTxBody (referenceInputsTxBodyL) + , EraTx (bodyTxL) + , EraTxBody (TxBody, inputsTxBodyL) + ) +import Cardano.Ledger.Api.Tx.Body + ( allInputsTxBodyF + ) +import Control.Lens + ( over + , view + ) +import Data.Either.Combinators + ( maybeToLeft + ) +import Data.Maybe + ( fromMaybe + ) +import Data.Semigroup.Cancellative + ( LeftReductive (stripPrefix) + ) +import Data.Set.NonEmpty + ( NESet + ) +import Internal.Cardano.Write.Tx + ( IsRecentEra + , Tx + , TxIn + , UTxO (UTxO) + ) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Set.NonEmpty as NESet + +-- | A transaction with an associated UTxO set. +-- +-- Every input in the transaction is guaranteed to resolve to a UTxO within the +-- associated UTxO set. +-- +-- The UTxO set may also contain additional UTxOs that are not referenced by +-- the transaction. +-- +data TxWithUTxO era = UnsafeTxWithUTxO !(Tx era) !(UTxO era) + +deriving instance IsRecentEra era => Eq (TxWithUTxO era) + +instance IsRecentEra era => Show (TxWithUTxO era) where + show = fromMaybe "TxWithUTxO" . stripPrefix "Unsafe" . show + +{-# COMPLETE TxWithUTxO #-} +pattern TxWithUTxO :: IsRecentEra era => Tx era -> UTxO era -> TxWithUTxO era +pattern TxWithUTxO tx utxo <- UnsafeTxWithUTxO tx utxo + +-- | Constructs a 'TxWithUTxO' object from an existing transaction and UTxO set. +-- +-- Construction succeeds if (and only if) every single input within the given +-- transaction resolves to a UTxO within the accompanying UTxO set. +-- +-- Otherwise, if the transaction has any unresolvable inputs, this function +-- returns the non-empty set of those inputs. +-- +construct + :: IsRecentEra era + => Tx era + -> UTxO era + -> Either (NESet TxIn) (TxWithUTxO era) +construct tx utxo = + maybeToLeft txWithUTxO (unresolvableInputs txWithUTxO) + where + txWithUTxO = UnsafeTxWithUTxO tx utxo + +-- | Constructs a 'TxWithUTxO' object from an existing transaction and UTxO set, +-- automatically filtering out any unresolvable inputs from the transaction. +-- +-- A transaction input is unresolvable if (and only if) it does not resolve to +-- a UTxO within the given UTxO set. +-- +constructFiltered + :: forall era. IsRecentEra era + => Tx era + -> UTxO era + -> TxWithUTxO era +constructFiltered tx utxo@(UTxO utxoMap) = UnsafeTxWithUTxO txFiltered utxo + where + txFiltered :: Tx era + txFiltered = over bodyTxL removeUnresolvableInputs tx + + removeUnresolvableInputs :: TxBody era -> TxBody era + removeUnresolvableInputs + = over inputsTxBodyL f + . over collateralInputsTxBodyL f + . over referenceInputsTxBodyL f + where + f = Set.filter (`Map.member` utxoMap) + +-- | Indicates whether or not a given 'TxWithUTxO' object is valid. +-- +-- A 'TxWithUTxO' object is valid if (and only if) all inputs within the +-- transaction resolve to a UTxO within the associated UTxO set. +-- +isValid :: IsRecentEra era => TxWithUTxO era -> Bool +isValid = null . unresolvableInputs + +-- | Finds the complete set of unresolvable transaction inputs. +-- +-- A transaction input is unresolvable if (and only if) it does not resolve +-- to a UTxO within the associated UTxO set. +-- +-- For a valid 'TxWithUTxO' object, this function will return 'Nothing'. +-- +unresolvableInputs + :: forall era. IsRecentEra era + => TxWithUTxO era + -> Maybe (NESet TxIn) +unresolvableInputs (TxWithUTxO tx (UTxO utxo)) + = NESet.nonEmptySet + . Set.filter (`Map.notMember` utxo) + . view (bodyTxL . allInputsTxBodyF) + $ tx From 94a8f538d08e22bd225c4f5fe768dc47b1e85aad Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 9 May 2024 03:58:30 +0000 Subject: [PATCH 04/12] Add module `Cardano.Write.Tx.TxWithUTxO.Gen`. --- lib/balance-tx/cardano-balance-tx.cabal | 1 + .../Cardano/Write/Tx/TxWithUTxO/Gen.hs | 130 ++++++++++++++++++ 2 files changed, 131 insertions(+) create mode 100644 lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs diff --git a/lib/balance-tx/cardano-balance-tx.cabal b/lib/balance-tx/cardano-balance-tx.cabal index 464762cc380..0fea2a3f8d9 100644 --- a/lib/balance-tx/cardano-balance-tx.cabal +++ b/lib/balance-tx/cardano-balance-tx.cabal @@ -98,6 +98,7 @@ library internal Internal.Cardano.Write.Tx.SizeEstimation Internal.Cardano.Write.Tx.TimeTranslation Internal.Cardano.Write.Tx.TxWithUTxO + Internal.Cardano.Write.Tx.TxWithUTxO.Gen Internal.Cardano.Write.UTxOAssumptions test-suite test diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs new file mode 100644 index 00000000000..5fb0f9999c4 --- /dev/null +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright: © 2024 Cardano Foundation +-- License: Apache-2.0 +-- +-- Provides generators and shrinkers for the 'TxWithUTxO' data type. +-- +module Internal.Cardano.Write.Tx.TxWithUTxO.Gen + ( generate + , generateWithMinimalUTxO + , generateWithSurplusUTxO + , shrinkWith + , shrinkTxWith + , shrinkUTxOWith + ) + where + +import Prelude + +import Cardano.Ledger.Api + ( EraTx (bodyTxL) + ) +import Cardano.Ledger.Api.Tx.Body + ( allInputsTxBodyF + ) +import Control.Lens + ( view + ) +import Internal.Cardano.Write.Tx + ( IsRecentEra + , Tx + , TxIn + , TxOut + , UTxO (UTxO) + ) +import Internal.Cardano.Write.Tx.TxWithUTxO + ( pattern TxWithUTxO + , type TxWithUTxO + ) +import Test.QuickCheck + ( Gen + , oneof + ) +import Test.QuickCheck.Extra + ( genMapFromKeysWith + , genNonEmptyDisjointMap + , interleaveRoundRobin + ) + +import qualified Internal.Cardano.Write.Tx.TxWithUTxO as TxWithUTxO + +-- | Generates a 'TxWithUTxO' object. +-- +-- The domain of the UTxO map is a superset of the transaction input set, but +-- it may or may not be a strict superset. +-- +generate + :: IsRecentEra era + => Gen (Tx era) + -> Gen (TxIn) + -> Gen (TxOut era) + -> Gen (TxWithUTxO era) +generate genTx genTxIn genTxOut = + oneof + [ generateWithMinimalUTxO genTx genTxIn genTxOut + , generateWithSurplusUTxO genTx genTxIn genTxOut + ] + +-- | Generates a 'TxWithUTxO' object that has a minimal UTxO set. +-- +-- The domain of the UTxO map is exactly equal to the transaction input set. +-- +generateWithMinimalUTxO + :: IsRecentEra era + => Gen (Tx era) + -> Gen (TxIn) + -> Gen (TxOut era) + -> Gen (TxWithUTxO era) +generateWithMinimalUTxO genTx _genTxIn genTxOut = do + tx <- genTx + utxo <- UTxO <$> genMapFromKeysWith genTxOut (txAllInputs tx) + pure $ TxWithUTxO.constructFiltered tx utxo + where + txAllInputs = view (bodyTxL . allInputsTxBodyF) + +-- | Generates a 'TxWithUTxO' object that has a surplus UTxO set. +-- +-- The domain of the UTxO map is a strict superset of the transaction input set. +-- +generateWithSurplusUTxO + :: forall era. () + => IsRecentEra era + => Gen (Tx era) + -> Gen (TxIn) + -> Gen (TxOut era) + -> Gen (TxWithUTxO era) +generateWithSurplusUTxO genTx genTxIn genTxOut = + generateWithMinimalUTxO genTx genTxIn genTxOut >>= \case + TxWithUTxO tx (UTxO utxo) -> do + utxoSurplus <- genNonEmptyDisjointMap genTxIn genTxOut utxo + pure $ TxWithUTxO.constructFiltered tx $ UTxO (utxo <> utxoSurplus) + +shrinkWith + :: IsRecentEra era + => (Tx era -> [Tx era]) + -> (UTxO era -> [UTxO era]) + -> (TxWithUTxO era -> [TxWithUTxO era]) +shrinkWith shrinkTx shrinkUTxO txWithUTxO = + interleaveRoundRobin + [ shrinkTxWith shrinkTx txWithUTxO + , shrinkUTxOWith shrinkUTxO txWithUTxO + ] + +shrinkTxWith + :: IsRecentEra era + => (Tx era -> [Tx era]) + -> (TxWithUTxO era -> [TxWithUTxO era]) +shrinkTxWith shrinkTx (TxWithUTxO tx utxo) = + [ TxWithUTxO.constructFiltered tx' utxo | tx' <- shrinkTx tx ] + +shrinkUTxOWith + :: IsRecentEra era + => (UTxO era -> [UTxO era]) + -> (TxWithUTxO era -> [TxWithUTxO era]) +shrinkUTxOWith shrinkUTxO (TxWithUTxO tx utxo) = + [ TxWithUTxO.constructFiltered tx utxo' | utxo' <- shrinkUTxO utxo ] From 579b4d4982688ec57500b852622e81ad438a90c1 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 9 May 2024 03:58:58 +0000 Subject: [PATCH 05/12] Redefine `Arbitrary` instance for `PartialTx`. --- .../Internal/Cardano/Write/Tx/BalanceSpec.hs | 51 +++++++++++-------- 1 file changed, 31 insertions(+), 20 deletions(-) diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs index 542486ac7cf..05ad77e8720 100644 --- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs +++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs @@ -12,6 +12,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -306,6 +307,10 @@ import Internal.Cardano.Write.Tx.TimeTranslation ( TimeTranslation , timeTranslationFromEpochInfo ) +import Internal.Cardano.Write.Tx.TxWithUTxO + ( pattern TxWithUTxO + , type TxWithUTxO + ) import Numeric.Natural ( Natural ) @@ -383,10 +388,10 @@ import Test.QuickCheck import Test.QuickCheck.Extra ( DisjointPair , genDisjointPair - , genMapFromKeysWith , genericRoundRobinShrink , getDisjointPair , shrinkDisjointPair + , shrinkMapToSubmaps , shrinkMapValuesWith , shrinkNatural , (.>=.) @@ -465,6 +470,8 @@ import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Internal.Cardano.Write.Tx as Write +import qualified Internal.Cardano.Write.Tx.TxWithUTxO as TxWithUTxO +import qualified Internal.Cardano.Write.Tx.TxWithUTxO.Gen as TxWithUTxO import qualified Ouroboros.Consensus.HardFork.History as HF import qualified Test.Hspec.Extra as Hspec @@ -2203,25 +2210,29 @@ instance Arbitrary (MixedSign Value) where genPositive = arbitrary shrink (MixedSign v) = MixedSign <$> shrink v -instance forall era. IsRecentEra era => Arbitrary (PartialTx era) where - arbitrary = do - tx <- genTxForBalancing - extraUTxO <- genExtraUTxO (txInputs tx) - let redeemers = [] - let timelockKeyWitnessCounts = mempty - pure PartialTx {tx, extraUTxO, redeemers, timelockKeyWitnessCounts} - where - genExtraUTxO :: Set TxIn -> Gen (UTxO era) - genExtraUTxO = fmap UTxO . genMapFromKeysWith genTxOut - txInputs :: Tx era -> Set TxIn - txInputs tx = tx ^. bodyTxL . inputsTxBodyL - shrink partialTx@PartialTx {tx, extraUTxO} = - [ partialTx {extraUTxO = extraUTxO'} - | extraUTxO' <- shrinkInputResolution extraUTxO - ] <> - [ restrictResolution (partialTx {tx = tx'}) - | tx' <- shrinkTx tx - ] +instance IsRecentEra era => Arbitrary (PartialTx era) where + arbitrary = mkPartialTx <$> genTxWithUTxO + shrink = shrinkMapBy mkPartialTx unPartialTx shrinkTxWithUTxO + +mkPartialTx :: IsRecentEra era => TxWithUTxO era -> PartialTx era +mkPartialTx (TxWithUTxO tx extraUTxO) = + PartialTx {tx, extraUTxO, redeemers = [], timelockKeyWitnessCounts = mempty} + +unPartialTx :: IsRecentEra era => PartialTx era -> TxWithUTxO era +unPartialTx PartialTx {tx, extraUTxO} = + TxWithUTxO.constructFiltered tx extraUTxO + +genTxWithUTxO :: IsRecentEra era => Gen (TxWithUTxO era) +genTxWithUTxO = TxWithUTxO.generate genTxForBalancing genTxIn genTxOut + where + genTxIn :: Gen TxIn + genTxIn = fromWalletTxIn <$> W.genTxIn + +shrinkTxWithUTxO :: IsRecentEra era => TxWithUTxO era -> [TxWithUTxO era] +shrinkTxWithUTxO = TxWithUTxO.shrinkWith shrinkTx shrinkUTxOToSubsets + where + shrinkUTxOToSubsets :: IsRecentEra era => UTxO era -> [UTxO era] + shrinkUTxOToSubsets = shrinkMapBy UTxO unUTxO shrinkMapToSubmaps instance Arbitrary StdGenSeed where arbitrary = StdGenSeed . fromIntegral @Int <$> arbitrary From 13798230403b4d5c00409ed3d36518fb26c022aa Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 8 May 2024 02:35:38 +0000 Subject: [PATCH 06/12] Remove unused function `restrictResolution`. --- .../spec/Internal/Cardano/Write/Tx/BalanceSpec.hs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs index 05ad77e8720..a07a2925305 100644 --- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs +++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs @@ -1845,17 +1845,6 @@ paymentPartialTx txouts = & outputsTxBodyL .~ StrictSeq.fromList (Convert.toBabbageTxOut <$> txouts) --- | Restricts the inputs list of the 'PartialTx' to the inputs of the --- underlying CBOR transaction. This allows us to "fix" the 'PartialTx' after --- shrinking the CBOR. --- --- NOTE: Perhaps ideally 'PartialTx' would handle this automatically. -restrictResolution :: IsRecentEra era => PartialTx era -> PartialTx era -restrictResolution partialTx@PartialTx {tx, extraUTxO} = partialTx - {extraUTxO = UTxO $ unUTxO extraUTxO `Map.restrictKeys` txIns} - where - txIns = tx ^. bodyTxL . inputsTxBodyL - serializedSize :: forall era. IsRecentEra era => Tx era From 091684ca0082a0388ddb1059ed3a0e26a2f86458 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 8 May 2024 02:36:06 +0000 Subject: [PATCH 07/12] Remove unused function `shrinkInputResolution`. --- .../test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs index a07a2925305..2427f52b5bc 100644 --- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs +++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs @@ -392,7 +392,6 @@ import Test.QuickCheck.Extra , getDisjointPair , shrinkDisjointPair , shrinkMapToSubmaps - , shrinkMapValuesWith , shrinkNatural , (.>=.) , (<:>) @@ -2335,14 +2334,6 @@ shrinkFee :: Ledger.Coin -> [Ledger.Coin] shrinkFee (Ledger.Coin 0) = [] shrinkFee _ = [Ledger.Coin 0] --- TODO: ADP-3272 --- Fix this function so that it returns something other than the empty list. -shrinkInputResolution :: IsRecentEra era => Write.UTxO era -> [Write.UTxO era] -shrinkInputResolution = - shrinkMapBy UTxO unUTxO (shrinkMapValuesWith shrinkOutput) - where - shrinkOutput _ = [] - shrinkScriptData :: Era (CardanoApi.ShelleyLedgerEra era) => CardanoApi.TxBodyScriptData era From 643ab041bf06b4e412d2ad5854ec27dc5123731c Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 10 May 2024 09:39:39 +0000 Subject: [PATCH 08/12] Adjust the frequency distribution in `TxWithUTxO.Gen.generate`. In response to review feedback: https://github.com/cardano-foundation/cardano-wallet/pull/4570#discussion_r1589650350 --- .../internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs index 5fb0f9999c4..bc059212fd7 100644 --- a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs @@ -43,7 +43,7 @@ import Internal.Cardano.Write.Tx.TxWithUTxO ) import Test.QuickCheck ( Gen - , oneof + , frequency ) import Test.QuickCheck.Extra ( genMapFromKeysWith @@ -65,9 +65,9 @@ generate -> Gen (TxOut era) -> Gen (TxWithUTxO era) generate genTx genTxIn genTxOut = - oneof - [ generateWithMinimalUTxO genTx genTxIn genTxOut - , generateWithSurplusUTxO genTx genTxIn genTxOut + frequency + [ (9, generateWithMinimalUTxO genTx genTxIn genTxOut) + , (1, generateWithSurplusUTxO genTx genTxIn genTxOut) ] -- | Generates a 'TxWithUTxO' object that has a minimal UTxO set. From 871ac7ba0190b4f183f1dfe2bbc090a62f5be38c Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 10 May 2024 10:17:14 +0000 Subject: [PATCH 09/12] Rename functions `mkPartialTx` and `unPartialTx`. We use the following new names: - `partialTxFromUTxOWithTx` - `UTxOWithTxFromPartialTx` --- .../Internal/Cardano/Write/Tx/BalanceSpec.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs index 2427f52b5bc..34593cf6f75 100644 --- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs +++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs @@ -2199,15 +2199,18 @@ instance Arbitrary (MixedSign Value) where shrink (MixedSign v) = MixedSign <$> shrink v instance IsRecentEra era => Arbitrary (PartialTx era) where - arbitrary = mkPartialTx <$> genTxWithUTxO - shrink = shrinkMapBy mkPartialTx unPartialTx shrinkTxWithUTxO - -mkPartialTx :: IsRecentEra era => TxWithUTxO era -> PartialTx era -mkPartialTx (TxWithUTxO tx extraUTxO) = + arbitrary = partialTxFromTxWithUTxO <$> genTxWithUTxO + shrink = shrinkMapBy + partialTxFromTxWithUTxO + txWithUTxOFromPartialTx + shrinkTxWithUTxO + +partialTxFromTxWithUTxO :: IsRecentEra era => TxWithUTxO era -> PartialTx era +partialTxFromTxWithUTxO (TxWithUTxO tx extraUTxO) = PartialTx {tx, extraUTxO, redeemers = [], timelockKeyWitnessCounts = mempty} -unPartialTx :: IsRecentEra era => PartialTx era -> TxWithUTxO era -unPartialTx PartialTx {tx, extraUTxO} = +txWithUTxOFromPartialTx :: IsRecentEra era => PartialTx era -> TxWithUTxO era +txWithUTxOFromPartialTx PartialTx {tx, extraUTxO} = TxWithUTxO.constructFiltered tx extraUTxO genTxWithUTxO :: IsRecentEra era => Gen (TxWithUTxO era) From 9e5d3966cfb66f9af2ac4c51e6284f33dcdfb7a0 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 10 May 2024 10:18:51 +0000 Subject: [PATCH 10/12] Draw more attention to constants within `partialTxFromTxWithUTxO`. --- .../test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs index 34593cf6f75..1bc37b83108 100644 --- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs +++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs @@ -2207,7 +2207,11 @@ instance IsRecentEra era => Arbitrary (PartialTx era) where partialTxFromTxWithUTxO :: IsRecentEra era => TxWithUTxO era -> PartialTx era partialTxFromTxWithUTxO (TxWithUTxO tx extraUTxO) = - PartialTx {tx, extraUTxO, redeemers = [], timelockKeyWitnessCounts = mempty} + PartialTx {tx, extraUTxO, redeemers, timelockKeyWitnessCounts} + where + -- This embedding uses the following constants: + redeemers = [] + timelockKeyWitnessCounts = mempty txWithUTxOFromPartialTx :: IsRecentEra era => PartialTx era -> TxWithUTxO era txWithUTxOFromPartialTx PartialTx {tx, extraUTxO} = From 71610da7baa0731cedc935f75ed4f34ee696ed7b Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Sat, 11 May 2024 02:33:41 +0000 Subject: [PATCH 11/12] Remove unused `Gen TxIn` argument from `generateWithMinimalUTxO`. In response to review feedback: https://github.com/cardano-foundation/cardano-wallet/pull/4570#discussion_r1596996702 --- .../internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs index bc059212fd7..298f1a2183a 100644 --- a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs @@ -66,7 +66,7 @@ generate -> Gen (TxWithUTxO era) generate genTx genTxIn genTxOut = frequency - [ (9, generateWithMinimalUTxO genTx genTxIn genTxOut) + [ (9, generateWithMinimalUTxO genTx genTxOut) , (1, generateWithSurplusUTxO genTx genTxIn genTxOut) ] @@ -77,10 +77,9 @@ generate genTx genTxIn genTxOut = generateWithMinimalUTxO :: IsRecentEra era => Gen (Tx era) - -> Gen (TxIn) -> Gen (TxOut era) -> Gen (TxWithUTxO era) -generateWithMinimalUTxO genTx _genTxIn genTxOut = do +generateWithMinimalUTxO genTx genTxOut = do tx <- genTx utxo <- UTxO <$> genMapFromKeysWith genTxOut (txAllInputs tx) pure $ TxWithUTxO.constructFiltered tx utxo @@ -99,7 +98,7 @@ generateWithSurplusUTxO -> Gen (TxOut era) -> Gen (TxWithUTxO era) generateWithSurplusUTxO genTx genTxIn genTxOut = - generateWithMinimalUTxO genTx genTxIn genTxOut >>= \case + generateWithMinimalUTxO genTx genTxOut >>= \case TxWithUTxO tx (UTxO utxo) -> do utxoSurplus <- genNonEmptyDisjointMap genTxIn genTxOut utxo pure $ TxWithUTxO.constructFiltered tx $ UTxO (utxo <> utxoSurplus) From 0433f6b918ccad77983f26d087705047ff164576 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Sat, 11 May 2024 02:40:53 +0000 Subject: [PATCH 12/12] Make `genTxIn` a top-level function. The new location is next to the other general-purpose generators, such as `genTxOut`. --- .../test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs index 1bc37b83108..61ced9e0370 100644 --- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs +++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs @@ -2219,9 +2219,6 @@ txWithUTxOFromPartialTx PartialTx {tx, extraUTxO} = genTxWithUTxO :: IsRecentEra era => Gen (TxWithUTxO era) genTxWithUTxO = TxWithUTxO.generate genTxForBalancing genTxIn genTxOut - where - genTxIn :: Gen TxIn - genTxIn = fromWalletTxIn <$> W.genTxIn shrinkTxWithUTxO :: IsRecentEra era => TxWithUTxO era -> [TxWithUTxO era] shrinkTxWithUTxO = TxWithUTxO.shrinkWith shrinkTx shrinkUTxOToSubsets @@ -2324,6 +2321,9 @@ genTxForBalancing :: forall era. IsRecentEra era => Gen (Tx era) genTxForBalancing = fromCardanoApiTx <$> CardanoApi.genTxForBalancing (cardanoEra @era) +genTxIn :: Gen TxIn +genTxIn = fromWalletTxIn <$> W.genTxIn + genTxOut :: forall era. IsRecentEra era => Gen (TxOut era) genTxOut = -- NOTE: genTxOut does not generate quantities larger than