Skip to content

Commit

Permalink
Implement and use distributeSurplus in balanceTx
Browse files Browse the repository at this point in the history 
- Factors out fee-minimisation logic such that it can be made more sophisticated and tested separately from balanceTransaction
- Fee- and change-related padding before fee-minimisation is increased.
- The padding after fee-minimisation is (in most cases) removed (see goldens; we are no longer overpaying the fee with 176 lovelace)
- The fee minimisation is more robust, and should work regardless of ProtocolParameters, whether a 5 ada fee is required, or a 21 lovelace one.

I ended up dropping the sanity check that any burned fee was less than
20 ada. I considered replacing the hard-coded limit with the following:
```
-- Increasing the fee by much should only happen if coin-selection is unable
-- to construct a change output respecting the minUTxOValue.
guardReasonableExcessFee
    :: TxFeeAndChange
    -> TxFeeAndChange
guardReasonableExcessFee fc@(TxFeeAndChange feeToBurn _)
    | feeToBurn > limit =
        error $ unwords
            [ "final redundant safety check in balanceTransaction:"
            , "burning more than 2 * minUTxOValue in fees is unreasonable"
            ]
    | otherwise = fc

  where
    -- We let 2*minAda be the limit rather than just minAda to account
    -- for overestimations in coin-selection etc. Precision doesn't
    -- matter here.
    limit = minAda
        <> minAda
        <> Coin (ceiling $ 16 * perByteFee)

    -- NOTE: The change output we've failed to create would only have
    -- contained ada, so passing 'TokenMap.empty' should be reasonable.
    minAda = txOutputMinimumAdaQuantity
        (view #constraints tl pp)
        TokenMap.empty

    LinearFee LinearFunction {slope = perByteFee} =
        view (#txParameters . #getFeePolicy) pp
```

but decided it was too complex to be worth it.
  • Loading branch information
@Anviking
Anviking committed Apr 19, 2022
1 parent 2e7c771 commit 1f69c03
Show file tree
Hide file tree
Showing 10 changed files with 365 additions and 151 deletions.
4 changes: 2 additions & 2 deletions lib/core-integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1746,11 +1746,11 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do
, expectErrorMessage errMsg403Collateral
, expectErrorMessage $ unwords
[ "I need an ada amount of at least:"
, "4.278900"
, "4.279500"
]
, expectErrorMessage $ unwords
[ "The largest combination of pure ada UTxOs I could find is:"
, "[2.852600]"
, "[2.853000]"
]
]

Expand Down
93 changes: 34 additions & 59 deletions lib/core/src/Cardano/Wallet.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,6 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
Expand Down Expand Up @@ -450,10 +449,12 @@ import Cardano.Wallet.Transaction
, ErrCannotJoin (..)
, ErrCannotQuit (..)
, ErrMkTransaction (..)
, ErrMoreSurplusNeeded (ErrMoreSurplusNeeded)
, ErrSignTx (..)
, ErrUpdateSealedTx (..)
, TransactionCtx (..)
, TransactionLayer (..)
, TxFeeAndChange (TxFeeAndChange)
, TxFeeUpdate (..)
, TxUpdate (..)
, Withdrawal (..)
Expand Down Expand Up @@ -538,7 +539,7 @@ import Data.List.NonEmpty
import Data.Map.Strict
( Map )
import Data.Maybe
( fromMaybe, isJust, mapMaybe )
( fromMaybe, isJust, listToMaybe, mapMaybe )
import Data.Proxy
( Proxy )
import Data.Quantity
Expand Down Expand Up @@ -1687,13 +1688,9 @@ balanceTransactionWithSelectionStrategy
, extraCollateral
, extraOutputs
, feeUpdate = UseNewTxFee $ unsafeFromLovelace minfee0
-- TODO [ADP-1514] Ensure the choice of fee here doesn't cause the fee
-- minimization to fail.
--
-- Assuming fees are between 0.065536 and 4.294967296 ada, it
-- shouldn't, but it would be better not to rely on this.
}


(balance, candidateMinFee) <- balanceAfterSettingMinFee candidateTx
surplus <- case Cardano.selectLovelace balance of
(Cardano.Lovelace c)
Expand All @@ -1703,31 +1700,28 @@ balanceTransactionWithSelectionStrategy
throwE . ErrBalanceTxNotYetSupported $
UnderestimatedFee (Coin.unsafeFromIntegral (-c)) candidateTx

-- If there are no change outputs, "burn" the surplus as extra fee.
--
-- This should only happen when coin-selection cannot afford to construct a
-- change output with the appropriate minUTxOValue.
let extraFeeToBurn = case extraOutputs of
[] | surplus > Coin 20_000_000 ->
error $ unwords
[ "final redundant safety check in balanceTransaction:"
, "burning more than 20 ada in fees is unreasonable"
]
[] ->
surplus
_ ->
Coin 0
let feeAndChange = TxFeeAndChange
(unsafeFromLovelace candidateMinFee)
(txOutCoin <$> listToMaybe extraOutputs)
let feePolicy = view (#txParameters . #getFeePolicy) pp

-- @distributeSurplus@ should never fail becase we have provided enough
-- padding in @selectAssets'@.
TxFeeAndChange extraFee extraChange <-
withExceptT
(\(ErrMoreSurplusNeeded c) ->
ErrBalanceTxNotYetSupported $ UnderestimatedFee c candidateTx)
(ExceptT . pure $
distributeSurplus tl feePolicy surplus feeAndChange)

guardTxSize =<< guardTxBalanced =<< (assembleTransaction $ TxUpdate
{ extraInputs
, extraCollateral
, extraOutputs =
-- NOTE: Can cause the size of the Coin value to increase. See todo
-- and workaround in 'balanceAfterSettingMinFee' below.
mapFirst (txOutAddCoin surplus) extraOutputs
, feeUpdate = UseNewTxFee $
(unsafeFromLovelace candidateMinFee)
<> extraFeeToBurn
, extraOutputs = mapFirst
(txOutAddCoin $ fromMaybe (Coin 0) extraChange)
extraOutputs
, feeUpdate = UseNewTxFee
(unsafeFromLovelace candidateMinFee <> extraFee)
})
where
tl = ctx ^. transactionLayer @k
Expand Down Expand Up @@ -1765,32 +1759,9 @@ balanceTransactionWithSelectionStrategy
:: SealedTx
-> ExceptT ErrBalanceTx m (Cardano.Value, Cardano.Lovelace)
balanceAfterSettingMinFee tx = ExceptT . pure $ do
-- This fee padding works around the problem of the size of a change
-- output increasing when minimizing the fee.
--
-- For this quick workaround, we assume all change outputs will contain
-- 0.065536 ada or more. This is certainly the case on mainnet with a
-- minUTxOValue of ≈1 ada. Then we only need to care about the following
-- two sizes of CBOR lovelace values:
-- - [0.065536 ada, 4.294967296 ada) is encoded as 5 bytes
-- - 4.294967296 ada and more is encoded as 9 bytes
--
-- To avoid fee minimization unknowingly increasing the size by 4 bytes,
-- we preemptively add an extra 4 bytes here.
--
-- https://json.nlohmann.me/features/binary_formats/cbor/
--
-- This fixes a 'prop_balanceTransactionBalanced' failure with seed
-- 1567390257.
--
-- TODO [ADP-1514] Improve fee minimization
let perByteFee = view #protocolParamTxFeePerByte nodePParams
let feePadding = Coin (4 * fromIntegral perByteFee)

-- NOTE: evaluateMinimumFee relies on correctly estimating the required
-- number of witnesses.
minfee <- (Coin.add feePadding)
<$> nothingAsByronErr (evaluateMinimumFee tl nodePParams tx)
minfee <- nothingAsByronErr (evaluateMinimumFee tl nodePParams tx)
let update = TxUpdate [] [] [] (UseNewTxFee minfee)
tx' <- left ErrBalanceTxUpdateError $ updateTx tl tx update
balance <-
Expand Down Expand Up @@ -1933,17 +1904,21 @@ balanceTransactionWithSelectionStrategy
defaultTransactionCtx
boringSkeleton

-- Workaround for a corner case failure in
-- prop_balanceTransactionBalanced where.
--
-- Seems to be related with the wallet selecting a change output
-- with a coin value just about the 9 byte limit (4294967296). I.e.
-- seems like a problem of coin selection.
feePadding =
let LinearFee LinearFunction {slope = perByte} =
view (#txParameters . #getFeePolicy) pp
scriptIntegrityHashBytes = 32 + 2
extraBytes = 4

-- Add padding to allow the fee value to increase.
-- Out of caution, assume it can increase by the theoretical
-- maximum of 8 bytes ('maximumCostOfIncreasingCoin').
--
-- NOTE: It's not convenient to import the constant at the
-- moment because of the package split.
--
-- Any overestimation will be reduced by 'distributeSurplus'
-- in the final stage of 'balanceTransaction'.
extraBytes = 8
in
Coin $ (round perByte) * (extraBytes + scriptIntegrityHashBytes)

Expand Down
45 changes: 45 additions & 0 deletions lib/core/src/Cardano/Wallet/Transaction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,6 +34,7 @@ module Cardano.Wallet.Transaction
, AnyScript (..)
, PlutusScriptInfo (..)
, PlutusVersion (..)
, TxFeeAndChange (..)

-- * Errors
, ErrSignTx (..)
Expand All @@ -42,6 +43,7 @@ module Cardano.Wallet.Transaction
, ErrCannotQuit (..)
, ErrUpdateSealedTx (..)
, ErrAssignRedeemers(..)
, ErrMoreSurplusNeeded (..)
) where

import Prelude
Expand All @@ -66,6 +68,7 @@ import Cardano.Wallet.Primitive.Slotting
( PastHorizonException, TimeInterpreter )
import Cardano.Wallet.Primitive.Types
( Certificate
, FeePolicy
, PoolId
, ProtocolParameters
, SlotNo (..)
Expand Down Expand Up @@ -252,6 +255,35 @@ data TransactionLayer k tx = TransactionLayer
--
-- Returns `Nothing` for ByronEra transactions.

, distributeSurplus
:: FeePolicy
-> Coin -- Surplus to distribute
-> TxFeeAndChange -- Fee and value of relevant change output (if any)
-> Either ErrMoreSurplusNeeded TxFeeAndChange
-- ^ Distribute a surplus transaction balance between a given change
-- output (if one exists present) and the transaction fee. The function
-- is aware of the fact that any increase of 'Coin' values could
-- increase the size and fee-requirement of the transaction.
--
-- This helper is used from 'balanceTransaction'.
--
-- >>> distributeSurplus feePolicy (Coin 100) (TxFeeAndChange (Coin 200) (Coin 200))
-- TxFeeAndChange
-- { fee = Coin 1
-- , change = Coin 99
-- }
--
-- >>> distributeSurplus feePolicy (Coin 100) (TxFeeAndChange (Coin 255) (Coin 200))
-- TxFeeAndChange
-- { fee = Coin 2
-- , change = Coin 98
-- }
--
-- Important note: the return value is a delta. In particular a returned
-- change value of @Nothing@ or @Just (Coin 0)@ does **not** mean the
-- change should be set to @Coin 0@, but rather that the change should
-- not be increased!

, computeSelectionLimit
:: ProtocolParameters
-> TransactionCtx
Expand Down Expand Up @@ -477,3 +509,16 @@ data ErrUpdateSealedTx
-- key-witnesses would have been rendered invalid.
| ErrByronTxNotSupported
deriving (Generic, Eq, Show)

-- | Error for when its impossible for 'distributeSurplus' to distribute the
-- surplus. As long as the surplus is larger than 'costOfIncreasingCoin', this
-- should never happen.
newtype ErrMoreSurplusNeeded = ErrMoreSurplusNeeded Coin
deriving (Generic, Eq, Show)

-- | Small helper record to disambiguate between a fee and change Coin values.
-- Used by 'distributeSurplus'.
data TxFeeAndChange = TxFeeAndChange
{ fee :: Coin
, change :: Maybe Coin
} deriving (Show, Eq)
2 changes: 2 additions & 0 deletions lib/core/test/unit/Cardano/WalletSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1359,6 +1359,8 @@ dummyTransactionLayer = TransactionLayer
error "dummyTransactionLayer: assignScriptRedeemers not implemented"
, evaluateMinimumFee =
error "dummyTransactionLayer: evaluateMinimumFee not implemented"
, distributeSurplus =
error "dummyTransactionLayer: distributeSurplus not implemented"
, estimateSignedTxSize =
error "dummyTransactionLayer: \
\estimateSignedTxSize not implemented"
Expand Down
100 changes: 100 additions & 0 deletions lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -54,7 +54,9 @@ module Cardano.Wallet.Shelley.Transaction
, mkUnsignedTx
, txConstraints
, costOfIncreasingCoin
, _distributeSurplus
, sizeOfCoin
, maximumCostOfIncreasingCoin
) where

import Prelude
Expand Down Expand Up @@ -176,10 +178,12 @@ import Cardano.Wallet.Transaction
, DelegationAction (..)
, ErrAssignRedeemers (..)
, ErrMkTransaction (..)
, ErrMoreSurplusNeeded (ErrMoreSurplusNeeded)
, ErrUpdateSealedTx (..)
, TokenMapWithScripts
, TransactionCtx (..)
, TransactionLayer (..)
, TxFeeAndChange (..)
, TxFeeUpdate (..)
, TxUpdate (..)
, withdrawalToCoin
Expand Down Expand Up @@ -622,6 +626,9 @@ newTransactionLayer networkId = TransactionLayer
, maxScriptExecutionCost =
_maxScriptExecutionCost


, distributeSurplus = _distributeSurplus

, assignScriptRedeemers =
_assignScriptRedeemers

Expand Down Expand Up @@ -1468,6 +1475,13 @@ costOfIncreasingCoin (LinearFee fee) from delta =
perByte = ceiling $ slope fee
costOfCoin = Coin . (perByte *) . unTxSize . sizeOfCoin

-- The maximum cost increase 'costOfIncreasingCoin' can return, which is the
-- cost of 8 bytes.
maximumCostOfIncreasingCoin :: FeePolicy -> Coin
maximumCostOfIncreasingCoin (LinearFee fee) = Coin $ ceiling $ 8 * perByte
where
perByte = slope fee

-- | Calculate the size of a coin when encoded as CBOR.
sizeOfCoin :: Coin -> TxSize
sizeOfCoin (Coin c)
Expand All @@ -1477,6 +1491,92 @@ sizeOfCoin (Coin c)
| c >= 24 = TxSize 2
| otherwise = TxSize 1

-- | Actual implementation for 'distributeSurplus'.
_distributeSurplus
:: FeePolicy
-> Coin -- ^ Surplus to distribute
-> TxFeeAndChange
-> Either ErrMoreSurplusNeeded TxFeeAndChange
_distributeSurplus feePolicy surplus fc@(TxFeeAndChange _fee0 Nothing) =
burnSurplusAsFees feePolicy surplus fc
_distributeSurplus feePolicy surplus fc@(TxFeeAndChange fee0 (Just change0)) =
let
-- We calculate the maximum possible fee increase, by assuming the
-- **entire** surplus is added to the change.
extraFee = findFixpointIncreasingFeeBy $
costOfIncreasingCoin feePolicy change0 surplus

in
case surplus `Coin.subtract` extraFee of
Just extraChange ->
Right $ TxFeeAndChange
{ fee = extraFee
, change = Just extraChange
}
Nothing ->
-- The fee increase from adding the surplus to the change was
-- greater than the surplus itself. This could happen if the
-- surplus is small.
burnSurplusAsFees feePolicy surplus fc
where
-- Increasing the fee may itself increase the fee. If that is the case, this
-- function will increase the fee further. The process repeats until the fee
-- doesn't need to be increased.
--
-- The function will always converge because the result of
-- 'costOfIncreasingCoin' is bounded to @8 * feePerByte@.
--
-- On mainnet it seems unlikely that the function would recurse more than
-- one time, and certainly not more than twice. If the protocol parameters
-- are updated to allow for slightly more expensive txs, it might be
-- possible to hit the boundary at ≈4 ada where the fee would need 9 bytes
-- rather than 5. This is already the largest boundary.
--
-- Note that both the argument and the result of this function are increases
-- relative to 'fee0'.
--
-- == Example ==
--
-- In this more extreme example the fee is increased from increasing the fee
-- itself:
--
-- @@
-- let fee0 = 23
-- let feePolicy = -- 300 lovelace / byte
--
-- findFixpointIncreasingFeeBy 1 = go 0 1
-- -- Recurse:
-- = go (0 + 1) (costOfIncreasingCoin feePolicy (23 + 0) 1)
-- = go (0 + 1) 300
-- -- Recurse:
-- = go (1 + 300) (costOfIncreasingCoin feePolicy (23 + 1) 300)
-- = go 301 300
-- = go (301 + 300) (costOfIncreasingCoin feePolicy (23 + 301) 300)
-- = go (301 + 300) 0
-- = go 601 0
-- = 601
-- @@
findFixpointIncreasingFeeBy = go mempty
where
go :: Coin -> Coin -> Coin
go c (Coin 0) = c
go c increase = go
(c <> increase)
(costOfIncreasingCoin feePolicy (c <> fee0) increase)

burnSurplusAsFees
:: FeePolicy
-> Coin -- Surplus
-> TxFeeAndChange
-> Either ErrMoreSurplusNeeded TxFeeAndChange
burnSurplusAsFees feePolicy surplus (TxFeeAndChange fee0 _) =
case costOfBurningSurplus `Coin.subtract` surplus of
Just shortfall -> Left $ ErrMoreSurplusNeeded shortfall
Nothing ->
Right $ TxFeeAndChange surplus Nothing
where
costOfBurningSurplus = costOfIncreasingCoin feePolicy fee0 surplus

-- | Estimates the final size of a transaction based on its skeleton.
--
-- This function uses the upper bounds of CBOR serialized objects as the basis
Expand Down
Loading

0 comments on commit 1f69c03

Please sign in to comment.