-
Notifications
You must be signed in to change notification settings - Fork 211
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
a8130ad
commit 3339855
Showing
4 changed files
with
287 additions
and
18 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
143 changes: 143 additions & 0 deletions
143
lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -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 |
115 changes: 115 additions & 0 deletions
115
lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/TxWithUTxO/Gen.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,115 @@ | ||
| {-# 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 | ||
| , shrink | ||
| ) | ||
| 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, unUTxO) | ||
| ) | ||
| import Internal.Cardano.Write.Tx.TxWithUTxO | ||
| ( pattern TxWithUTxO | ||
| , type TxWithUTxO | ||
| ) | ||
| import Test.QuickCheck | ||
| ( Gen | ||
| , oneof | ||
| ) | ||
| import Test.QuickCheck.Extra | ||
| ( genMapFromKeysWith | ||
| , genMapWith | ||
| , shrinkMapToSubmaps | ||
| ) | ||
|
|
||
| import qualified Data.Map.Strict as Map | ||
| 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 (txInputs tx) | ||
| pure $ TxWithUTxO.constructFiltered tx utxo | ||
| where | ||
| txInputs = view (bodyTxL . allInputsTxBodyF) | ||
|
|
||
| -- | Generates a 'TxWithUTxO' object that has a non-minimal 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 minimalUTxO -> do | ||
| surplusUTxO <- genNonEmptyUTxO | ||
| pure $ TxWithUTxO.constructFiltered tx (minimalUTxO <> surplusUTxO) | ||
| where | ||
| genNonEmptyUTxO :: Gen (UTxO era) | ||
| genNonEmptyUTxO | ||
| = fmap UTxO | ||
| $ Map.insert <$> genTxIn <*> genTxOut <*> genMapWith genTxIn genTxOut | ||
|
|
||
| -- TODO: Parameterise this by `Tx era -> [Tx era]` shrinker. | ||
| shrink :: IsRecentEra era => TxWithUTxO era -> [TxWithUTxO era] | ||
| shrink (TxWithUTxO tx utxo) = do | ||
| utxoSubset <- UTxO <$> shrinkMapToSubmaps (unUTxO utxo) | ||
| pure $ TxWithUTxO.constructFiltered tx utxoSubset |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters