Skip to content

Commit

Permalink
new balancing working
Browse files Browse the repository at this point in the history
  • Loading branch information
mmontin committed Jun 8, 2024
1 parent 3d62774 commit 606e832
Show file tree
Hide file tree
Showing 3 changed files with 42 additions and 219 deletions.
257 changes: 40 additions & 217 deletions src/Cooked/MockChain/Balancing.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,16 +20,13 @@ import Cooked.Wallet
import Data.Bifunctor
import Data.Function
import Data.List
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe
import Data.Ratio qualified as Rat
import Data.Set (Set)
import Data.Set qualified as Set
import Ledger.Index qualified as Ledger
import Optics.Core hiding (chosen)
import Optics.Core
import Plutus.Script.Utils.Ada qualified as Script
import Plutus.Script.Utils.Value qualified as Script
import PlutusLedgerApi.V1.Value qualified as Api
import PlutusLedgerApi.V3 qualified as Api
import PlutusTx.Prelude qualified as PlutusTx
Expand Down Expand Up @@ -91,19 +88,18 @@ calcMaxFee = do
Emulator.Coin txFeeFixed = Cardano.protocolParamTxFeeFixed params
Cardano.ExecutionUnitPrices priceESteps priceEMem = fromMaybe defExecutionUnitPrices $ Cardano.protocolParamPrices params
Cardano.ExecutionUnits (toInteger -> eSteps) (toInteger -> eMem) = fromMaybe defMaxTxExecutionUnits $ Cardano.protocolParamMaxTxExUnits params
-- Intermediate computations
-- Final fee accounts for the size of the transaction and the units consumed
-- by the execution of scripts from the transaction
let sizeFees = txFeeFixed + (maxTxSize * txFeePerByte)
eStepsFees = (eSteps * Rat.numerator priceESteps) `div` Rat.denominator priceESteps
eMemFees = (eMem * Rat.numerator priceEMem) `div` Rat.denominator priceEMem
-- Final fee accounts for the size of the transaction and the units consumed
-- by the execution of scripts from the transaction
return $ Fee $ sizeFees + eStepsFees + eMemFees

-- | Balances a skeleton and computes optimal fees using a dychotomic search
calcFee :: (MonadBlockChainBalancing m) => Wallet -> Fee -> Fee -> Set Api.TxOutRef -> Wallet -> TxSkel -> m (TxSkel, Fee, Set Api.TxOutRef)
calcFee _ minFee maxFee _ _ _ | minFee >= maxFee = fail "cannot balance"
calcFee balanceWallet minFee@(Fee a) maxFee@(Fee b) collateralIns returnCollateralWallet skel | fee <- Fee $ div (a + b) 2 = do
attemptedSkel <- balanceTxFromAux balanceWallet skel fee
attemptedSkel <- computeBalancedTxSkel balanceWallet skel fee
adjustedCollateralIns <- collateralInsFromFees fee collateralIns returnCollateralWallet
newFee <- estimateTxSkelFee attemptedSkel fee adjustedCollateralIns returnCollateralWallet
case newFee - fee of
Expand Down Expand Up @@ -159,7 +155,7 @@ reachValue (h@(_, Api.txOutValue -> hVal) : t) target maxEls =
(++)
-- dropping the first element
(reachValue t target maxEls)
-- taking the first element
-- picking the first element
(first (h :) <$> reachValue t (target <> PlutusTx.negate hVal) (maxEls - 1))

-- | This function is essentially a copy of
Expand All @@ -181,212 +177,39 @@ estimateTxSkelFee skel fee collateralIns returnCollateralWallet = do
pParams = Emulator.pEmulatorPParams params
case Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway txBodyContent of
Left err -> throwError $ MCEGenerationError (TxBodyError "Error creating body when estimating fees" err)
Right txBody | Emulator.Coin fee' <- Cardano.evaluateTransactionFee Cardano.ShelleyBasedEraConway pParams txBody nkeys 0 -> return $ Fee fee'

balanceTxFromAux :: (MonadBlockChainBalancing m) => Wallet -> TxSkel -> Fee -> m TxSkel
balanceTxFromAux balanceWallet txskel fee = do
bres@(BalanceTxRes {newInputs, returnValue, availableUtxos}) <- calcBalanceTx balanceWallet txskel fee
case applyBalanceTx (walletPKHash balanceWallet) bres txskel of
Just txskel' -> return txskel'
Nothing ->
throwError $
MCEUnbalanceable
( MCEUnbalNotEnoughReturning
(valueAndRefs newInputs)
(valueAndRefs availableUtxos)
returnValue
)
txskel
where
valueAndRefs :: [(Api.TxOutRef, Api.TxOut)] -> (Api.Value, [Api.TxOutRef])
valueAndRefs x = (mconcat (outputValue . snd <$> x), fst <$> x)

data BalanceTxRes = BalanceTxRes
{ -- | Inputs that need to be added in order to cover the value in the
-- transaction outputs
newInputs :: [(Api.TxOutRef, Api.TxOut)],
-- | The 'newInputs' will add _at least_ the missing value to cover the
-- outputs, this is the difference of the input value together with the
-- 'newInputs' and the output value. This value must be nonnegative in
-- every asset class.
returnValue :: Api.Value,
-- | Some additional UTxOs that could be used as extra inputs. These all
-- belong to the same wallet that was passed to 'calcBalanceTx' as an
-- argument, and are sorted in decreasing order of their Ada value.
availableUtxos :: [(Api.TxOutRef, Api.TxOut)]
}
deriving (Show)
Right txBody | Emulator.Coin (Fee -> fee') <- Cardano.evaluateTransactionFee Cardano.ShelleyBasedEraConway pParams txBody nkeys 0 -> return fee'

-- | Calculate the changes needed to balance a transaction with assets from a
-- given wallet. Every transaction that is sent to the chain must be balanced:
-- @inputs + mints == outputs + fee + burns@.
calcBalanceTx :: (MonadBlockChainBalancing m) => Wallet -> TxSkel -> Fee -> m BalanceTxRes
calcBalanceTx balanceWallet skel fee = do
inValue <- (<> positivePart (txSkelMintsValue $ txSkelMints skel)) <$> txSkelInputValue skel -- transaction inputs + minted value
let outValue = txSkelOutputValue skel fee -- transaction outputs + fee + burned value
difference = outValue <> PlutusTx.negate inValue
-- This is the value that must still be paid by 'balancePK' in order to
-- balance the transaction:
missingValue = positivePart difference
-- This will be paid to 'balancePK' in any case:
initialExcess = negativePart difference
-- All TxOutRefs that the transaction consumes. We'll need them to make
-- sure that no additional UTxOs are chosen that are in fact already
-- present on the transaction.
inputOrefs = Map.keys $ txSkelIns skel
-- Get all UTxOs that belong to the given wallet, and that are not yet being
-- consumed on the transaction.
--
-- These UTxOs are sorted in decreasing order of their Ada value, which will
-- make 'selectNewInputs' will more likely select additional inputs that
-- contain a lot of Ada. The hope behind this heuristic is that it'll
-- therefore become less likely for the 'returnValue' to be less than the
-- minimum Ada amount required for each output. See this comment for context:
-- https://github.com/tweag/cooked-validators/issues/71#issuecomment-1016406041
candidateUtxos <-
sortBy (flip compare `on` Script.fromValue . outputValue . snd)
. filter ((`notElem` inputOrefs) . fst)
<$> utxosAt (walletAddress balanceWallet)
case selectNewInputs candidateUtxos [] initialExcess missingValue of
Nothing -> throwError $ MCEUnbalanceable (MCEUnbalNotEnoughFunds balanceWallet missingValue) skel
Just bTxRes -> return bTxRes
where
selectNewInputs ::
[(Api.TxOutRef, Api.TxOut)] ->
[(Api.TxOutRef, Api.TxOut)] ->
Api.Value ->
Api.Value ->
Maybe BalanceTxRes
selectNewInputs available chosen excess missing =
case view flattenValueI missing of
[] -> Just $ BalanceTxRes chosen excess available
(ac, _) : _ ->
-- Find the first UTxO belonging to the wallet that contains at least
-- one token of the required asset class (The hope is that it'll
-- contain at least @n@ such tokens, but we can't yet fail if there
-- are fewer; we might need to add several UTxOs):
case break ((`Script.geq` Script.assetClassValue ac 1) . outputValue . snd) available of
(_, []) -> Nothing -- The wallet owns nothing of the required asset class. We can't balance with this wallet.
(previousUtxos, theChosenUtxo : nextUtxos) ->
let available' = previousUtxos ++ nextUtxos
chosen' = theChosenUtxo : chosen
theChosenValue = outputValue $ snd theChosenUtxo
theChosenDifference = missing <> PlutusTx.negate theChosenValue
excess' = excess <> negativePart theChosenDifference
missing' = positivePart theChosenDifference
in -- A remark on why the following line should not lead to an
-- infinite recursion: The value described by @missing'@ is
-- strictly smaller than the value described by @missing@,
-- because there was at least one token of the asset class
-- @ac@ in @theChosenValue@.
selectNewInputs available' chosen' excess' missing'

-- | Once we calculated what is needed to balance a transaction @skel@, we still
-- need to apply those changes to @skel@. Because of the 'Script.minAdaTxOut'
-- constraint, this might not be possible: imagine the leftover is less than
-- 'Script.minAdaTxOut', but the transaction has no output addressed to the
-- balancing wallet. If we just create a new ouput for the balancing wallet and
-- place the leftover there, the resulting transaction will fail to validate
-- with "LessThanMinAdaPerUTxO" error. Instead, we need to consume yet another
-- UTxO belonging to the wallet to then create the output with the proper
-- leftover. If the wallet has no UTxO, then there's no way to balance this
-- transaction.
applyBalanceTx :: Api.PubKeyHash -> BalanceTxRes -> TxSkel -> Maybe TxSkel
applyBalanceTx balancePK (BalanceTxRes newInputs returnValue availableUtxos) skel@TxSkel {..} = do
-- Here we'll try a few things, in order, until one of them succeeds:
--
-- 1. If allowed by the balanceOutputPolicy, pick out the best possible output
-- to adjust and adjust it as long as it remains with more than
-- 'Script.minAdaTxOut'. No need for additional inputs apart from the
-- @newInputs@. The "best possible" here means the most valuable ada-only
-- output without any datum that will be paid to the given wallet. If the
-- policy doesn't allow modifying an existing utxo or no such utxo exists,
-- we move on to the next option;
--
-- 2. If the leftover is more than 'Script.minAdaTxOut' and (1) wasn't
-- possible, create a new output to return leftover. No need for additional
-- inputs besides the @newInputs@.
--
-- 3. Attempt to consume other possible utxos from 'w' in order to combine
-- them and return the leftover.

-- TODO: Mustn't every UTxO belonging to the wallet contain at least minAda?
-- In that case, we could forget about adding several additional inputs. If
-- one isn't enough, there's nothing we can do, no?
let bestOuts ::
-- \| Current best partition of the outputs
Maybe ([TxSkelOut], (TxSkelOut, Integer), [TxSkelOut]) ->
-- \| Outputs that have already been checked
[TxSkelOut] ->
-- \| Outputs that remain to be checked
[TxSkelOut] ->
-- \| Returns the best (if any) candidate output alongside its
-- predecessors and successors
Maybe ([TxSkelOut], (TxSkelOut, Integer), [TxSkelOut])
bestOuts currentBest _ [] = currentBest
bestOuts currentBest processed (txSkelOut@(Pays output) : nexts) =
case isPKOutputFrom balancePK output >>= isOutputWithoutDatum >>= isOnlyAdaOutput of
Nothing -> bestOuts currentBest (processed ++ [txSkelOut]) nexts
Just output'
| Script.Lovelace amount <- output' ^. outputValueL ->
if amount < maybe 0 (\(_, (_, x), _) -> x) currentBest
then -- This is a good candidate but a better one was found before
bestOuts currentBest (processed ++ [txSkelOut]) nexts
else -- This is the best candidate so far
Just (processed, (txSkelOut, amount), nexts)

(newIns, newOuts) <-
case bestOuts Nothing [] txSkelOuts of
Nothing ->
-- There's no "best possible transaction output" in the sense described
-- above.
tryAdditionalOutput txSkelIns txSkelOuts
Just (previousUtxos, (bestTxOut, _), nextUtxos) ->
case txOptBalanceOutputPolicy txSkelOpts of
AdjustExistingOutput ->
let bestTxOutValue = txSkelOutValue bestTxOut
adjustedValue = bestTxOutValue <> returnValue
in if adjustedValue `Script.geq` Script.toValue Ledger.minAdaTxOutEstimated -- TODO make this depende on the atual TxOut
then
Just -- (1)
( txSkelIns <> Map.fromSet (const TxSkelNoRedeemerForPK) (Set.fromList $ map fst newInputs),
previousUtxos ++ (bestTxOut & txSkelOutValueL .~ adjustedValue) : nextUtxos
)
else tryAdditionalInputs txSkelIns txSkelOuts availableUtxos returnValue
DontAdjustExistingOutput -> tryAdditionalOutput txSkelIns txSkelOuts
return skel {txSkelIns = newIns, txSkelOuts = newOuts}
where
tryAdditionalOutput ::
Map Api.TxOutRef TxSkelRedeemer ->
[TxSkelOut] ->
Maybe (Map Api.TxOutRef TxSkelRedeemer, [TxSkelOut])
tryAdditionalOutput ins outs =
if Script.fromValue returnValue >= Ledger.minAdaTxOutEstimated -- TODO make this depend on the atual TxOut
then
Just -- (2)
( ins <> Map.fromSet (const TxSkelNoRedeemerForPK) (Set.fromList $ map fst newInputs),
outs ++ [paysPK balancePK returnValue]
)
else tryAdditionalInputs ins outs availableUtxos returnValue

tryAdditionalInputs ::
Map Api.TxOutRef TxSkelRedeemer ->
[TxSkelOut] ->
[(Api.TxOutRef, Api.TxOut)] ->
Api.Value ->
Maybe (Map Api.TxOutRef TxSkelRedeemer, [TxSkelOut])
tryAdditionalInputs ins outs available oldReturn =
case available of
[] -> Nothing
(newTxOutRef, newTxOut) : newAvailable ->
let additionalValue = outputValue newTxOut
newReturn = additionalValue <> oldReturn
newIns =
( ins
<> Map.fromSet (const TxSkelNoRedeemerForPK) (Set.fromList $ map fst newInputs)
<> Map.singleton newTxOutRef TxSkelNoRedeemerForPK
)
newOuts = outs ++ [paysPK balancePK newReturn]
in if newReturn `Script.geq` Script.toValue Ledger.minAdaTxOutEstimated -- TODO make this dependen on the actual TxOut
then Just (newIns, newOuts) -- (3)
else tryAdditionalInputs newIns newOuts newAvailable newReturn
-- | This creates a balanced skeleton from a given skeleton and fee
-- In other words, this ensures that the following equation holds:
-- input value + minted value = output value + burned value + fee
computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Wallet -> TxSkel -> Fee -> m TxSkel
computeBalancedTxSkel balancingWallet txSkel (Fee (lovelace -> feeValue)) = do
params <- getParams
let mintedValue = positivePart $ txSkelMintsValue $ txSkelMints txSkel
burnedValue = negativePart $ txSkelMintsValue $ txSkelMints txSkel
outValue = foldOf (txSkelOutsL % folded % txSkelOutValueL) txSkel
inValue <- txSkelInputValue txSkel
let left = inValue <> mintedValue
right = outValue <> burnedValue <> feeValue
diff = right <> PlutusTx.negate left
-- what we need to look for in inputs
missingLeft = positivePart diff
-- what we need to provide as additional payment
missingRight = negativePart diff
balancingUtxosInitial <- runUtxoSearch $ onlyValueOutputsAtSearch balancingWallet `filterWithAlways` outputTxOut
let alreadyUsedUtxos =
Map.keys (txSkelIns txSkel)
<> mapMaybe txSkelReferenceScript (Map.elems $ txSkelIns txSkel)
<> Set.toList (txSkelInsReference txSkel)
balancingUtxos = filter ((`notElem` alreadyUsedUtxos) . fst) balancingUtxosInitial
let candidatesRaw = second (<> missingRight) <$> reachValue balancingUtxos missingLeft (toInteger $ length balancingUtxos)
candidatesDecorated = second (\val -> (val, Script.fromValue val, getTxSkelOutMinAda params $ paysPK balancingWallet val)) <$> candidatesRaw
candidatesFiltered = [(lv, (fst <$> l, val)) | (l, (val, Script.Lovelace lv, Right minLv)) <- candidatesDecorated, minLv <= lv]
case sortBy (compare `on` fst) candidatesFiltered of
[] -> throwError $ MCEUnbalanceable (MCEUnbalNotEnoughFunds balancingWallet missingLeft) txSkel
(_, (txOutRefs, val)) : _ ->
return $
txSkel
{ txSkelOuts = txSkelOuts txSkel ++ [paysPK balancingWallet val],
txSkelIns = txSkelIns txSkel <> Map.fromList ((,TxSkelNoRedeemerForPK) <$> txOutRefs)
}
2 changes: 1 addition & 1 deletion src/Cooked/MockChain/GenerateTx.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -154,7 +154,7 @@ resolveScriptOutputOwnerAndDatum txOutRef = do
validatorHash <-
case outputAddress txOut of
(Api.Address (Api.ScriptCredential (Api.ScriptHash validatorHash)) _) -> return $ Script.ValidatorHash validatorHash
_ -> throwOnString "txSkelInToTxIn: Output is not a script output"
_ -> throwOnString $ "txSkelInToTxIn: Output is not a script output" <> show txOut
validator <- throwOnLookup "txSkelInToTxIn: Unknown validator" validatorHash =<< asks managedValidators
datum <-
case outputOutputDatum txOut of
Expand Down
Loading

0 comments on commit 606e832

Please sign in to comment.