diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index c5bf16cb685..f490957e5b9 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -83,6 +83,7 @@ library , persistent , persistent-sqlite , persistent-template + , pretty-simple , profunctors , quiet , random @@ -175,6 +176,9 @@ library Cardano.Wallet.Primitive.AddressDiscovery.SharedState Cardano.Wallet.Primitive.SyncProgress Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin + Cardano.Wallet.Primitive.Migration + Cardano.Wallet.Primitive.Migration.Planning + Cardano.Wallet.Primitive.Migration.Selection Cardano.Wallet.Primitive.Model Cardano.Wallet.Primitive.Types Cardano.Wallet.Primitive.Types.Address @@ -283,6 +287,7 @@ test-suite unit , network , network-uri , persistent + , pretty-simple , regex-pcre-builtin , OddWord , ouroboros-consensus @@ -356,6 +361,9 @@ test-suite unit Cardano.Wallet.Primitive.AddressDiscovery.SharedStateSpec Cardano.Wallet.Primitive.AddressDiscoverySpec Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobinSpec + Cardano.Wallet.Primitive.MigrationSpec + Cardano.Wallet.Primitive.Migration.PlanningSpec + Cardano.Wallet.Primitive.Migration.SelectionSpec Cardano.Wallet.Primitive.ModelSpec Cardano.Wallet.Primitive.Slotting.Legacy Cardano.Wallet.Primitive.SlottingSpec diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs index d42a85c542e..727484408f0 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs @@ -223,7 +223,7 @@ data SelectionResult change = SelectionResult -- ^ An optional extra source of ada. , outputsCovered :: ![TxOut] - -- ^ A list of ouputs covered. + -- ^ A list of outputs covered. -- FIXME: Left as a list to allow to work-around the limitation of -- 'performSelection' which cannot run for no output targets (e.g. in -- the context of a delegation transaction). This allows callers to diff --git a/lib/core/src/Cardano/Wallet/Primitive/Migration.hs b/lib/core/src/Cardano/Wallet/Primitive/Migration.hs new file mode 100644 index 00000000000..4b19c80ef92 --- /dev/null +++ b/lib/core/src/Cardano/Wallet/Primitive/Migration.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} + +-- | +-- Copyright: © 2021 IOHK +-- License: Apache-2.0 +-- +-- This module provides a public API for planning wallet migrations. +-- +-- Use 'createPlan' to create a migration plan. +-- +module Cardano.Wallet.Primitive.Migration + ( + -- * Creating a migration plan + createPlan + , MigrationPlan (..) + , RewardWithdrawal (..) + , Selection (..) + , TxSize (..) + + ) where + +import Prelude + +import Cardano.Wallet.Primitive.Migration.Selection + ( RewardWithdrawal (..), Selection (..), TxSize (..) ) +import Cardano.Wallet.Primitive.Types.Coin + ( Coin ) +import Cardano.Wallet.Primitive.Types.Tx + ( TxConstraints (..), TxIn, TxOut ) +import Cardano.Wallet.Primitive.Types.UTxO + ( UTxO ) +import Data.Generics.Internal.VL.Lens + ( view ) +import Data.Generics.Labels + () +import GHC.Generics + ( Generic ) + +import qualified Cardano.Wallet.Primitive.Migration.Planning as Planning + +-- | Represents a plan for migrating a 'UTxO' set. +-- +-- See 'createPlan' to create a migration plan. +-- +data MigrationPlan size = MigrationPlan + { selections :: ![Selection (TxIn, TxOut) size] + -- ^ A list of generated selections: each selection is the basis for a + -- single transaction. + , unselected :: !UTxO + -- ^ The portion of the UTxO that was not selected. + , totalFee :: !Coin + -- ^ The total fee payable: equal to the sum of the fees of the + -- individual selections. + } + deriving (Eq, Generic, Show) + +-- | Creates a migration plan for the given UTxO set and reward withdrawal +-- amount. +-- +-- See 'MigrationPlan'. +-- +createPlan + :: TxSize size + => TxConstraints size + -> UTxO + -> RewardWithdrawal + -> MigrationPlan size +createPlan constraints utxo reward = MigrationPlan + { selections = view #selections plan + , unselected = Planning.uncategorizeUTxO (view #unselected plan) + , totalFee = view #totalFee plan + } + where + plan = Planning.createPlan + constraints (Planning.categorizeUTxO constraints utxo) reward diff --git a/lib/core/src/Cardano/Wallet/Primitive/Migration/Planning.hs b/lib/core/src/Cardano/Wallet/Primitive/Migration/Planning.hs new file mode 100644 index 00000000000..914f594288a --- /dev/null +++ b/lib/core/src/Cardano/Wallet/Primitive/Migration/Planning.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright: © 2021 IOHK +-- License: Apache-2.0 +-- +-- This module contains an algorithm for planning migrations at a high level. +-- +-- It determines how to partition the UTxO set into entries of different types, +-- and in which order to add entries to selections, in order to maximize the +-- number of entries that can be successfully migrated. +-- +-- Use 'createPlan' to create a migration plan. +-- +module Cardano.Wallet.Primitive.Migration.Planning + ( + -- * Migration planning + createPlan + , MigrationPlan (..) + + -- * UTxO entry categorization + , CategorizedUTxO (..) + , UTxOEntryCategory (..) + , categorizeUTxO + , categorizeUTxOEntries + , categorizeUTxOEntry + , uncategorizeUTxO + , uncategorizeUTxOEntries + + ) where + +import Prelude + +import Cardano.Wallet.Primitive.Migration.Selection + ( RewardWithdrawal (..), Selection (..), SelectionError (..), TxSize (..) ) +import Cardano.Wallet.Primitive.Types.Coin + ( Coin (..) ) +import Cardano.Wallet.Primitive.Types.TokenBundle + ( TokenBundle (..) ) +import Cardano.Wallet.Primitive.Types.Tx + ( TxConstraints (..), TxIn, TxOut ) +import Cardano.Wallet.Primitive.Types.UTxO + ( UTxO (..) ) +import Data.Either + ( isRight ) +import Data.Functor + ( (<&>) ) +import Data.Generics.Internal.VL.Lens + ( view ) +import Data.Generics.Labels + () +import GHC.Generics + ( Generic ) + +import qualified Cardano.Wallet.Primitive.Migration.Selection as Selection +import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.Map.Strict as Map + +-------------------------------------------------------------------------------- +-- Migration planning +-------------------------------------------------------------------------------- + +-- | Represents a plan for migrating a set of UTxO entries. +-- +-- Use 'createPlan' to create a migration plan. +-- +data MigrationPlan input size = MigrationPlan + { selections :: ![Selection input size] + -- ^ A list of generated selections: each selection is the basis for a + -- single transaction. + , unselected :: !(CategorizedUTxO input) + -- ^ The portion of the UTxO that was not selected. + , totalFee :: !Coin + -- ^ The total fee payable: equal to the sum of the fees of the + -- individual selections. + } + deriving (Eq, Generic, Show) + +-- | Creates a migration plan for the given categorized UTxO set and reward +-- withdrawal amount. +-- +-- See 'MigrationPlan'. +-- +createPlan + :: TxSize size + => TxConstraints size + -> CategorizedUTxO input + -> RewardWithdrawal + -> MigrationPlan input size +createPlan constraints = + run [] + where + run !selections !utxo !reward = + case createSelection constraints utxo reward of + Just (utxo', selection) -> + run (selection : selections) utxo' (RewardWithdrawal $ Coin 0) + Nothing -> MigrationPlan + { selections + , unselected = utxo + , totalFee = F.foldMap (view #fee) selections + } + +-- | Creates an individual selection for inclusion in a migration plan. +-- +-- A selection is the basis for an individual transaction. +-- +-- Returns 'Nothing' if it was not possible to create a selection with the UTxO +-- entries that remain. +-- +createSelection + :: TxSize size + => TxConstraints size + -> CategorizedUTxO input + -> RewardWithdrawal + -> Maybe (CategorizedUTxO input, Selection input size) +createSelection constraints utxo rewardWithdrawal = + initializeSelection constraints utxo rewardWithdrawal + <&> extendSelectionUntilFull constraints + +-- | Initializes a selection with a single entry. +-- +-- Returns 'Nothing' if it was not possible to initialize a selection with the +-- UTxO entries that remain. +-- +initializeSelection + :: forall input size. TxSize size + => TxConstraints size + -> CategorizedUTxO input + -> RewardWithdrawal + -> Maybe (CategorizedUTxO input, Selection input size) +initializeSelection constraints utxoAtStart reward = + initializeWith =<< utxoAtStart `select` Supporter + where + initializeWith (entry, utxo) = + case Selection.create constraints reward [entry] of + Right selection -> Just (utxo, selection) + Left _ -> Nothing + +-- | Extends a selection repeatedly, until the selection is full. +-- +-- This function terminates when the selection cannot be extended further +-- (because doing so would cause it to exceed the size limit of a transaction), +-- or when there are no more UTxO entries available for selection. +-- +-- Priority is given to selecting "freerider" entries: entries that cannot pay +-- for themselves. A "supporter" entry is only added to the selection if there +-- is not enough ada to pay for a "freerider" entry. +-- +extendSelectionUntilFull + :: TxSize size + => TxConstraints size + -> (CategorizedUTxO input, Selection input size) + -> (CategorizedUTxO input, Selection input size) +extendSelectionUntilFull constraints = extendWithFreerider + where + extendWithFreerider (!utxo, !selection) = + case extendWith Freerider constraints (utxo, selection) of + Right (utxo', selection') -> + extendWithFreerider (utxo', selection') + Left ExtendSelectionAdaInsufficient -> + extendWithSupporter (utxo, selection) + Left ExtendSelectionEntriesExhausted -> + extendWithSupporter (utxo, selection) + Left ExtendSelectionFull -> + (utxo, selection) + + extendWithSupporter (!utxo, !selection) = + case extendWith Supporter constraints (utxo, selection) of + Right (utxo', selection') -> + extendWithFreerider (utxo', selection') + Left ExtendSelectionAdaInsufficient -> + (utxo, selection) + Left ExtendSelectionEntriesExhausted -> + (utxo, selection) + Left ExtendSelectionFull -> + (utxo, selection) + +data ExtendSelectionError + = ExtendSelectionAdaInsufficient + | ExtendSelectionEntriesExhausted + | ExtendSelectionFull + +extendWith + :: TxSize size + => UTxOEntryCategory + -> TxConstraints size + -> (CategorizedUTxO input, Selection input size) + -> Either ExtendSelectionError (CategorizedUTxO input, Selection input size) +extendWith category constraints (utxo, selection) = + case utxo `select` category of + Just (entry, utxo') -> + case Selection.extend constraints selection entry of + Right selection' -> + Right (utxo', selection') + Left SelectionAdaInsufficient -> + Left ExtendSelectionAdaInsufficient + Left SelectionFull {} -> + Left ExtendSelectionFull + Nothing -> + Left ExtendSelectionEntriesExhausted + +select + :: CategorizedUTxO input + -> UTxOEntryCategory + -> Maybe ((input, TokenBundle), CategorizedUTxO input) +select utxo = \case + Supporter -> selectSupporter + Freerider -> selectFreerider + Ignorable -> selectIgnorable + where + selectSupporter = case supporters utxo of + entry : remaining -> Just (entry, utxo {supporters = remaining}) + [] -> Nothing + selectFreerider = case freeriders utxo of + entry : remaining -> Just (entry, utxo {freeriders = remaining}) + [] -> Nothing + selectIgnorable = + -- We never select an entry that should be ignored: + Nothing + +-------------------------------------------------------------------------------- +-- Categorization of UTxO entries +-------------------------------------------------------------------------------- + +data UTxOEntryCategory + = Supporter + -- ^ A coin or bundle that is capable of paying for its own marginal fee + -- and the base transaction fee. + | Freerider + -- ^ A coin or bundle that is not capable of paying for itself. + | Ignorable + -- ^ A coin that should not be added to a selection, because its value is + -- lower than the marginal fee for an input. + deriving (Eq, Show) + +data CategorizedUTxO input = CategorizedUTxO + { supporters :: ![(input, TokenBundle)] + , freeriders :: ![(input, TokenBundle)] + , ignorables :: ![(input, TokenBundle)] + } + deriving (Eq, Show) + +categorizeUTxO + :: TxSize size + => TxConstraints size + -> UTxO + -> CategorizedUTxO (TxIn, TxOut) +categorizeUTxO constraints (UTxO u) = categorizeUTxOEntries constraints $ + (\(i, o) -> ((i, o), view #tokens o)) <$> Map.toList u + +categorizeUTxOEntries + :: forall input size. TxSize size + => TxConstraints size + -> [(input, TokenBundle)] + -> CategorizedUTxO input +categorizeUTxOEntries constraints uncategorizedEntries = CategorizedUTxO + { supporters = entriesMatching Supporter + , freeriders = entriesMatching Freerider + , ignorables = entriesMatching Ignorable + } + where + categorizedEntries :: [(input, (TokenBundle, UTxOEntryCategory))] + categorizedEntries = uncategorizedEntries + <&> (\(i, b) -> (i, (b, categorizeUTxOEntry constraints b))) + + entriesMatching :: UTxOEntryCategory -> [(input, TokenBundle)] + entriesMatching category = + fmap fst <$> L.filter ((== category) . snd . snd) categorizedEntries + +categorizeUTxOEntry + :: TxSize size + => TxConstraints size + -> TokenBundle + -> UTxOEntryCategory +categorizeUTxOEntry constraints b + | Just c <- TokenBundle.toCoin b, coinIsIgnorable c = + Ignorable + | bundleIsSupporter = + Supporter + | otherwise = + Freerider + where + bundleIsSupporter :: Bool + bundleIsSupporter = isRight $ + Selection.create constraints (RewardWithdrawal $ Coin 0) [((), b)] + + coinIsIgnorable :: Coin -> Bool + coinIsIgnorable c = c <= txInputCost constraints + +uncategorizeUTxO :: CategorizedUTxO (TxIn, TxOut) -> UTxO +uncategorizeUTxO = UTxO . Map.fromList . fmap fst . uncategorizeUTxOEntries + +uncategorizeUTxOEntries :: CategorizedUTxO input -> [(input, TokenBundle)] +uncategorizeUTxOEntries utxo = mconcat + [ supporters utxo + , freeriders utxo + , ignorables utxo + ] diff --git a/lib/core/src/Cardano/Wallet/Primitive/Migration/Selection.hs b/lib/core/src/Cardano/Wallet/Primitive/Migration/Selection.hs new file mode 100644 index 00000000000..6cc8c59e444 --- /dev/null +++ b/lib/core/src/Cardano/Wallet/Primitive/Migration/Selection.hs @@ -0,0 +1,960 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Copyright: © 2021 IOHK +-- License: Apache-2.0 +-- +-- This module contains functions for incrementally constructing a selection +-- to be included in a migration plan. +-- +-- A selection is the basis for a single transaction. +-- +-- Use 'create' to create a selection with one or more inputs. +-- Use 'extend' to extend a selection with an additional input. +-- +module Cardano.Wallet.Primitive.Migration.Selection + ( + -- * Types + Selection (..) + , SelectionError (..) + , SelectionFullError (..) + , RewardWithdrawal (..) + , TxSize (..) + + -- * Creating selections + , create + + -- * Extending selections + , extend + + -- * Balancing selections + , balance + + -- * Adding value to outputs + , addValueToOutputs + + -- * Minimizing fees + , minimizeFee + , minimizeFeeStep + + -- * Computing bulk properties of selections + , computeCurrentFee + , computeCurrentSize + , computeMinimumFee + + -- * Verifying selections for correctness + , verify + , SelectionCorrectness (..) + + ) where + +import Prelude + +import Cardano.Wallet.Primitive.Types.Coin + ( Coin (..) ) +import Cardano.Wallet.Primitive.Types.TokenBundle + ( TokenBundle (..) ) +import Cardano.Wallet.Primitive.Types.TokenMap + ( TokenMap ) +import Cardano.Wallet.Primitive.Types.Tx + ( TxConstraints (..) + , txOutputCoinCost + , txOutputHasValidSize + , txOutputHasValidTokenQuantities + ) +import Control.Monad + ( (>=>) ) +import Data.Bifunctor + ( first ) +import Data.Either.Extra + ( eitherToMaybe, maybeToEither ) +import Data.Generics.Internal.VL.Lens + ( view ) +import Data.Generics.Labels + () +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Maybe + ( catMaybes, listToMaybe ) +import GHC.Generics + ( Generic ) + +import qualified Cardano.Wallet.Primitive.Types.Coin as Coin +import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle +import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set + +-------------------------------------------------------------------------------- +-- Selections +-------------------------------------------------------------------------------- + +-- | A selection is the basis for a single transaction. +-- +-- Use 'create' to create a selection with one or more inputs. +-- Use 'extend' to extend a selection with an additional input. +-- Use 'verify' to verify the correctness of a selection. +-- +data Selection input size = Selection + { inputIds :: !(NonEmpty input) + -- ^ The selected inputs. + , inputBalance :: !TokenBundle + -- ^ The total balance of value provided by the inputs. + , outputs :: !(NonEmpty TokenBundle) + -- ^ The outputs, adjusted to pay for the fee. + , fee :: !Coin + -- ^ The actual fee payable for this selection. + , feeExcess :: !Coin + -- ^ The excess over the minimum permissible fee for this selection. + , size :: !size + -- ^ The size of this selection. + , rewardWithdrawal :: !Coin + -- ^ The reward withdrawal amount, if any. + } + deriving (Eq, Generic, Show) + +newtype RewardWithdrawal = RewardWithdrawal + { unRewardWithdrawal :: Coin } + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- Selection errors +-------------------------------------------------------------------------------- + +-- | Indicates a failure to create or extend a selection. +-- +data SelectionError size + = SelectionAdaInsufficient + -- ^ Indicates that the desired selection would not have enough ada to pay + -- for the minimum permissible fee. + | SelectionFull + -- ^ Indicates that the desired selection would exceed the maximum + -- selection size. + (SelectionFullError size) + deriving (Eq, Show) + +data SelectionFullError size = SelectionFullError + { selectionSizeMaximum :: size + , selectionSizeRequired :: size + } + deriving (Eq, Show) + +-------------------------------------------------------------------------------- +-- Creating selections +-------------------------------------------------------------------------------- + +-- | Creates a selection with the given inputs. +-- +-- Guarantees the following property for a returned selection 's': +-- +-- >>> verify s == SelectionCorrect +-- +-- Returns 'SelectionAdaInsufficient' if the desired selection would not have +-- enough ada to pay for the fee. +-- +-- Returns 'SelectionFull' if the desired selection would exceed the maximum +-- selection size. +-- +create + :: forall input size. TxSize size + => TxConstraints size + -> RewardWithdrawal + -> NonEmpty (input, TokenBundle) + -> Either (SelectionError size) (Selection input size) +create constraints reward inputs = + balance constraints $ Selection + { inputBalance = F.foldMap snd inputs + , inputIds = fst <$> inputs + , outputs = assignMinimumAdaQuantity constraints <$> + F.foldl' + (addValueToOutputs constraints . NE.toList) + (addValueToOutputs constraints [] (NE.head inputMaps)) + (NE.tail inputMaps) + , fee = Coin 0 + , feeExcess = Coin 0 + , size = mempty + , rewardWithdrawal = unRewardWithdrawal reward + } + where + inputMaps = view #tokens . snd <$> inputs + +-------------------------------------------------------------------------------- +-- Extending selections +-------------------------------------------------------------------------------- + +-- | Extends a selection with an additional input. +-- +-- Guarantees the following property for a returned selection 's': +-- +-- >>> verify s == SelectionCorrect +-- +-- Returns 'SelectionAdaInsufficient' if the desired selection would not have +-- enough ada to pay for the fee. +-- +-- Returns 'SelectionFull' if the desired selection would exceed the maximum +-- selection size. +-- +extend + :: forall input size. TxSize size + => TxConstraints size + -> Selection input size + -> (input, TokenBundle) + -> Either (SelectionError size) (Selection input size) +extend constraints selection (inputId, inputBundle) = + balance constraints $ Selection + { inputBalance = inputBundle <> inputBalance selection + , inputIds = inputId `NE.cons` inputIds selection + , outputs = assignMinimumAdaQuantity constraints <$> + addValueToOutputs constraints + (view #tokens <$> NE.toList (outputs selection)) + (view #tokens inputBundle) + , fee = Coin 0 + , feeExcess = Coin 0 + , size = mempty + , rewardWithdrawal = rewardWithdrawal selection + } + +-------------------------------------------------------------------------------- +-- Balancing selections +-------------------------------------------------------------------------------- + +-- | Balances the fee for a given selection. +-- +-- The ada quantities of the outputs are maximized in order to minimize the fee +-- excess. +-- +-- Guarantees the following property for a returned selection 's': +-- +-- >>> verify s == SelectionCorrect +-- +balance + :: forall input size. TxSize size + => TxConstraints size + -> Selection input size + -> Either (SelectionError size) (Selection input size) +balance constraints unbalancedSelection = do + let minimizedOutputs = outputs unbalancedSelection + unbalancedFee <- first (const SelectionAdaInsufficient) $ + computeCurrentFee unbalancedSelection + let minimumFeeForUnbalancedSelection = + computeMinimumFee constraints unbalancedSelection + unbalancedFeeExcess <- maybeToEither SelectionAdaInsufficient $ + Coin.subtractCoin unbalancedFee minimumFeeForUnbalancedSelection + let (minimizedFeeExcess, maximizedOutputs) = minimizeFee constraints + (unbalancedFeeExcess, minimizedOutputs) + let costIncrease = Coin.distance + (totalCoinCost minimizedOutputs) + (totalCoinCost maximizedOutputs) + let balancedSelection = unbalancedSelection + { fee = mconcat + [ minimumFeeForUnbalancedSelection + , minimizedFeeExcess + , costIncrease + ] + , feeExcess = minimizedFeeExcess + , outputs = maximizedOutputs + } + size <- guardSize constraints $ + computeCurrentSize constraints balancedSelection + pure balancedSelection {size} + where + totalCoinCost :: NonEmpty TokenBundle -> Coin + totalCoinCost = F.foldMap (txOutputCoinCost constraints . view #coin) + +assignMinimumAdaQuantity :: TxConstraints size -> TokenMap -> TokenBundle +assignMinimumAdaQuantity constraints m = + TokenBundle c m + where + c = txOutputMinimumAdaQuantity constraints m + +-------------------------------------------------------------------------------- +-- Adding value to outputs +-------------------------------------------------------------------------------- + +-- | Adds value (obtained from an input) to an existing set of output maps. +-- +-- This function attempts to merge the given value into one of the existing +-- output maps. If merging is successful, then the returned output map list +-- will be identical in length and content to the original output map list, +-- except for the merged output. +-- +-- If the given value cannot be merged into one of the existing output maps +-- (because it would cause an output to exceed the output size limit), then +-- this function appends the given output map to the given output map list, +-- effectively creating a new output. +-- +-- Pre-condition: all output maps in the given list must be within the output +-- size limit. +-- +-- Assuming the above pre-condition is met, this function guarantees that all +-- output maps in the returned list will also be within the output size limit. +-- +addValueToOutputs + :: TxSize size + => TxConstraints size + -> [TokenMap] + -- ^ Outputs + -> TokenMap + -- ^ Output value to add + -> NonEmpty TokenMap + -- ^ Outputs with the additional value added +addValueToOutputs constraints outputsOriginal outputUnchecked = + -- We need to be a bit careful with the output value to be added, as it may + -- itself be oversized. We split it up if any of the output size limits are + -- exceeded: + NE.fromList + $ F.foldl' (flip add) outputsOriginal + $ splitOutputIfLimitsExceeded constraints outputUnchecked + where + -- Add an output value (whose size has been checked) to the existing + -- outputs, merging it into one of the existing outputs if possible. + add :: TokenMap -> [TokenMap] -> [TokenMap] + add output outputs = run [] outputsSorted + where + -- Attempt to merge the specified output value into one of the existing + -- outputs, by trying each existing output in turn, and terminating as + -- soon as a successful candidate for merging is found. + run :: [TokenMap] -> [TokenMap] -> [TokenMap] + run considered (candidate : unconsidered) = + case safeMerge output candidate of + Just merged -> merged : (considered <> unconsidered) + Nothing -> run (candidate : considered) unconsidered + run considered [] = + -- Merging with an existing output is not possible, so just make + -- a new output. + output : considered + + -- To minimize both the number of merge attempts and the size increase + -- of the merged output compared to the original, we sort the existing + -- outputs into ascending order according to the number of assets that + -- would need to be added to each output. + -- + -- In the absolute ideal case, where an existing output's assets are a + -- superset of the output value to be added, merging with that output + -- will not increase its asset count. + -- + -- As a tie-breaker, we give priority to outputs with smaller numbers + -- of assets. Merging with a smaller output is more likely to succeed, + -- because merging with a larger output is more likely to fall foul of + -- the output size limit. + outputsSorted :: [TokenMap] + outputsSorted = L.sortOn sortOrder outputs + where + sortOrder targetOutput = + (targetOutputAssetCountIncrease, targetOutputAssetCount) + where + targetOutputAssetCount + = Set.size targetOutputAssets + targetOutputAssetCountIncrease + = Set.size + $ Set.difference sourceOutputAssets targetOutputAssets + sourceOutputAssets = TokenMap.getAssets output + targetOutputAssets = TokenMap.getAssets targetOutput + + safeMerge :: TokenMap -> TokenMap -> Maybe TokenMap + safeMerge a b + | isSafe = Just value + | otherwise = Nothing + where + isSafe = (&&) + (txOutputHasValidSizeIfAdaMaximized constraints value) + (txOutputHasValidTokenQuantities constraints value) + value = a <> b + +-------------------------------------------------------------------------------- +-- Splitting output values +-------------------------------------------------------------------------------- + +-- | Splits up an output map into smaller maps if it exceeds any of the limits. +-- +splitOutputIfLimitsExceeded + :: TxSize size + => TxConstraints size + -> TokenMap + -> NonEmpty TokenMap +splitOutputIfLimitsExceeded constraints = + splitOutputIfTokenQuantityExceedsLimit constraints >=> + splitOutputIfSizeExceedsLimit constraints + +-- | Splits up an output map if it exceeds the serialized size limit. +-- +splitOutputIfSizeExceedsLimit + :: TxSize size + => TxConstraints size + -> TokenMap + -> NonEmpty TokenMap +splitOutputIfSizeExceedsLimit constraints value + | txOutputHasValidSizeIfAdaMaximized constraints value = + pure value + | otherwise = + split value >>= splitOutputIfSizeExceedsLimit constraints + | otherwise = + pure value + where + split = flip TokenMap.equipartitionAssets (() :| [()]) + +-- | Splits up an output map if any individual token quantity exceeds the limit. +-- +splitOutputIfTokenQuantityExceedsLimit + :: TxConstraints size + -> TokenMap + -> NonEmpty TokenMap +splitOutputIfTokenQuantityExceedsLimit + = flip TokenMap.equipartitionQuantitiesWithUpperBound + . txOutputMaximumTokenQuantity + +-- | Checks that an output has a valid size even if it is assigned the maximum +-- possible ada quantity. +-- +-- Using this function to check all outputs provided to 'balance' will ensure +-- that it has complete freedom to adjust the ada quantities of those outputs, +-- without exceeding the output size limit. +-- +txOutputHasValidSizeIfAdaMaximized + :: TxSize size => TxConstraints size -> TokenMap -> Bool +txOutputHasValidSizeIfAdaMaximized constraints output = + txOutputHasValidSize constraints (TokenBundle maxBound output) + +-------------------------------------------------------------------------------- +-- Minimizing fees +-------------------------------------------------------------------------------- + +-- | Minimizes the given fee excess by adding ada to the given output bundles. +-- +-- This function: +-- +-- - guarantees to leave all non-ada quantities unchanged. +-- +-- - guarantees to not change the length of the list. +-- +-- - guarantees that each resulting output bundle will have an ada quantity +-- that is greater than or equal to its original ada quantity. +-- +-- - guarantees that the resulting fee excess will be less than or equal to +-- the original fee excess. +-- +-- - does not check that the given ada quantities are above the minimum +-- required for each output, and therefore only guarantees that the +-- resulting ada quantities will be above the minimum required if the +-- caller makes this guarantee for the original output bundles. +-- +-- This function aims to adjust as few output bundles as possible, and in the +-- ideal case, will increase the ada quantity of just one output bundle. +-- +-- Increasing the ada quantity of an output may increase the overall cost of +-- that output, as increasing an ada quantity may increase the length of the +-- binary representation used to encode that quantity. +-- +-- By maximizing the ada increase of a single output, and minimizing the ada +-- increases of the remaining outputs, we can minimize the cost increase of +-- the overall selection, and therefore maximize the chance of being able to +-- pay for the selection. +-- +-- This is a consequence of the following mathematical relationship: +-- +-- Consider a non-negative integer constant 'a' defined in terms of a summation +-- of a fixed number 'n' of non-negative integer variables: +-- +-- >>> a = a1 + a2 + a3 + ... + an +-- +-- Now consider the total space 's' required to encode all of the variables: +-- +-- >>> s = length a1 + length a2 + length a3 + ... + length an +-- +-- For any given number base, we can get close to the minimal value of 's' by +-- making the following assignments: +-- +-- >>> a1 := a +-- >>> a2 := 0 +-- >>> a3 := 0 +-- >>> ... +-- >>> an := 0 +-- +-- Consider the following example, working in base 10: +-- +-- >>> a = 999 +-- >>> n = 9 +-- +-- If we were to use a flat distribution, where the constant is partitioned +-- into 'n' equal quantities (modulo rounding), our space cost 's' would be: +-- +-- >>> s = length a1 + length a2 + length a3 + ... + length a9 +-- >>> s = length 111 + length 111 + length 111 + ... + length 111 +-- >>> s = 3 + 3 + 3 + ... + 3 +-- >>> s = 3 × 9 +-- >>> s = 27 +-- +-- But by maximizing 'a1' and minimizing the remaining variables, we can obtain +-- the following smaller space cost: +-- +-- >>> s = length a1 + length a2 + length a3 + ... + length a9 +-- >>> s = length 999 + length 0 + length 0 + ... + length 0 +-- >>> s = 3 + 1 + 1 + ... + 1 +-- >>> s = 3 + 8 +-- >>> s = 11 +-- +minimizeFee + :: TxConstraints size + -> (Coin, NonEmpty TokenBundle) + -- ^ Fee excess and output bundles. + -> (Coin, NonEmpty TokenBundle) + -- ^ Fee excess and output bundles after optimization. +minimizeFee constraints (currentFeeExcess, outputs) = + NE.fromList <$> run currentFeeExcess (NE.toList outputs) [] + where + run :: Coin -> [TokenBundle] -> [TokenBundle] -> (Coin, [TokenBundle]) + run (Coin 0) remaining processed = + (Coin 0, processed <> remaining) + run feeExcessRemaining [] processed = + (feeExcessRemaining, processed) + run feeExcessRemaining (output : remaining) processed = + run feeExcessRemaining' remaining (output' : processed) + where + (feeExcessRemaining', output') = + minimizeFeeStep constraints (feeExcessRemaining, output) + +-- | Minimizes the given fee excess by adding ada to the given output. +-- +-- This function: +-- +-- - guarantees to leave all non-ada quantities unchanged. +-- +-- - increases the ada quantity of the given output until it is no longer +-- economically worthwhile to increase it further (i.e., if the cost of +-- a further increase would be greater than the increase itself). +-- +-- - guarantees that the resulting output bundle will have an ada quantity +-- that is greater than or equal to its original ada quantity. +-- +-- - guarantees that the resulting fee excess will be less than or equal to +-- the original fee excess. +-- +-- Returns the minimized fee excess and the modified output. +-- +minimizeFeeStep + :: TxConstraints size + -> (Coin, TokenBundle) + -- ^ Fee excess and output bundle. + -> (Coin, TokenBundle) + -- ^ Fee excess and output bundle after optimization. +minimizeFeeStep constraints = + findFixedPoint reduceFee + where + reduceFee :: (Coin, TokenBundle) -> (Coin, TokenBundle) + reduceFee (feeExcess, outputBundle) + | outputCoinFinal > outputCoin && + outputCoinFinalCostIncrease < outputCoinFinalIncrease = + (feeExcessFinal, outputBundleFinal) + | otherwise = + (feeExcess, outputBundle) + where + outputCoin = view #coin outputBundle + outputCoinMaxCostIncrease = Coin.distance + (txOutputCoinCost constraints outputCoin) + (txOutputCoinCost constraints $ outputCoin <> feeExcess) + outputCoinFinal = Coin + $ unCoin outputCoin + + unCoin feeExcess + - unCoin outputCoinMaxCostIncrease + outputCoinFinalCostIncrease = Coin.distance + (txOutputCoinCost constraints outputCoin) + (txOutputCoinCost constraints outputCoinFinal) + outputCoinFinalIncrease = Coin.distance outputCoin outputCoinFinal + outputBundleFinal = TokenBundle.setCoin outputBundle outputCoinFinal + feeExcessFinal = Coin + $ unCoin feeExcess + - unCoin outputCoinFinalIncrease + - unCoin outputCoinFinalCostIncrease + +-------------------------------------------------------------------------------- +-- Computing bulk properties of selections +-------------------------------------------------------------------------------- + +-- | Calculates the current fee for a selection. +-- +computeCurrentFee :: Selection input size -> Either NegativeCoin Coin +computeCurrentFee Selection {inputBalance, outputs, rewardWithdrawal} + | adaBalanceIn >= adaBalanceOut = + Right adaDifference + | otherwise = + Left (NegativeCoin adaDifference) + where + adaBalanceIn = + rewardWithdrawal <> view #coin inputBalance + adaBalanceOut = + F.foldMap (TokenBundle.getCoin) outputs + adaDifference = + Coin.distance adaBalanceIn adaBalanceOut + +-- | Calculates the current size of a selection. +-- +computeCurrentSize + :: TxSize size + => TxConstraints size + -> Selection input size + -> size +computeCurrentSize constraints selection = mconcat + [ txBaseSize constraints + , F.foldMap (const $ txInputSize constraints) (inputIds selection) + , F.foldMap (txOutputSize constraints) (outputs selection) + , txRewardWithdrawalSize constraints (rewardWithdrawal selection) + ] + +-- | Calculates the minimum permissible fee for a selection. +-- +computeMinimumFee :: TxConstraints size -> Selection input size -> Coin +computeMinimumFee constraints selection = mconcat + [ txBaseCost constraints + , F.foldMap (const $ txInputCost constraints) (inputIds selection) + , F.foldMap (txOutputCost constraints) (outputs selection) + , txRewardWithdrawalCost constraints (rewardWithdrawal selection) + ] + +-------------------------------------------------------------------------------- +-- Verifying selections for correctness +-------------------------------------------------------------------------------- + +-- | Indicates whether or not a selection is correct. +-- +data SelectionCorrectness size + = SelectionCorrect + | SelectionIncorrect (SelectionCorrectnessError size) + deriving (Eq, Show) + +-- | Indicates that a selection is incorrect. +-- +data SelectionCorrectnessError size + = SelectionAssetBalanceIncorrect + SelectionAssetBalanceIncorrectError + | SelectionFeeIncorrect + SelectionFeeIncorrectError + | SelectionFeeExcessIncorrect + SelectionFeeExcessIncorrectError + | SelectionFeeInsufficient + SelectionFeeInsufficientError + | SelectionOutputBelowMinimumAdaQuantity + SelectionOutputBelowMinimumAdaQuantityError + | SelectionOutputSizeExceedsLimit + SelectionOutputSizeExceedsLimitError + | SelectionSizeExceedsLimit + (SelectionSizeExceedsLimitError size) + | SelectionSizeIncorrect + (SelectionSizeIncorrectError size) + deriving (Eq, Show) + +-- | Verifies a selection for correctness. +-- +-- This function is provided primarily as a convenience for testing. As such, +-- it's not usually necessary to call this function from ordinary application +-- code, unless you suspect that a selection value is incorrect in some way. +-- +verify + :: forall input size. TxSize size + => TxConstraints size + -> Selection input size + -> SelectionCorrectness size +verify constraints selection = + either SelectionIncorrect (const SelectionCorrect) verifyAll + where + verifyAll :: Either (SelectionCorrectnessError size) () + verifyAll = do + checkAssetBalance selection + `failWith` SelectionAssetBalanceIncorrect + checkFee selection + `failWith` SelectionFeeIncorrect + checkFeeSufficient constraints selection + `failWith` SelectionFeeInsufficient + checkFeeExcess constraints selection + `failWith` SelectionFeeExcessIncorrect + checkOutputMinimumAdaQuantities constraints selection + `failWith` SelectionOutputBelowMinimumAdaQuantity + checkOutputSizes constraints selection + `failWith` SelectionOutputSizeExceedsLimit + checkSizeWithinLimit constraints selection + `failWith` SelectionSizeExceedsLimit + checkSizeCorrectness constraints selection + `failWith` SelectionSizeIncorrect + + failWith :: Maybe e1 -> (e1 -> e2) -> Either e2 () + onError `failWith` thisError = maybe (Right ()) (Left . thisError) onError + +-------------------------------------------------------------------------------- +-- Selection correctness: asset balance correctness +-------------------------------------------------------------------------------- + +data SelectionAssetBalanceIncorrectError = SelectionAssetBalanceIncorrectError + { assetBalanceInputs + :: TokenMap + , assetBalanceOutputs + :: TokenMap + } + deriving (Eq, Show) + +checkAssetBalance + :: Selection input size + -> Maybe SelectionAssetBalanceIncorrectError +checkAssetBalance Selection {inputBalance, outputs} + | assetBalanceInputs == assetBalanceOutputs = + Nothing + | otherwise = + Just SelectionAssetBalanceIncorrectError + { assetBalanceInputs + , assetBalanceOutputs + } + where + assetBalanceInputs = view #tokens inputBalance + assetBalanceOutputs = F.foldMap (tokens) outputs + +-------------------------------------------------------------------------------- +-- Selection correctness: fee correctness +-------------------------------------------------------------------------------- + +data SelectionFeeIncorrectError = SelectionFeeIncorrectError + { selectionFeeComputed + :: Either NegativeCoin Coin + , selectionFeeStored + :: Coin + } + deriving (Eq, Show) + +checkFee :: Selection input size -> Maybe SelectionFeeIncorrectError +checkFee selection = + case computeCurrentFee selection of + Left negativeFee -> + pure SelectionFeeIncorrectError + { selectionFeeComputed = Left negativeFee + , selectionFeeStored = fee selection + } + Right positiveFee | positiveFee /= fee selection -> + pure SelectionFeeIncorrectError + { selectionFeeComputed = Right positiveFee + , selectionFeeStored = fee selection + } + Right _ -> + Nothing + +-------------------------------------------------------------------------------- +-- Selection correctness: fee excess correctness +-------------------------------------------------------------------------------- + +data SelectionFeeExcessIncorrectError = SelectionFeeExcessIncorrectError + { selectionFeeExcessActual + :: Coin + , selectionFeeExcessExpected + :: Coin + } + deriving (Eq, Show) + +checkFeeExcess + :: TxConstraints size + -> Selection input size + -> Maybe SelectionFeeExcessIncorrectError +checkFeeExcess constraints selection = + checkInner =<< eitherToMaybe (computeCurrentFee selection) + where + checkInner :: Coin -> Maybe SelectionFeeExcessIncorrectError + checkInner currentSelectionFee + | selectionFeeExcessExpected == selectionFeeExcessActual = + Nothing + | otherwise = + Just SelectionFeeExcessIncorrectError + { selectionFeeExcessActual + , selectionFeeExcessExpected + } + where + selectionFeeExcessActual = feeExcess selection + selectionFeeExcessExpected = Coin.distance + (currentSelectionFee) + (computeMinimumFee constraints selection) + +-------------------------------------------------------------------------------- +-- Selection correctness: fee sufficiency +-------------------------------------------------------------------------------- + +data SelectionFeeInsufficientError = SelectionFeeInsufficientError + { selectionFeeActual + :: Either NegativeCoin Coin + , selectionFeeMinimum + :: Coin + } + deriving (Eq, Show) + +checkFeeSufficient + :: TxConstraints size + -> Selection input size + -> Maybe SelectionFeeInsufficientError +checkFeeSufficient constraints selection = + case computeCurrentFee selection of + Left nf -> + Just SelectionFeeInsufficientError + { selectionFeeActual = Left nf + , selectionFeeMinimum + } + Right pf | pf < selectionFeeMinimum -> + Just SelectionFeeInsufficientError + { selectionFeeActual = Right pf + , selectionFeeMinimum + } + Right _ -> + Nothing + where + selectionFeeMinimum = computeMinimumFee constraints selection + +-------------------------------------------------------------------------------- +-- Selection correctness: minimum ada quantities +-------------------------------------------------------------------------------- + +data SelectionOutputBelowMinimumAdaQuantityError = + SelectionOutputBelowMinimumAdaQuantityError + { outputBundle :: TokenBundle + -- ^ The output that is below the expected minimum ada quantity. + , expectedMinimumAdaQuantity :: Coin + -- ^ The expected minimum ada quantity. + } + deriving (Eq, Show) + +checkOutputMinimumAdaQuantities + :: TxConstraints size + -> Selection input size + -> Maybe SelectionOutputBelowMinimumAdaQuantityError +checkOutputMinimumAdaQuantities constraints selection = + maybesToMaybe $ checkOutput <$> outputs selection + where + checkOutput + :: TokenBundle + -> Maybe SelectionOutputBelowMinimumAdaQuantityError + checkOutput outputBundle + | TokenBundle.getCoin outputBundle >= expectedMinimumAdaQuantity = + Nothing + | otherwise = + Just SelectionOutputBelowMinimumAdaQuantityError + { outputBundle + , expectedMinimumAdaQuantity + } + where + expectedMinimumAdaQuantity = + txOutputMinimumAdaQuantity constraints (view #tokens outputBundle) + +-------------------------------------------------------------------------------- +-- Selection correctness: output sizes +-------------------------------------------------------------------------------- + +newtype SelectionOutputSizeExceedsLimitError = + SelectionOutputSizeExceedsLimitError + { selectionOutput :: TokenBundle } + deriving (Eq, Show) + +checkOutputSizes + :: TxSize size + => TxConstraints size + -> Selection input size + -> Maybe SelectionOutputSizeExceedsLimitError +checkOutputSizes constraints selection = + maybesToMaybe $ checkOutput <$> outputs selection + where + checkOutput + :: TokenBundle + -> Maybe SelectionOutputSizeExceedsLimitError + checkOutput selectionOutput + | txOutputHasValidSize constraints selectionOutput = + Nothing + | otherwise = + Just SelectionOutputSizeExceedsLimitError + { selectionOutput } + +-------------------------------------------------------------------------------- +-- Selection correctness: selection size (in comparison to the stored value) +-------------------------------------------------------------------------------- + +data SelectionSizeIncorrectError size = SelectionSizeIncorrectError + { selectionSizeComputed :: size + , selectionSizeStored :: size + } + deriving (Eq, Show) + +checkSizeCorrectness + :: TxSize size + => TxConstraints size + -> Selection input size + -> Maybe (SelectionSizeIncorrectError size) +checkSizeCorrectness constraints selection + | selectionSizeComputed == selectionSizeStored = + Nothing + | otherwise = pure SelectionSizeIncorrectError + { selectionSizeComputed + , selectionSizeStored + } + where + selectionSizeComputed = computeCurrentSize constraints selection + selectionSizeStored = size selection + +-------------------------------------------------------------------------------- +-- Selection correctness: selection size (in comparison to the limit) +-------------------------------------------------------------------------------- + +data SelectionSizeExceedsLimitError size = SelectionSizeExceedsLimitError + { selectionSizeComputed :: size + , selectionSizeMaximum :: size + } + deriving (Eq, Show) + +checkSizeWithinLimit + :: TxSize size + => TxConstraints size + -> Selection input size + -> Maybe (SelectionSizeExceedsLimitError size) +checkSizeWithinLimit constraints selection + | selectionSizeComputed <= selectionSizeMaximum = + Nothing + | otherwise = pure SelectionSizeExceedsLimitError + { selectionSizeComputed + , selectionSizeMaximum + } + where + selectionSizeComputed = computeCurrentSize constraints selection + selectionSizeMaximum = txMaximumSize constraints + +-------------------------------------------------------------------------------- +-- Miscellaneous types and functions +-------------------------------------------------------------------------------- + +newtype NegativeCoin = NegativeCoin + { unNegativeCoin :: Coin + } + deriving (Eq, Show) + +class (Ord size, Monoid size) => TxSize size where + txSizeDistance :: size -> size -> size + +findFixedPoint :: Eq a => (a -> a) -> a -> a +findFixedPoint f = findInner + where + findInner a = let fa = f a in if a == fa then a else findInner fa + +guardSize + :: TxSize size + => TxConstraints size + -> size + -> Either (SelectionError size) size +guardSize constraints selectionSizeRequired + | selectionSizeRequired <= selectionSizeMaximum = + pure selectionSizeRequired + | otherwise = + Left $ SelectionFull SelectionFullError + { selectionSizeMaximum + , selectionSizeRequired + } + where + selectionSizeMaximum = txMaximumSize constraints + +maybesToMaybe :: NonEmpty (Maybe a) -> Maybe a +maybesToMaybe = listToMaybe . catMaybes . NE.toList diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/Tx.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/Tx.hs index bac302f8026..b867998b2c6 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types/Tx.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types/Tx.hs @@ -45,6 +45,16 @@ module Cardano.Wallet.Primitive.Types.Tx , txOutMinTokenQuantity , txOutMaxTokenQuantity + -- * Constraints + , TxConstraints (..) + , txOutputCoinCost + , txOutputCoinSize + , txOutputCoinMinimum + , txOutputIsValid + , txOutputHasValidAdaQuantity + , txOutputHasValidSize + , txOutputHasValidTokenQuantities + ) where import Prelude @@ -493,3 +503,76 @@ txOutMinTokenQuantity = TokenQuantity 1 -- txOutMaxTokenQuantity :: TokenQuantity txOutMaxTokenQuantity = TokenQuantity $ fromIntegral $ maxBound @Word64 + +-------------------------------------------------------------------------------- +-- Constraints +-------------------------------------------------------------------------------- + +-- | Provides an abstract cost and size model for transactions. +-- +-- This allows parts of a transaction to be costed (or sized) individually, +-- without having to compute the cost (or size) of an entire transaction. +-- +-- Note that the following functions assume one witness is required per input: +-- +-- - 'txInputCost' +-- - 'txInputSize' +-- +-- This will lead to slight overestimation in the case of UTxOs that share the +-- same payment key. +-- +data TxConstraints s = TxConstraints + { txBaseCost :: Coin + -- ^ The constant cost of an empty transaction. + , txBaseSize :: s + -- ^ The constant size of an empty transaction. + , txInputCost :: Coin + -- ^ The constant cost of a transaction input, assuming one witness is + -- required per input. + , txInputSize :: s + -- ^ The constant size of a transaction input, assuming one witness is + -- required per input. + , txOutputCost :: TokenBundle -> Coin + -- ^ The variable cost of a transaction output. + , txOutputSize :: TokenBundle -> s + -- ^ The variable size of a transaction output. + , txOutputMaximumSize :: s + -- ^ The maximum size of a transaction output. + , txOutputMaximumTokenQuantity :: TokenQuantity + -- ^ The maximum token quantity that can appear in a transaction output. + , txOutputMinimumAdaQuantity :: TokenMap -> Coin + -- ^ The variable minimum ada quantity of a transaction output. + , txRewardWithdrawalCost :: Coin -> Coin + -- ^ The variable cost of a reward withdrawal. + , txRewardWithdrawalSize :: Coin -> s + -- ^ The variable size of a reward withdrawal. + , txMaximumSize :: s + -- ^ The maximum size of a transaction. + } + +txOutputCoinCost :: TxConstraints s -> Coin -> Coin +txOutputCoinCost constraints = txOutputCost constraints . TokenBundle.fromCoin + +txOutputCoinSize :: TxConstraints s -> Coin -> s +txOutputCoinSize constraints = txOutputSize constraints . TokenBundle.fromCoin + +txOutputCoinMinimum :: TxConstraints s -> Coin +txOutputCoinMinimum constraints = txOutputMinimumAdaQuantity constraints mempty + +txOutputIsValid :: Ord s => TxConstraints s -> TokenBundle -> Bool +txOutputIsValid constraints b = + constraints `txOutputHasValidAdaQuantity` b + && constraints `txOutputHasValidSize` b + && constraints `txOutputHasValidTokenQuantities` (view #tokens b) + +txOutputHasValidAdaQuantity :: TxConstraints s -> TokenBundle -> Bool +txOutputHasValidAdaQuantity constraints (TokenBundle c m) = + c >= txOutputMinimumAdaQuantity constraints m + +txOutputHasValidSize :: Ord s => TxConstraints s -> TokenBundle -> Bool +txOutputHasValidSize constraints b = + txOutputSize constraints b <= txOutputMaximumSize constraints + +txOutputHasValidTokenQuantities :: TxConstraints s -> TokenMap -> Bool +txOutputHasValidTokenQuantities constraints m = + TokenMap.maximumQuantity m <= txOutputMaximumTokenQuantity constraints diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/Migration/PlanningSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/Migration/PlanningSpec.hs new file mode 100644 index 00000000000..ccc0107387b --- /dev/null +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/Migration/PlanningSpec.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Cardano.Wallet.Primitive.Migration.PlanningSpec + where + +import Prelude + +import Cardano.Wallet.Primitive.Migration.Planning + ( CategorizedUTxO (..) + , MigrationPlan (..) + , UTxOEntryCategory (..) + , categorizeUTxOEntries + , categorizeUTxOEntry + , createPlan + , uncategorizeUTxOEntries + ) +import Cardano.Wallet.Primitive.Migration.Selection + ( RewardWithdrawal (..), Selection (..) ) +import Cardano.Wallet.Primitive.Migration.SelectionSpec + ( MockInputId + , MockTxConstraints (..) + , Pretty (..) + , genMockInput + , genRewardWithdrawal + , genTokenBundleMixed + , report + , shrinkMockInput + , testAll + , unMockTxConstraints + , verify + ) +import Cardano.Wallet.Primitive.Types.Coin + ( Coin (..) ) +import Cardano.Wallet.Primitive.Types.TokenBundle + ( TokenBundle (..) ) +import Cardano.Wallet.Primitive.Types.TokenMap + ( TokenMap ) +import Control.Monad + ( replicateM ) +import Data.Either + ( isLeft, isRight ) +import Data.Generics.Internal.VL.Lens + ( view ) +import Data.Generics.Labels + () +import Data.Set + ( Set ) +import Fmt + ( padLeftF, pretty ) +import Test.Hspec + ( Spec, describe, it ) +import Test.Hspec.Core.QuickCheck + ( modifyMaxSuccess ) +import Test.Hspec.Extra + ( parallel ) +import Test.QuickCheck + ( Blind (..) + , Gen + , Property + , checkCoverage + , choose + , cover + , forAllBlind + , forAllShrink + , property + , shrinkList + , tabulate + , withMaxSuccess + , (===) + ) + +import qualified Cardano.Wallet.Primitive.Migration.Selection as Selection +import qualified Cardano.Wallet.Primitive.Types.Coin as Coin +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set + +spec :: Spec +spec = describe "Cardano.Wallet.Primitive.Migration.PlanningSpec" $ + + modifyMaxSuccess (const 1000) $ do + + parallel $ describe "Creating migration plans" $ do + + describe "Empty migrations" $ + it "prop_createPlan_empty" $ + property prop_createPlan_empty + + describe "Small migrations" $ + it "prop_createPlan_small" $ + property prop_createPlan_small + + describe "Large migrations" $ + it "prop_createPlan_large" $ + property prop_createPlan_large + + describe "Giant migrations" $ + it "prop_createPlan_giant" $ + property prop_createPlan_giant + + parallel $ describe "Categorizing UTxO entries" $ do + + it "prop_categorizeUTxOEntries" $ + property prop_categorizeUTxOEntries + it "prop_categorizeUTxOEntry" $ + property prop_categorizeUTxOEntry + +-------------------------------------------------------------------------------- +-- Creating migration plans +-------------------------------------------------------------------------------- + +prop_createPlan_empty :: Blind MockTxConstraints -> Property +prop_createPlan_empty (Blind mockConstraints) = + withMaxSuccess 1 $ + prop_createPlan (0, 0) mockConstraints + +prop_createPlan_small :: Blind MockTxConstraints -> Property +prop_createPlan_small (Blind mockConstraints) = + withMaxSuccess 100 $ + prop_createPlan (1, 100) mockConstraints + +prop_createPlan_large :: Blind MockTxConstraints -> Property +prop_createPlan_large (Blind mockConstraints) = + withMaxSuccess 10 $ + prop_createPlan (1_000, 1_000) mockConstraints + +prop_createPlan_giant :: Blind MockTxConstraints -> Property +prop_createPlan_giant (Blind mockConstraints) = + withMaxSuccess 1 $ + prop_createPlan (10_000, 10_000) mockConstraints + +prop_createPlan :: (Int, Int) -> MockTxConstraints -> Property +prop_createPlan inputCountRange mockConstraints = + forAllBlind genInputs $ \inputs -> + forAllBlind genRewardWithdrawal $ \reward -> + prop_createPlan_inner mockConstraints inputs reward + where + genInputs :: Gen [(MockInputId, TokenBundle)] + genInputs = do + mockInputCount <- choose inputCountRange + replicateM mockInputCount (genMockInput mockConstraints) + +prop_createPlan_inner + :: MockTxConstraints + -> [(MockInputId, TokenBundle)] + -> RewardWithdrawal + -> Property +prop_createPlan_inner mockConstraints inputs reward = + makeReports $ makeStatistics $ testAll makeTests + where + makeTests + = verify + (inputIdsAll == Set.union inputIdsSelected inputIdsNotSelected) + "inputs are preserved (union)" + . verify + (Set.empty == Set.intersection inputIdsSelected inputIdsNotSelected) + "inputs are preserved (intersection)" + . verify + (totalInputAda >= totalOutputAda) + "ada is consumed and not created" + . verify + (totalInputTokenBalance == totalOutputTokenBalance) + "balance of non-ada tokens is preserved" + . verify + (totalFee result == totalFeeExpected) + "total fee is correct" + . verify + (rewardWithdrawalCount <= 1) + "at most one transaction has reward withdrawal" + . verify + (rewardWithdrawalAmount == rewardWithdrawalExpected) + "reward withdrawal amount correct" + . verify + (null (supporters (unselected result))) + "every supporter is selected" + + makeReports + = report mockConstraints + "mockConstraints" + . report (length $ supporters categorizedUTxO) + "count of supporters available" + . report (length $ supporters $ unselected result) + "count of supporters not selected" + . report (length $ freeriders categorizedUTxO) + "count of freeriders available" + . report (length $ freeriders $ unselected result) + "count of freeriders not selected" + . report (length $ ignorables categorizedUTxO) + "count of ignorables available" + . report (length $ ignorables $ unselected result) + "count of ignorables not selected" + . report rewardWithdrawalCount + "count of reward withdrawals" + . report totalInputAda + "total input ada" + . report totalOutputAda + "total output ada" + . report totalFeeExpected + "total fee expected" + . report (totalFee result) + "total fee actual" + . report totalInputTokenBalance + "total input token balance" + . report totalOutputTokenBalance + "total output token balance" + + makeStatistics + = tabulate "Number of transactions required" + [transactionCount] + . tabulate "Mean number of inputs per transaction" + [meanTransactionInputCount] + . tabulate "Mean number of outputs per transaction" + [meanTransactionOutputCount] + . tabulate "Percentage of supporters selected" + [percentageSelected supporters] + . tabulate "Percentage of freeriders selected" + [percentageSelected freeriders] + . tabulate "Percentage of ignorables selected" + [percentageSelected ignorables] + + transactionCount = pretty $ mconcat + [ "[" + , padLeftF 3 '0' (10 * selectionCountDiv10) + , " – " + , padLeftF 3 '0' (10 * (selectionCountDiv10 + 1) - 1) + , "]" + ] + where + selectionCountDiv10 = selectionCount `div` 10 + + meanTransactionInputCount = pretty $ mconcat + [ "[" + , padLeftF 3 '0' (10 * meanTxInputCountDiv10) + , " – " + , padLeftF 3 '0' (10 * (meanTxInputCountDiv10 + 1) - 1) + , "]" + ] + where + meanTxInputCountDiv10 = meanTxInputCount `div` 10 + meanTxInputCount :: Int + meanTxInputCount + | selectionCount == 0 = + 0 + | otherwise = + totalSelectedInputCount `div` selectionCount + totalSelectedInputCount :: Int + totalSelectedInputCount = + L.sum $ L.length . view #inputIds <$> selections result + + meanTransactionOutputCount = pretty $ + padLeftF 3 ' ' meanTxOutputCount + where + meanTxOutputCount :: Int + meanTxOutputCount + | selectionCount == 0 = + 0 + | otherwise = + totalSelectedOutputCount `div` selectionCount + totalSelectedOutputCount :: Int + totalSelectedOutputCount = + L.sum $ L.length . view #outputs <$> selections result + + percentageSelected category = pretty $ + padLeftF 3 ' ' percentage <> "%" + where + percentage :: Int + percentage + | entriesAvailable == 0 = + 100 + | otherwise = + 100 - ((entriesNotSelected * 100) `div` entriesAvailable) + + entriesAvailable :: Int + entriesAvailable = length $ category categorizedUTxO + entriesNotSelected :: Int + entriesNotSelected = length $ category $ unselected result + + constraints = unMockTxConstraints mockConstraints + result = createPlan constraints categorizedUTxO reward + + categorizedUTxO = categorizeUTxOEntries constraints inputs + + inputIdsAll :: Set MockInputId + inputIdsAll = Set.fromList (fst <$> inputs) + + inputIdsSelected :: Set MockInputId + inputIdsSelected = Set.fromList + [ i + | s <- selections result + , i <- NE.toList (view #inputIds s) + ] + + inputIdsNotSelected :: Set MockInputId + inputIdsNotSelected = Set.fromList + $ fmap fst + $ uncategorizeUTxOEntries + $ unselected result + + rewardWithdrawalCount = + length $ filter (> Coin 0) (rewardWithdrawal <$> selections result) + rewardWithdrawalAmount = + RewardWithdrawal $ F.foldMap rewardWithdrawal (selections result) + rewardWithdrawalExpected + | selectionCount == 0 = + RewardWithdrawal $ Coin 0 + | otherwise = + reward + + selectionCount = length (selections result) + + totalFeeExpected :: Coin + totalFeeExpected + | not (null (selections result)) = + Coin.distance totalInputAda totalOutputAda + | otherwise = + Coin 0 + + totalInputAda :: Coin + totalInputAda = mconcat + [ F.foldMap (view #coin . view #inputBalance) (selections result) + , unRewardWithdrawal reward + ] + + totalOutputAda :: Coin + totalOutputAda = + F.foldMap (view #coin . F.fold . view #outputs) (selections result) + + totalInputTokenBalance :: TokenMap + totalInputTokenBalance = + F.foldMap (view #tokens . view #inputBalance) (selections result) + + totalOutputTokenBalance :: TokenMap + totalOutputTokenBalance = + F.foldMap (view #tokens . F.fold . view #outputs) (selections result) + +-------------------------------------------------------------------------------- +-- Categorizing multiple UTxO entries +-------------------------------------------------------------------------------- + +prop_categorizeUTxOEntries :: Blind MockTxConstraints -> Property +prop_categorizeUTxOEntries (Blind mockConstraints) = + forAllShrink genEntries (shrinkList shrinkMockInput) prop + where + prop :: [(MockInputId, TokenBundle)] -> Property + prop entries = (===) + (Pretty $ L.sortOn fst $ uncategorizeUTxOEntries categorizedEntries) + (Pretty $ L.sortOn fst entries) + where + categorizedEntries = categorizeUTxOEntries constraints entries + constraints = unMockTxConstraints mockConstraints + + genEntries :: Gen [(MockInputId, TokenBundle)] + genEntries = do + mockEntryCount <- choose (1, 100) + replicateM mockEntryCount (genMockInput mockConstraints) + +-------------------------------------------------------------------------------- +-- Categorizing individual UTxO entries +-------------------------------------------------------------------------------- + +prop_categorizeUTxOEntry :: Blind MockTxConstraints -> Property +prop_categorizeUTxOEntry (Blind mockConstraints) = + forAllBlind (genTokenBundleMixed mockConstraints) prop + where + prop :: TokenBundle -> Property + prop entry = + checkCoverage $ + cover 5 (result == Supporter) "Supporter" $ + cover 5 (result == Freerider) "Freerider" $ + cover 5 (result == Ignorable) "Ignorable" $ + report mockConstraints "mockConstraints" $ + property + $ selectionCreateExpectation + $ Selection.create constraints + (RewardWithdrawal $ Coin 0) [((), entry)] + where + constraints = unMockTxConstraints mockConstraints + result = categorizeUTxOEntry constraints entry + selectionCreateExpectation = case result of + Supporter -> isRight + Freerider -> isLeft + Ignorable -> isLeft + +-------------------------------------------------------------------------------- +-- Miscellaneous types and functions +-------------------------------------------------------------------------------- + +coinToInteger :: Coin -> Integer +coinToInteger = fromIntegral . unCoin diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/Migration/SelectionSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/Migration/SelectionSpec.hs new file mode 100644 index 00000000000..d4ae0a350c7 --- /dev/null +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/Migration/SelectionSpec.hs @@ -0,0 +1,1132 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Cardano.Wallet.Primitive.Migration.SelectionSpec + where + +import Prelude + +import Cardano.Wallet.Primitive.Migration.Selection + ( RewardWithdrawal (..) + , Selection (..) + , SelectionCorrectness (..) + , SelectionError (..) + , SelectionFullError (..) + , TxSize (..) + , addValueToOutputs + , create + , extend + , minimizeFee + , minimizeFeeStep + ) +import Cardano.Wallet.Primitive.Types.Coin + ( Coin (..) ) +import Cardano.Wallet.Primitive.Types.Hash + ( Hash (..) ) +import Cardano.Wallet.Primitive.Types.TokenBundle + ( Flat (..), TokenBundle (..) ) +import Cardano.Wallet.Primitive.Types.TokenMap + ( AssetId (..), TokenMap ) +import Cardano.Wallet.Primitive.Types.TokenPolicy + ( TokenName (..), TokenPolicyId (..) ) +import Cardano.Wallet.Primitive.Types.TokenQuantity + ( TokenQuantity (..) ) +import Cardano.Wallet.Primitive.Types.Tx + ( TxConstraints (..) + , txOutputCoinCost + , txOutputCoinMinimum + , txOutputCoinSize + , txOutputHasValidSize + , txOutputHasValidTokenQuantities + ) +import Control.Monad + ( replicateM ) +import Data.ByteArray.Encoding + ( Base (Base16), convertToBase ) +import Data.ByteString + ( ByteString ) +import Data.Either + ( isRight ) +import Data.Either.Extra + ( eitherToMaybe ) +import Data.Functor + ( (<&>) ) +import Data.Generics.Internal.VL.Lens + ( view ) +import Data.Generics.Labels + () +import Data.List.NonEmpty + ( NonEmpty (..) ) +import Data.Maybe + ( fromMaybe ) +import Data.Semigroup + ( mtimesDefault, stimes ) +import Data.Word + ( Word8 ) +import Fmt + ( Builder, build, indentF, pretty ) +import Numeric.Natural + ( Natural ) +import Test.Hspec + ( Spec, describe, it ) +import Test.Hspec.Core.QuickCheck + ( modifyMaxSuccess ) +import Test.Hspec.Extra + ( parallel ) +import Test.QuickCheck + ( Arbitrary (..) + , Blind (..) + , Gen + , Property + , Testable + , checkCoverage + , choose + , counterexample + , cover + , elements + , forAllBlind + , frequency + , genericShrink + , oneof + , property + , suchThat + , suchThatMap + , vectorOf + , withMaxSuccess + , (.&&.) + ) +import Text.Pretty.Simple + ( pShow ) + +import qualified Cardano.Wallet.Primitive.Migration.Selection as Selection +import qualified Cardano.Wallet.Primitive.Types.Coin as Coin +import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle +import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Foldable as F +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL + +spec :: Spec +spec = describe "Cardano.Wallet.Primitive.Migration.SelectionSpec" $ + + modifyMaxSuccess (const 1000) $ do + + parallel $ describe "Creating selections" $ do + + it "prop_create" $ + property prop_create + + parallel $ describe "Extending selections" $ do + + it "prop_extend" $ + property prop_extend + + parallel $ describe "Adding value to outputs" $ do + + it "prop_addValueToOutputs" $ + property prop_addValueToOutputs + + parallel $ describe "Minimizing fees" $ do + + it "prop_minimizeFee" $ + property prop_minimizeFee + it "prop_minimizeFeeStep" $ + property prop_minimizeFeeStep + + parallel $ describe "Constraint calculations" $ do + + it "prop_txOutputCost" $ + property prop_txOutputCost + it "prop_txOutputSize" $ + property prop_txOutputSize + +-------------------------------------------------------------------------------- +-- Creating a selection +-------------------------------------------------------------------------------- + +type MockSelection = Selection MockInputId MockSize +type MockSelectionError = SelectionError MockSize +type MockSelectionResult = Either MockSelectionError MockSelection + +prop_create :: Blind MockTxConstraints -> Property +prop_create (Blind mockConstraints) = + forAllBlind genInputs $ \inputs -> + forAllBlind genRewardWithdrawal $ \reward -> + prop_create_inner mockConstraints inputs reward + where + genInputs :: Gen (NonEmpty (MockInputId, TokenBundle)) + genInputs = do + inputCount <- choose (1, 32) + (:|) + <$> genMockInput mockConstraints + <*> replicateM (inputCount - 1) (genMockInput mockConstraints) + +prop_create_inner + :: MockTxConstraints + -> NonEmpty (MockInputId, TokenBundle) + -> RewardWithdrawal + -> Property +prop_create_inner mockConstraints inputs reward = + checkCoverage $ + cover 50 (resultIsSelection result) + "Success" $ + cover 50 (resultHasZeroFeeExcess result) + "Success with zero fee excess" $ + cover 1 (resultHasInsufficientAda result) + "Failure due to insufficient ada" $ + cover 1 (resultIsFull result) + "Failure due to oversized selection" $ + report mockConstraints + "mockConstraints" $ + case result of + Left SelectionAdaInsufficient -> + property True + Left (SelectionFull e) -> + property (selectionSizeMaximum e < selectionSizeRequired e) + Right selection -> makeReports $ testAll + $ verify + (correctness == SelectionCorrect) + "correctness == SelectionCorrect" + . verify + (Selection.balance constraints selection == Right selection) + "Rebalancing the selection leaves it unchanged" + . verify + (feeExcess selection == feeExcessExpected) + "feeExcess selection == feeExcessExpected" + where + makeReports + = report correctness + "correctness" + . report feeExcessExpected + "feeExcessExpected" + correctness = + Selection.verify constraints selection + (feeExcessExpected, _) = + minimizeFee constraints (feeExcess selection, outputs selection) + where + constraints = unMockTxConstraints mockConstraints + result = create constraints reward inputs + +resultIsSelection :: MockSelectionResult -> Bool +resultIsSelection = isRight + +resultHasZeroFeeExcess :: MockSelectionResult -> Bool +resultHasZeroFeeExcess = matchRight $ \selection -> + feeExcess selection == Coin 0 + +resultHasInsufficientAda :: MockSelectionResult -> Bool +resultHasInsufficientAda = matchLeft $ \case + SelectionAdaInsufficient -> True + _ -> False + +resultIsFull :: MockSelectionResult -> Bool +resultIsFull = matchLeft $ \case + SelectionFull _ -> True + _ -> False + +-------------------------------------------------------------------------------- +-- Extending a selection +-------------------------------------------------------------------------------- + +prop_extend :: Blind MockTxConstraints -> Property +prop_extend (Blind mockConstraints) = + forAllBlind genSelection $ \selection -> + forAllBlind genExtraInput $ \input -> + prop_extend_inner mockConstraints selection input + where + genSelection :: Gen MockSelection + genSelection = genSelectionMaybe `suchThatMap` eitherToMaybe + where + genSelectionMaybe :: Gen (Either MockSelectionError MockSelection) + genSelectionMaybe = + create (unMockTxConstraints mockConstraints) + <$> genRewardWithdrawal + <*> genInputs + + genInputs :: Gen (NonEmpty (MockInputId, TokenBundle)) + genInputs = do + inputCount <- choose (1, 32) + (:|) + <$> genMockInput mockConstraints + <*> replicateM (inputCount - 1) (genMockInput mockConstraints) + + genExtraInput :: Gen (MockInputId, TokenBundle) + genExtraInput = (,) + <$> genMockInputId + <*> oneof + [ genTokenBundleMixed mockConstraints + -- In order to increase coverage of error conditions, + -- deliberately include some large bundles whose ada + -- quantities are below the minimum: + , TokenBundle (Coin 0) . F.fold <$> + replicateM 4 (genTokenMap mockConstraints) + ] + +prop_extend_inner + :: MockTxConstraints + -> MockSelection + -> (MockInputId, TokenBundle) + -> Property +prop_extend_inner mockConstraints selectionOriginal input = + checkCoverage $ + cover 40 (resultIsSelection result) + "Success" $ + cover 10 (resultHasZeroFeeExcess result) + "Success with zero fee excess" $ + cover 0.1 (resultHasInsufficientAda result) + "Failure due to insufficient ada" $ + cover 0.1 (resultIsFull result) + "Failure due to oversized selection" $ + report mockConstraints + "mockConstraints" $ + case result of + Left SelectionAdaInsufficient -> + property True + Left (SelectionFull e) -> + property (selectionSizeMaximum e < selectionSizeRequired e) + Right selection -> makeReports $ testAll + $ verify + (correctness == SelectionCorrect) + "correctness == SelectionCorrect" + . verify + (Selection.balance constraints selection == Right selection) + "Rebalancing the selection leaves it unchanged" + . verify + (feeExcess selection == feeExcessExpected) + "feeExcess selection == feeExcessExpected" + where + makeReports + = report correctness + "correctness" + . report feeExcessExpected + "feeExcessExpected" + correctness = + Selection.verify constraints selection + (feeExcessExpected, _) = + minimizeFee constraints (feeExcess selection, outputs selection) + where + constraints = unMockTxConstraints mockConstraints + result = extend constraints selectionOriginal input + +-------------------------------------------------------------------------------- +-- Adding value to outputs +-------------------------------------------------------------------------------- + +prop_addValueToOutputs :: Blind MockTxConstraints -> Property +prop_addValueToOutputs (Blind mockConstraints) = + forAllBlind genOutputs $ \outputs -> + prop_addValueToOutputs_inner mockConstraints outputs + where + genOutputs :: Gen (NonEmpty TokenMap) + genOutputs = do + -- The upper limit is chosen to be comfortably above the maximum + -- number of inputs expected in a typical transaction containing + -- different types of inputs: + outputCount <- choose (1, 128) + (:|) + <$> genTokenMap mockConstraints + <*> replicateM (outputCount - 1) (genTokenMap mockConstraints) + +prop_addValueToOutputs_inner + :: MockTxConstraints + -> NonEmpty TokenMap + -> Property +prop_addValueToOutputs_inner mockConstraints outputs = + withMaxSuccess 100 $ + checkCoverage $ makeCoverage $ makeReports $ testAll makeTests + where + makeTests + = verify + (valueAfter == valueBefore) + "Value is preserved" + . verify + (all (txOutputHasValidSizeWithMaxAda constraints) result) + "All outputs have valid sizes (if ada maximized)" + . verify + (all (txOutputHasValidTokenQuantities constraints) result) + "All outputs have valid token quantities" + makeCoverage + = cover 0.1 (length result == 1) + "length result == 1" + . cover 8.0 (length result >= 2) + "length result >= 2" + makeReports + = report mockConstraints + "mockConstraints" + . report valueBefore + "valueBefore" + . report valueAfter + "valueAfter" + . report (length outputs) + "length outputs" + . report (length result) + "length result" + + constraints = unMockTxConstraints mockConstraints + result :: NonEmpty TokenMap + result = F.foldl' + (addValueToOutputs constraints . NE.toList) + (addValueToOutputs constraints [] (NE.head outputs)) + (NE.tail outputs) + + valueBefore + = F.fold outputs + valueAfter + = F.fold result + +txOutputHasValidSizeWithMaxAda + :: TxSize size => TxConstraints size -> TokenMap -> Bool +txOutputHasValidSizeWithMaxAda constraints b = + txOutputHasValidSize constraints $ TokenBundle maxBound b + +-------------------------------------------------------------------------------- +-- Minimizing fees +-------------------------------------------------------------------------------- + +prop_minimizeFee :: Blind MockTxConstraints -> Property +prop_minimizeFee (Blind mockConstraints) = + forAllBlind genFeeExcess $ \feeExcessToMinimize -> + forAllBlind genOutputs $ \outputs -> + prop_minimizeFee_inner mockConstraints feeExcessToMinimize outputs + where + genFeeExcess :: Gen Coin + genFeeExcess = genCoinRange (Coin 0) (Coin 10_000) + + genOutputs :: Gen (NonEmpty TokenBundle) + genOutputs = do + outputCount <- choose (1, 10) + (:|) + <$> genTokenBundleMixed mockConstraints + <*> replicateM + (outputCount - 1) + (genTokenBundleMixed mockConstraints) + +prop_minimizeFee_inner + :: MockTxConstraints + -> Coin + -> NonEmpty TokenBundle + -> Property +prop_minimizeFee_inner mockConstraints feeExcessBefore outputsBefore = + checkCoverage $ makeCoverage $ makeReports $ testAll makeTests + where + makeTests + = verify + (feeExcessAfter <= feeExcessBefore) + "feeExcessAfter <= feeExcessBefore" + . verify + (feeExcessReduction == feeExcessReductionExpected) + "feeExcessReduction == feeExcessReductionExpected" + . verify + (length outputsAfter == length outputsBefore) + "length outputsAfter == length outputsBefore" + makeCoverage + = cover 50 (feeExcessAfter == Coin 0) + "feeExcessAfter == 0" + . cover 50 (totalOutputCostIncrease > Coin 0) + "totalOutputCostIncrease > 0" + makeReports + = report mockConstraints + "mockConstraints" + . report feeExcessBefore + "feeExcessBefore" + . report feeExcessAfter + "feeExcessAfter" + . report feeExcessReduction + "feeExcessReduction" + . report feeExcessReductionExpected + "feeExcessReductionExpected" + . report (length outputsBefore) + "length outputsBefore" + . report (length outputsAfter) + "length outputsAfter" + + constraints = unMockTxConstraints mockConstraints + + (feeExcessAfter, outputsAfter) = + minimizeFee constraints (feeExcessBefore, outputsBefore) + feeExcessReduction = + Coin.distance feeExcessBefore feeExcessAfter + feeExcessReductionExpected = + totalOutputCostIncrease <> totalOutputAdaIncrease + + totalOutputAdaAfter = + F.foldMap (view #coin) outputsAfter + totalOutputAdaBefore = + F.foldMap (view #coin) outputsBefore + totalOutputAdaIncrease = + Coin.distance totalOutputAdaAfter totalOutputAdaBefore + + totalOutputCostAfter = + F.foldMap (txOutputCost constraints) outputsAfter + totalOutputCostBefore = + F.foldMap (txOutputCost constraints) outputsBefore + totalOutputCostIncrease = + Coin.distance totalOutputCostBefore totalOutputCostAfter + +-------------------------------------------------------------------------------- +-- Minimizing fees (a single step) +-------------------------------------------------------------------------------- + +prop_minimizeFeeStep :: Blind MockTxConstraints -> Property +prop_minimizeFeeStep (Blind mockConstraints) = + forAllBlind genFeeExcess $ \feeExcessToMinimize -> + forAllBlind genOutput $ \output -> + prop_minimizeFeeStep_inner mockConstraints feeExcessToMinimize output + where + genFeeExcess :: Gen Coin + genFeeExcess = genCoinRange (Coin 0) (Coin 10_000) + + genOutput :: Gen TokenBundle + genOutput = genTokenBundleMixed mockConstraints + +prop_minimizeFeeStep_inner + :: MockTxConstraints + -> Coin + -> TokenBundle + -> Property +prop_minimizeFeeStep_inner mockConstraints feeExcessBefore outputBefore = + checkCoverage $ makeCoverage $ makeReports $ testAll makeTests + where + makeTests + = verify + (feeExcessAfter <= feeExcessBefore) + "feeExcessAfter <= feeExcessBefore" + . verify + (outputCoinAfter >= outputCoinBefore) + "outputCoinAfter >= outputCoinBefore" + . verify + (outputCostAfter >= outputCostBefore) + "outputCostAfter >= outputCostBefore" + . verify + (feeExcessReduction <> feeExcessAfter == feeExcessBefore) + "feeExcessReduction <> feeExcessAfter == feeExcessBefore" + . verify + (costOfEliminatingFeeExcess >= gainOfEliminatingFeeExcess) + "costOfEliminatingFeeExcess >= gainOfEliminatingFeeExcess" + makeCoverage + = cover 50 (feeExcessAfter == Coin 0) + "feeExcessAfter == 0" + . cover 0.01 (feeExcessAfter /= Coin 0) + "feeExcessAfter /= 0" + . cover 1 (outputCostIncrease > Coin 0) + "outputCostIncrease > 0" + makeReports + = report mockConstraints + "mockConstraints" + . report feeExcessBefore + "feeExcessBefore" + . report feeExcessAfter + "feeExcessAfter" + . report feeExcessReduction + "feeExcessReduction" + . report costOfEliminatingFeeExcess + "costOfEliminatingFeeExcess" + . report gainOfEliminatingFeeExcess + "gainOfEliminatingFeeExcess" + . report outputCoinBefore + "outputCoinBefore" + . report outputCoinAfter + "outputCoinAfter" + . report outputCoinIncrease + "outputCoinIncrease" + . report outputCostBefore + "outputCostBefore" + . report outputCostAfter + "outputCostAfter" + . report outputCostIncrease + "outputCostIncrease" + + constraints = unMockTxConstraints mockConstraints + + (feeExcessAfter, outputAfter) = + minimizeFeeStep constraints (feeExcessBefore, outputBefore) + + costOfEliminatingFeeExcess = Coin.distance + (txOutputCoinCost constraints outputCoinAfter) + (txOutputCoinCost constraints (outputCoinAfter <> feeExcessAfter)) + gainOfEliminatingFeeExcess = fromMaybe (Coin 0) $ Coin.subtractCoin + feeExcessAfter + costOfEliminatingFeeExcess + + feeExcessReduction = + Coin.distance feeExcessBefore feeExcessAfter + + outputCoinAfter = + view #coin outputAfter + outputCoinBefore = + view #coin outputBefore + outputCoinIncrease = + Coin.distance outputCoinBefore outputCoinAfter + outputCostAfter = + txOutputCost constraints outputAfter + outputCostBefore = + txOutputCost constraints outputBefore + outputCostIncrease = + Coin.distance outputCostBefore outputCostAfter + +-------------------------------------------------------------------------------- +-- Cost calculations +-------------------------------------------------------------------------------- + +prop_txOutputCost :: Blind MockTxConstraints -> Property +prop_txOutputCost (Blind mockConstraints) = + forAllBlind genOutput $ \output -> + prop_txOutputCost_inner mockConstraints output + where + genOutput :: Gen TokenBundle + genOutput = genTokenBundleMixed mockConstraints + +prop_txOutputCost_inner :: MockTxConstraints -> TokenBundle -> Property +prop_txOutputCost_inner mockConstraints output = + makeReports $ testAll makeTests + where + makeTests + = verify + ( txOutputCost constraints output < + txOutputCost constraints outputWithLargerCoin ) + "multiplying a coin by a factor of 10 increases its cost" + . verify + ( txOutputCost constraints output < + txOutputCost constraints outputWithMaxCoin ) + "all coins cost less than the maximum ada quantity" + . verify + ( txOutputCostDifference output outputWithLargerCoin == + txOutputCoinCostDifference output outputWithLargerCoin ) + "cost difference is independent of whether bundles are considered" + makeReports + = report mockConstraints + "mockConstraints" + . report output + "output" + . report outputWithLargerCoin + "outputWithLargerCoin" + + txOutputCostDifference :: TokenBundle -> TokenBundle -> Coin + txOutputCostDifference out1 out2 = Coin.distance + (txOutputCost constraints out1) + (txOutputCost constraints out2) + + txOutputCoinCostDifference :: TokenBundle -> TokenBundle -> Coin + txOutputCoinCostDifference out1 out2 = Coin.distance + (txOutputCoinCost constraints (view #coin out1)) + (txOutputCoinCost constraints (view #coin out2)) + + constraints = + unMockTxConstraints mockConstraints + outputWithLargerCoin = TokenBundle.setCoin output + $ multiplyCoinByTen + $ TokenBundle.getCoin output + outputWithMaxCoin = + TokenBundle.setCoin output maxBound + multiplyCoinByTen (Coin n) = Coin $ 10 * n + +-------------------------------------------------------------------------------- +-- Size calculations +-------------------------------------------------------------------------------- + +prop_txOutputSize :: Blind MockTxConstraints -> Property +prop_txOutputSize (Blind mockConstraints) = + forAllBlind genOutput $ \output -> + prop_txOutputSize_inner mockConstraints output + where + genOutput :: Gen TokenBundle + genOutput = genTokenBundleMixed mockConstraints + +prop_txOutputSize_inner :: MockTxConstraints -> TokenBundle -> Property +prop_txOutputSize_inner mockConstraints output = + makeReports $ testAll makeTests + where + makeTests + = verify + ( txOutputSize constraints output < + txOutputSize constraints outputWithLargerCoin ) + "multiplying a coin by a factor of 10 increases its size" + . verify + ( txOutputSize constraints output < + txOutputSize constraints outputWithMaxCoin ) + "all coins have a smaller size than the maximum ada quantity" + . verify + ( txOutputSizeDifference output outputWithLargerCoin == + txOutputCoinSizeDifference output outputWithLargerCoin ) + "size difference is independent of whether bundles are considered" + makeReports + = report mockConstraints + "mockConstraints" + . report output + "output" + . report outputWithLargerCoin + "outputWithLargerCoin" + + txOutputSizeDifference :: TokenBundle -> TokenBundle -> MockSize + txOutputSizeDifference out1 out2 = txSizeDistance + (txOutputSize constraints out1) + (txOutputSize constraints out2) + + txOutputCoinSizeDifference :: TokenBundle -> TokenBundle -> MockSize + txOutputCoinSizeDifference out1 out2 = txSizeDistance + (txOutputCoinSize constraints (view #coin out1)) + (txOutputCoinSize constraints (view #coin out2)) + + constraints = + unMockTxConstraints mockConstraints + outputWithLargerCoin = TokenBundle.setCoin output + $ multiplyCoinByTen + $ TokenBundle.getCoin output + outputWithMaxCoin = + TokenBundle.setCoin output maxBound + multiplyCoinByTen (Coin n) = Coin $ 10 * n + +-------------------------------------------------------------------------------- +-- Mock transaction constraints +-------------------------------------------------------------------------------- + +data MockTxConstraints = MockTxConstraints + { mockTxCostFunction + :: MockTxCostFunction + , mockTxBaseSize + :: MockTxBaseSize + , mockTxInputSize + :: MockTxInputSize + , mockTxOutputMaximumSize + :: MockTxOutputMaximumSize + , mockTxOutputMaximumTokenQuantity + :: MockTxOutputMaximumTokenQuantity + , mockTxOutputMinimumAdaQuantity + :: MockTxOutputMinimumAdaQuantity + , mockTxMaximumSize + :: MockTxMaximumSize + } + deriving (Eq, Show) + +instance Arbitrary MockTxConstraints where + arbitrary = genMockTxConstraints + +genMockTxConstraints :: Gen MockTxConstraints +genMockTxConstraints = do + mockTxCostFunction <- genMockTxCostFunction + mockTxBaseSize <- genMockTxBaseSize + mockTxInputSize <- genMockTxInputSize + mockTxOutputMaximumSize <- genMockTxOutputMaximumSize + mockTxOutputMaximumTokenQuantity <- genMockTxOutputMaximumTokenQuantity + mockTxOutputMinimumAdaQuantity <- genMockTxOutputMinimumAdaQuantity + mockTxMaximumSize <- genMockTxMaximumSize + mockTxBaseSize + mockTxInputSize + mockTxOutputMaximumSize + pure MockTxConstraints {..} + +unMockTxConstraints :: MockTxConstraints -> TxConstraints MockSize +unMockTxConstraints MockTxConstraints {..} = TxConstraints + { txBaseCost = + baseCost mockTxCostFunction + , txBaseSize = + unMockTxBaseSize mockTxBaseSize + , txInputCost = + mockSizeToCost $ unMockTxInputSize mockTxInputSize + , txInputSize = + unMockTxInputSize mockTxInputSize + , txOutputCost = + mockSizeToCost . mockOutputSize + , txOutputSize = + mockOutputSize + , txOutputMaximumSize = + unMockTxOutputMaximumSize mockTxOutputMaximumSize + , txOutputMaximumTokenQuantity = + unMockTxOutputMaximumTokenQuantity mockTxOutputMaximumTokenQuantity + , txOutputMinimumAdaQuantity = + unMockTxOutputMinimumAdaQuantity mockTxOutputMinimumAdaQuantity + , txRewardWithdrawalCost = + mockSizeToCost . mockRewardWithdrawalSize + , txRewardWithdrawalSize = + mockRewardWithdrawalSize + , txMaximumSize = + unMockTxMaximumSize mockTxMaximumSize + } + where + mockOutputSize :: TokenBundle -> MockSize + mockOutputSize (TokenBundle c m) = (<>) + (MockSize $ fromIntegral $ BS.length $ pretty $ Flat m) + (mockCoinSize c) + + mockRewardWithdrawalSize :: Coin -> MockSize + mockRewardWithdrawalSize = \case + Coin 0 -> MockSize 0 + Coin c -> mockCoinSize (Coin c) + + mockCoinSize :: Coin -> MockSize + mockCoinSize = MockSize . fromIntegral . length . show + + mockSizeToCost :: MockSize -> Coin + mockSizeToCost (MockSize s) = + Coin $ fromIntegral $ fromIntegral a * s + where + Coin a = sizeCost mockTxCostFunction + +-------------------------------------------------------------------------------- +-- Mock transaction costs +-------------------------------------------------------------------------------- + +data MockTxCostFunction = MockTxCostFunction + { baseCost :: Coin + , sizeCost :: Coin + } + deriving stock (Eq, Show) + +genMockTxCostFunction :: Gen MockTxCostFunction +genMockTxCostFunction = MockTxCostFunction + <$> genCoinRange (Coin 0) (Coin 1000) + <*> genCoinRange (Coin 1) (Coin 4) + +-------------------------------------------------------------------------------- +-- Mock base transaction sizes +-------------------------------------------------------------------------------- + +newtype MockTxBaseSize = MockTxBaseSize + { unMockTxBaseSize :: MockSize } + deriving stock Eq + deriving Show via Natural + +genMockTxBaseSize :: Gen MockTxBaseSize +genMockTxBaseSize = MockTxBaseSize <$> genMockSizeRange 0 1000 + +-------------------------------------------------------------------------------- +-- Mock input sizes +-------------------------------------------------------------------------------- + +newtype MockTxInputSize = MockTxInputSize + { unMockTxInputSize :: MockSize } + deriving stock Eq + deriving Show via Natural + +genMockTxInputSize :: Gen MockTxInputSize +genMockTxInputSize = MockTxInputSize <$> genMockSizeRange 2 4 + +-------------------------------------------------------------------------------- +-- Mock maximum output sizes +-------------------------------------------------------------------------------- + +newtype MockTxOutputMaximumSize = MockTxOutputMaximumSize + { unMockTxOutputMaximumSize :: MockSize } + deriving stock Eq + deriving Show via Natural + +genMockTxOutputMaximumSize :: Gen MockTxOutputMaximumSize +genMockTxOutputMaximumSize = + -- Chosen so that the upper limit is around twice the unconstrained maximum + -- size of token bundles generated by 'genTokenBundle'. + pure $ MockTxOutputMaximumSize $ MockSize 400 + +-------------------------------------------------------------------------------- +-- Mock maximum token quantities +-------------------------------------------------------------------------------- + +newtype MockTxOutputMaximumTokenQuantity = MockTxOutputMaximumTokenQuantity + { unMockTxOutputMaximumTokenQuantity :: TokenQuantity } + deriving stock Eq + deriving Show via Natural + +genMockTxOutputMaximumTokenQuantity :: Gen MockTxOutputMaximumTokenQuantity +genMockTxOutputMaximumTokenQuantity = MockTxOutputMaximumTokenQuantity <$> + genTokenQuantityRange (TokenQuantity 500) (TokenQuantity 2000) + +-------------------------------------------------------------------------------- +-- Mock minimum ada quantities +-------------------------------------------------------------------------------- + +data MockTxOutputMinimumAdaQuantity = MockTxOutputMinimumAdaQuantity + { perOutput :: Coin + , perOutputAsset :: Coin + } + deriving (Eq, Show) + +unMockTxOutputMinimumAdaQuantity + :: MockTxOutputMinimumAdaQuantity + -> (TokenMap -> Coin) +unMockTxOutputMinimumAdaQuantity mock m = + let assetCount = Set.size $ TokenMap.getAssets m in + perOutput mock + <> mtimesDefault assetCount (perOutputAsset mock) + +genMockTxOutputMinimumAdaQuantity :: Gen MockTxOutputMinimumAdaQuantity +genMockTxOutputMinimumAdaQuantity = MockTxOutputMinimumAdaQuantity + <$> genCoinRange (Coin 4) (Coin 8) + <*> genCoinRange (Coin 1) (Coin 2) + +-------------------------------------------------------------------------------- +-- Mock maximum transaction sizes +-------------------------------------------------------------------------------- + +newtype MockTxMaximumSize = MockTxMaximumSize + { unMockTxMaximumSize :: MockSize } + deriving stock Eq + deriving Show via Natural + +genMockTxMaximumSize + :: MockTxBaseSize + -> MockTxInputSize + -> MockTxOutputMaximumSize + -> Gen MockTxMaximumSize +genMockTxMaximumSize mockTxBaseSize mockTxInputSize mockTxOutputMaximumSize = + pure $ genInner 4 + where + genInner :: Int -> MockTxMaximumSize + genInner multiplier = MockTxMaximumSize $ mconcat + [ unMockTxBaseSize mockTxBaseSize + , stimes multiplier (unMockTxInputSize mockTxInputSize) + , stimes multiplier (unMockTxOutputMaximumSize mockTxOutputMaximumSize) + ] + +-------------------------------------------------------------------------------- +-- Generating inputs +-------------------------------------------------------------------------------- + +newtype MockInputId = MockInputId + { unMockInputId :: ByteString } + deriving (Eq, Ord) + +instance Show MockInputId where + show = show . T.decodeUtf8 . convertToBase Base16 . unMockInputId + +genMockInput :: MockTxConstraints -> Gen (MockInputId, TokenBundle) +genMockInput mockConstraints = (,) + <$> genMockInputId + <*> genTokenBundleMixed mockConstraints + +shrinkMockInput :: (MockInputId, TokenBundle) -> [(MockInputId, TokenBundle)] +shrinkMockInput (inputId, TokenBundle c m) + | c /= Coin 0, m /= mempty = + [(inputId, TokenBundle c mempty)] + | c /= Coin 0, m == mempty = + [(inputId, TokenBundle (Coin 0) mempty)] + | otherwise = + [] + +genMockInputAdaOnly :: MockTxConstraints -> Gen (MockInputId, TokenBundle) +genMockInputAdaOnly mockConstraints = (,) + <$> genMockInputId + <*> (TokenBundle.fromCoin <$> genCoinMixed mockConstraints) + +genMockInputId :: Gen MockInputId +genMockInputId = MockInputId . BS.pack <$> + vectorOf 16 (choose (minBound @Word8, maxBound @Word8)) + +-------------------------------------------------------------------------------- +-- Generating coins, token bundles, token maps, and token quantities +-------------------------------------------------------------------------------- + +genCoinMixed :: MockTxConstraints -> Gen Coin +genCoinMixed mockConstraints = frequency + [ (10, genCoinBelowMinimumAdaQuantity mockConstraints) + , (40, genCoinAboveMinimumAdaQuantity mockConstraints) + ] + +genCoinAboveMinimumAdaQuantity :: MockTxConstraints -> Gen Coin +genCoinAboveMinimumAdaQuantity mockConstraints = + genCoinRange + (txOutputCoinMinimum constraints) + (txOutputCoinMinimum constraints `scaleCoin` 1000) + where + constraints = unMockTxConstraints mockConstraints + +genCoinBelowMinimumAdaQuantity :: MockTxConstraints -> Gen Coin +genCoinBelowMinimumAdaQuantity mockConstraints = + genCoinRange + (Coin 1) + (Coin.distance (txOutputCoinMinimum constraints) (Coin 1)) + where + constraints = unMockTxConstraints mockConstraints + +genCoinRange :: Coin -> Coin -> Gen Coin +genCoinRange (Coin minCoin) (Coin maxCoin) = + Coin . fromIntegral <$> choose (minCoin, maxCoin) + +genTokenBundleMixed :: MockTxConstraints -> Gen TokenBundle +genTokenBundleMixed mockConstraints = + genInner `suchThat` txOutputHasValidSize constraints + where + constraints = unMockTxConstraints mockConstraints + + genInner :: Gen TokenBundle + genInner = frequency $ fmap (\g -> g mockConstraints) <$> distribution + + distribution :: [(Int, MockTxConstraints -> Gen TokenBundle)] + distribution = + [ (10, genCoinBelowMinimumAdaQuantity <&> fmap TokenBundle.fromCoin) + , (40, genCoinAboveMinimumAdaQuantity <&> fmap TokenBundle.fromCoin) + , (40, genTokenBundleWithMinimumAdaQuantity) + , (10, genTokenBundleAboveMinimumAdaQuantity) + ] + +genTokenBundleWithMinimumAdaQuantity :: MockTxConstraints -> Gen TokenBundle +genTokenBundleWithMinimumAdaQuantity mockConstraints = do + m <- genTokenMap mockConstraints + let minAda = txOutputMinimumAdaQuantity constraints m + pure $ TokenBundle minAda m + where + constraints = unMockTxConstraints mockConstraints + +genTokenBundleAboveMinimumAdaQuantity :: MockTxConstraints -> Gen TokenBundle +genTokenBundleAboveMinimumAdaQuantity mockConstraints = do + m <- genTokenMap mockConstraints + let minAda = txOutputMinimumAdaQuantity constraints m + c <- genCoinRange (minAda <> Coin 1) (minAda `scaleCoin` 1000) + pure $ TokenBundle c m + where + constraints = unMockTxConstraints mockConstraints + +genTokenMap :: MockTxConstraints -> Gen TokenMap +genTokenMap mockConstraints = + genInner + `suchThat` (txOutputHasValidSize constraints . (TokenBundle maxBound)) + `suchThat` (txOutputHasValidTokenQuantities constraints) + where + constraints = unMockTxConstraints mockConstraints + + genInner :: Gen TokenMap + genInner = do + assetCount <- choose (1, 4) + TokenMap.fromFlatList <$> replicateM assetCount genAssetQuantity + + genAssetQuantity :: Gen (AssetId, TokenQuantity) + genAssetQuantity = (,) + <$> genAssetId + <*> genTokenQuantityRange + (TokenQuantity 1) + (txOutputMaximumTokenQuantity constraints) + + genAssetId :: Gen AssetId + genAssetId = elements mockAssetIds + +genTokenQuantityRange :: TokenQuantity -> TokenQuantity -> Gen TokenQuantity +genTokenQuantityRange (TokenQuantity a) (TokenQuantity b) = + TokenQuantity . fromIntegral @Integer + <$> choose (fromIntegral a, fromIntegral b) + +mockAssetIds :: [AssetId] +mockAssetIds = + [ AssetId i n + | i <- UnsafeTokenPolicyId . Hash . B8.singleton <$> ['0' .. '3'] + , n <- UnsafeTokenName . B8.singleton <$> ['0' .. '3'] + ] + +-------------------------------------------------------------------------------- +-- Generating reward withdrawals +-------------------------------------------------------------------------------- + +genRewardWithdrawal :: Gen RewardWithdrawal +genRewardWithdrawal = RewardWithdrawal <$> oneof + [ pure (Coin 0) + , genCoinRange (Coin 1) (Coin 1_000_000) + ] + +-------------------------------------------------------------------------------- +-- Mock sizes +-------------------------------------------------------------------------------- + +newtype MockSize = MockSize { unMockSize :: Natural } + deriving stock (Eq, Ord) + deriving Show via Natural + +instance Semigroup MockSize where + MockSize a <> MockSize b = MockSize (a + b) + +instance Monoid MockSize where + mempty = MockSize 0 + +instance TxSize MockSize where + MockSize a `txSizeDistance` MockSize b + | a >= b = MockSize (a - b) + | otherwise = MockSize (b - a) + +genMockSizeRange :: Natural -> Natural -> Gen MockSize +genMockSizeRange minSize maxSize = + MockSize . fromIntegral @Integer @Natural <$> + choose (fromIntegral minSize, fromIntegral maxSize) + +-------------------------------------------------------------------------------- +-- Arbitrary instances +-------------------------------------------------------------------------------- + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = (:|) <$> arbitrary <*> arbitrary + shrink = genericShrink + +-------------------------------------------------------------------------------- +-- Internal types and functions +-------------------------------------------------------------------------------- + +-- | Adds a named variable to the counterexample output of a property. +-- +-- On failure, uses pretty-printing to show the contents of the variable. +-- +report :: (Show a, Testable prop) => a -> String -> prop -> Property +report a name = counterexample + $ pretty $ mconcat + [ buildPretty name + , build @String ":\n" + , indentF 4 (buildPretty a) + ] + where + buildPretty :: Show b => b -> Builder + buildPretty = build . TL.unpack . pShow + +-- | Adds a named condition to a property. +-- +-- On failure, reports the name of the condition that failed. +-- +verify :: Bool -> String -> Property -> Property +verify condition conditionTitle = + (.&&.) (counterexample counterexampleText $ property condition) + where + counterexampleText = mconcat + [ "Condition violated: " + , TL.unpack (pShow conditionTitle) + ] + +-- | Tests a collection of properties defined with 'verify'. +-- +-- Example: +-- +-- >>> testAll (verify c1 "cond1" . verify c2 "cond2" . verify c3 "cond3") +-- +testAll :: (Property -> Property) -> Property +testAll properties = properties $ property True + +matchLeft :: (e -> Bool) -> Either e a -> Bool +matchLeft f result = case result of + Right _ -> False + Left x -> f x + +matchRight :: (a -> Bool) -> Either e a -> Bool +matchRight f result = case result of + Right x -> f x + Left _ -> False + +scaleCoin :: Coin -> Int -> Coin +scaleCoin (Coin c) s = Coin $ c * fromIntegral s + +-------------------------------------------------------------------------------- +-- Pretty-printing +-------------------------------------------------------------------------------- + +newtype Pretty a = Pretty { unPretty :: a } + deriving Eq + +instance Arbitrary a => Arbitrary (Pretty a) where + arbitrary = Pretty <$> arbitrary + shrink (Pretty a) = Pretty <$> shrink a + +instance Show a => Show (Pretty a) where + show (Pretty a) = TL.unpack $ pShow a diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/MigrationSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/MigrationSpec.hs new file mode 100644 index 00000000000..917eb85147d --- /dev/null +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/MigrationSpec.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedLabels #-} + +module Cardano.Wallet.Primitive.MigrationSpec + where + +import Prelude + +import Cardano.Wallet.Primitive.Migration + ( RewardWithdrawal (..), createPlan ) +import Cardano.Wallet.Primitive.Migration.Planning + ( categorizeUTxO, uncategorizeUTxO ) +import Cardano.Wallet.Primitive.Migration.SelectionSpec + ( MockTxConstraints + , genRewardWithdrawal + , genTokenBundleMixed + , testAll + , unMockTxConstraints + , verify + ) +import Cardano.Wallet.Primitive.Types.Address.Gen + ( genAddressSmallRange ) +import Cardano.Wallet.Primitive.Types.Tx + ( TxIn, TxOut (..) ) +import Cardano.Wallet.Primitive.Types.Tx.Gen + ( genTxInLargeRange ) +import Cardano.Wallet.Primitive.Types.UTxO + ( UTxO (..) ) +import Control.Monad + ( replicateM ) +import Data.Function + ( (&) ) +import Data.Generics.Internal.VL.Lens + ( view ) +import Data.Generics.Labels + () +import Test.Hspec + ( Spec, describe, it ) +import Test.Hspec.Extra + ( parallel ) +import Test.QuickCheck + ( Blind (..), Gen, Property, choose, forAllBlind, property ) + +import qualified Cardano.Wallet.Primitive.Migration.Planning as Planning +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map + +spec :: Spec +spec = describe "Cardano.Wallet.Primitive.MigrationSpec" $ + + parallel $ + describe "Creating migration plans (with concrete wallet types)" $ do + + it "prop_createPlan_equivalent" $ + property prop_createPlan_equivalent + +-------------------------------------------------------------------------------- +-- Creating migration plans (with concrete wallet types) +-------------------------------------------------------------------------------- + +-- This property test is really just a simple sanity check to ensure that it's +-- possible to create migration plans through the public interface, using +-- concrete wallet types such as 'UTxO', 'TxIn', and 'TxOut'. +-- +-- As such, this test does not do anything beyond establishing that the results +-- of calling the following functions are equivalent: +-- +-- - Migration .createPlan (uses concrete wallet types) +-- - Migration.Planning.createPlan (uses abstract types) +-- +-- For a more detailed test of 'createPlan' (with abstract types) see +-- 'PlanningSpec.prop_createPlan'. +-- +prop_createPlan_equivalent :: Blind MockTxConstraints -> Property +prop_createPlan_equivalent (Blind mockConstraints) = + forAllBlind genUTxO $ \utxo -> + forAllBlind genRewardWithdrawal $ \reward -> + prop_createPlan_equivalent_inner mockConstraints utxo reward + where + genUTxO :: Gen UTxO + genUTxO = do + entryCount <- choose (0, 64) + UTxO . Map.fromList <$> replicateM entryCount genUTxOEntry + where + genUTxOEntry :: Gen (TxIn, TxOut) + genUTxOEntry = (,) <$> genTxIn <*> genTxOut + where + genTxIn :: Gen TxIn + genTxIn = genTxInLargeRange + + genTxOut :: Gen TxOut + genTxOut = TxOut + <$> genAddressSmallRange + <*> genTokenBundleMixed mockConstraints + +prop_createPlan_equivalent_inner + :: MockTxConstraints + -> UTxO + -> RewardWithdrawal + -> Property +prop_createPlan_equivalent_inner mockConstraints utxo reward = testAll + $ verify + (totalFeeConcrete == totalFeeAbstract) + "totalFeeConcrete == totalFeeAbstract" + . verify + (selectionsConcrete == selectionsAbstract) + "selectionsConcrete == selectionsAbstract" + . verify + (unselectedConcrete == unselectedAbstract) + "unselectedConcrete == unselectedAbstract" + . verify + (utxoEmpty == utxoIntersect utxoSelected utxoNotSelected) + "utxoEmpty == utxoIntersect utxoSelected utxoNotSelected" + . verify + (utxo == utxoUnion utxoSelected utxoNotSelected) + "utxo == utxoUnion utxoSelected utxoNotSelected" + where + totalFeeConcrete = view #totalFee planConcrete + totalFeeAbstract = view #totalFee planAbstract + + selectionsConcrete = view #selections planConcrete + selectionsAbstract = view #selections planAbstract + + unselectedConcrete = view #unselected planConcrete + unselectedAbstract = view #unselected planAbstract + & uncategorizeUTxO + + planConcrete = createPlan constraints utxo reward + planAbstract = Planning.createPlan + constraints (categorizeUTxO constraints utxo) reward + + constraints = unMockTxConstraints mockConstraints + + utxoEmpty :: UTxO + utxoEmpty = UTxO Map.empty + + utxoIntersect :: UTxO -> UTxO -> UTxO + utxoIntersect (UTxO u1) (UTxO u2) = UTxO $ Map.intersection u1 u2 + + utxoUnion :: UTxO -> UTxO -> UTxO + utxoUnion (UTxO u1) (UTxO u2) = UTxO $ Map.union u1 u2 + + utxoSelected :: UTxO + utxoSelected = planConcrete + & view #selections + & fmap (NE.toList . view #inputIds) + & mconcat + & Map.fromList + & UTxO + + utxoNotSelected :: UTxO + utxoNotSelected = planConcrete + & view #unselected diff --git a/nix/.stack.nix/cardano-wallet-core.nix b/nix/.stack.nix/cardano-wallet-core.nix index 52c28543ae5..b2db0ab4347 100644 --- a/nix/.stack.nix/cardano-wallet-core.nix +++ b/nix/.stack.nix/cardano-wallet-core.nix @@ -79,6 +79,7 @@ (hsPkgs."persistent" or (errorHandler.buildDepError "persistent")) (hsPkgs."persistent-sqlite" or (errorHandler.buildDepError "persistent-sqlite")) (hsPkgs."persistent-template" or (errorHandler.buildDepError "persistent-template")) + (hsPkgs."pretty-simple" or (errorHandler.buildDepError "pretty-simple")) (hsPkgs."profunctors" or (errorHandler.buildDepError "profunctors")) (hsPkgs."quiet" or (errorHandler.buildDepError "quiet")) (hsPkgs."random" or (errorHandler.buildDepError "random")) @@ -166,6 +167,7 @@ (hsPkgs."network" or (errorHandler.buildDepError "network")) (hsPkgs."network-uri" or (errorHandler.buildDepError "network-uri")) (hsPkgs."persistent" or (errorHandler.buildDepError "persistent")) + (hsPkgs."pretty-simple" or (errorHandler.buildDepError "pretty-simple")) (hsPkgs."regex-pcre-builtin" or (errorHandler.buildDepError "regex-pcre-builtin")) (hsPkgs."OddWord" or (errorHandler.buildDepError "OddWord")) (hsPkgs."ouroboros-consensus" or (errorHandler.buildDepError "ouroboros-consensus"))