Balancing overhaul (#514)

### **This improves balancing in several ways:**

1. This adds a `TxSkel` option to defer validation failures occurring
during balancing.

As a consequence, the balancing succeeds even when running the script to
assign execution units fails, and thus the balanced `TxSkel` can be
traced.

As a downside, this drastically decreases performances (as scripts are
run several more times, even if we know they fail) and thus is only made
available as an option, disabled by default.

2. This add another `TxSkel` option to cap the maximum amount of UTxOs
that can be used for balancing purposes.

This idea is that in the rare case where there are many candidate UTxOs,
the algorithm would be too greedy, and thus some constraints need to be
applied. This is now possible.

3. This reworks the main balancing function `reachValue`

The idea is that it now optimizes the solutions depending on how much
overhead in terms of size, rather than by the minAda required for the
extra payment. For instance, if a solution generates a very small extra
payment, but with many additional inputs, and another generates a bigger
extra output, but with fewers added inputs, then the latter will likely
be picked.

4. This makes it so that the body generated during fee computation is
not lost

The body is given back as a result of the balancing, and is directly
used when submitting the transaction for validation in our main
validation function.

5. This fixes an optimization bug in the fee computation

6. This improves the handling and generation of collaterals

Fixes #435 
Fixes #494 
Fixes #500 
Fixes #503

Author: mmontin

src/Cooked/MockChain/Balancing.hs

@@ -10,7 +10,6 @@ module Cooked.MockChain.Common
 where
 
 import Cooked.Skeleton.Output
-import Cooked.Skeleton.User
 import Data.Set (Set)
 import PlutusLedgerApi.V3 qualified as Api
 
@@ -22,8 +21,9 @@ type Fee = Integer
 -- | An alias for sets of utxos used as collateral inputs
 type CollateralIns = Set Api.TxOutRef
 
--- | An alias for optional pairs of collateral inputs and return collateral peer
-type Collaterals = Maybe (CollateralIns, Peer)
+-- | An alias for optional pairs of collateral inputs and optional return
+-- collateral output
+type Collaterals = (CollateralIns, Maybe TxSkelOut)
 
 -- | An alias for an output and its reference
 type Utxo = (Api.TxOutRef, TxSkelOut)

src/Cooked/MockChain/Common.hs

@@ -1,6 +1,7 @@
 -- | This module exposes the errors that can be raised during a mockchain run
 module Cooked.MockChain.Error
   ( -- * Mockchain errors
+    BalancingError (..),
     MockChainError (..),
 
     -- * Interpretating effects into `Error MockChainError`
@@ -18,16 +19,31 @@ import Polysemy
 import Polysemy.Error
 import Polysemy.Fail
 
+-- | Errors that can be produced during balancing
+data BalancingError
+  = -- | The balancing user theoretically has enough funds to balancing the
+    -- trasaction, but this balancing results in a surplus payment which they
+    -- cannot afford ADA-wise.
+    NotEnoughFundForExtraMinAda Peer
+  | -- | The balancing does not have enough funds to sustain the fee required to
+    -- balance the transaction.
+    NotEnoughFundForProperFee Peer
+  | -- | The balancing wallet does not have enough funds to balance the
+    -- transaction
+    NotEnoughFund Peer Api.Value
+  | -- | The provided of collateral UTxOs does not have enough funds to cover
+    -- the potential collateral cost
+    NoSuitableCollateral Integer Integer Api.Value
+  | -- | The balancing user has not be provided, but the balancing requires it
+    MissingBalancingUser
+  deriving (Show, Eq)
+
 -- | Errors that can be produced by the blockchain
 data MockChainError
   = -- | Validation errors, either in Phase 1 or Phase 2
     MCEValidationError Ledger.ValidationPhase Ledger.ValidationError
-  | -- | The balancing user does not have enough funds
-    MCEUnbalanceable Peer Api.Value
-  | -- | The balancing user is required but missing
-    MCEMissingBalancingUser String
-  | -- | No suitable collateral could be associated with a skeleton
-    MCENoSuitableCollateral Integer Integer Api.Value
+  | -- | Balancing errors
+    MCEBalancingError BalancingError
   | -- | Translating a skeleton element to its Cardano counterpart failed
     MCEToCardanoError Ledger.ToCardanoError
   | -- | The required reference script is missing from a witness utxo

src/Cooked/MockChain/Error.hs

@@ -41,12 +41,12 @@ txSkelToTxBodyContent ::
   (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) =>
   TxSkel ->
   Fee ->
-  Collaterals ->
+  Maybe Collaterals ->
   Sem effs (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra)
 txSkelToTxBodyContent skel@TxSkel {..} fee mCollaterals = do
   txIns <- mapM toTxInAndWitness $ Map.toList txSkelIns
   txInsReference <- toInsReference skel
-  (txInsCollateral, txTotalCollateral, txReturnCollateral) <- toCollateralTriplet fee mCollaterals
+  (txInsCollateral, txTotalCollateral, txReturnCollateral) <- toCollateralTriplet mCollaterals
   txOuts <- mapM toCardanoTxOut txSkelOuts
   (txValidityLowerBound, txValidityUpperBound) <- fromEither $ Ledger.toCardanoValidityRange txSkelValidityRange
   txMintValue <- toMintValue txSkelMints
@@ -85,7 +85,7 @@ txBodyContentToTxBody txBodyContent = do
 txSkelToIndex ::
   (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) =>
   TxSkel ->
-  Collaterals ->
+  Maybe Collaterals ->
   Sem effs (Cardano.UTxO Cardano.ConwayEra)
 txSkelToIndex txSkel mCollaterals = do
   -- We build the index of UTxOs which are known to this skeleton. This includes
@@ -106,7 +106,7 @@ txSkelToTxBody ::
   (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) =>
   TxSkel ->
   Fee ->
-  Collaterals ->
+  Maybe Collaterals ->
   Sem effs (Cardano.TxBody Cardano.ConwayEra)
 txSkelToTxBody txSkel fee mCollaterals = do
   -- We create a first body content and body, without execution units
@@ -119,9 +119,14 @@ txSkelToTxBody txSkel fee mCollaterals = do
   params <- getParams
   -- We retrieve the execution units associated with the transaction
   case Emulator.getTxExUnitsWithLogs params (Ledger.fromPlutusIndex index) tx' of
-    -- Computing the execution units can result in all kinds of validation
-    -- errors except for the ones related to the execution units themselves.
-    Left err -> throw $ uncurry MCEValidationError err
+    -- Computing the execution units can result in all kinds of phase 2
+    -- validation failures, except for the ones related to the execution units
+    -- themselves. Unless required in the options, we throw the validation
+    -- failure right away when applicable.
+    Left err | not $ txSkelOptDeferPhase2FailuresDuringBalancing $ txSkelOpts txSkel -> throw $ uncurry MCEValidationError err
+    -- The other option is to ignore those and return the unchanged body with
+    -- the existing execution units, postponing the handling of the failures.
+    Left _ -> return txBody'
     -- When no error arises, we get an execution unit for each script usage. We
     -- first have to transform this Ledger map to a cardano API map.
     Right (Map.mapKeysMonotonic (Cardano.toScriptIndex Cardano.AlonzoEraOnwardsConway) . fmap (Cardano.fromAlonzoExUnits . snd) -> exUnits) ->
@@ -131,7 +136,7 @@ txSkelToTxBody txSkel fee mCollaterals = do
         Left _ -> fail "Error while assigning execution units"
         -- We now have a body content with proper execution units and can create
         -- the final body from it
-        Right txBody -> txBodyContentToTxBody txBody
+        Right txBodyContent -> txBodyContentToTxBody txBodyContent
 
 -- | Generates a Cardano transaction and signs it
 txSignatoriesAndBodyToCardanoTx ::
@@ -145,7 +150,7 @@ txSkelToCardanoTx ::
   (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) =>
   TxSkel ->
   Fee ->
-  Collaterals ->
+  Maybe Collaterals ->
   Sem effs (Cardano.Tx Cardano.ConwayEra)
 txSkelToCardanoTx txSkel fee =
   fmap (txSignatoriesAndBodyToCardanoTx (txSkelSignatories txSkel))

src/Cooked/MockChain/GenerateTx/Body.hs

@@ -3,76 +3,54 @@
 module Cooked.MockChain.GenerateTx.Collateral where
 
 import Cardano.Api qualified as Cardano
-import Cardano.Ledger.Conway.Core qualified as Conway
-import Cardano.Node.Emulator.Internal.Node qualified as Emulator
-import Control.Monad
 import Cooked.MockChain.Common
+import Cooked.MockChain.GenerateTx.Output
 import Cooked.MockChain.Read
 import Cooked.Skeleton.Output
+import Cooked.Skeleton.Value
+import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Ledger.Tx.CardanoAPI qualified as Ledger
-import Lens.Micro.Extras qualified as MicroLens
-import Plutus.Script.Utils.Address qualified as Script
-import Plutus.Script.Utils.Value qualified as Script
-import PlutusTx.Numeric qualified as PlutusTx
+import Optics.Core
+import PlutusLedgerApi.V3 qualified as Api
 import Polysemy
 import Polysemy.Error
 
--- | Computes the collateral triplet from the fees and the collateral inputs in
--- the context. What we call a collateral triplet is composed of:
+-- | Computes the collateral triplet from the potential collaterals. What we
+-- call a collateral triplet is composed of:
+--
 -- * The set of collateral inputs
+--
 -- * The total collateral paid by the transaction in case of phase 2 failure
+--
 -- * An output returning excess collateral value when collaterals are used
+--
 -- These quantity should satisfy the equation (in terms of their values):
 -- collateral inputs = total collateral + return collateral
 toCollateralTriplet ::
   (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) =>
-  Fee ->
-  Collaterals ->
+  Maybe Collaterals ->
   Sem
     effs
     ( Cardano.TxInsCollateral Cardano.ConwayEra,
       Cardano.TxTotalCollateral Cardano.ConwayEra,
       Cardano.TxReturnCollateral Cardano.CtxTx Cardano.ConwayEra
     )
-toCollateralTriplet _ Nothing = return (Cardano.TxInsCollateralNone, Cardano.TxTotalCollateralNone, Cardano.TxReturnCollateralNone)
-toCollateralTriplet fee (Just (Set.toList -> collateralInsList, returnCollateralUser)) = do
+toCollateralTriplet Nothing = return (Cardano.TxInsCollateralNone, Cardano.TxTotalCollateralNone, Cardano.TxReturnCollateralNone)
+toCollateralTriplet (Just (Set.toList -> collateralInsList, mReturnCollateral)) = do
   -- We build the collateral inputs from this list
   txInsCollateral <-
     case collateralInsList of
       [] -> return Cardano.TxInsCollateralNone
       l -> fromEither $ Cardano.TxInsCollateral Cardano.AlonzoEraOnwardsConway <$> mapM Ledger.toCardanoTxIn l
-  -- Retrieving the total value in collateral inputs. This fails if one of the
-  -- collateral inputs has not been successfully resolved.
-  collateralInsValue <-
-    foldM (\val -> ((val <>) <$>) . viewByRef txSkelOutValueL) mempty collateralInsList
-  -- We retrieve the collateral percentage compared to fees. By default, we use
-  -- 150% which is the current value in the parameters, although the default
-  -- value should never be used here, as the call is supposed to always succeed.
-  collateralPercentage <- toInteger . MicroLens.view Conway.ppCollateralPercentageL . Emulator.pEmulatorPParams <$> getParams
-  -- The total collateral corresponds to the fees multiplied by the collateral
-  -- percentage. We add 1 because the ledger apparently rounds up this value.
-  let coinTotalCollateral = 1 + (fee * collateralPercentage) `div` 100
-  -- We create the total collateral based on the computed value
-  let txTotalCollateral = Cardano.TxTotalCollateral Cardano.BabbageEraOnwardsConway $ Cardano.Coin coinTotalCollateral
-  -- We compute a return collateral value by subtracting the total collateral to
-  -- the value in collateral inputs
-  let returnCollateralValue = collateralInsValue <> PlutusTx.negate (Script.lovelace coinTotalCollateral)
-  -- The return collateral is then computed
+  -- We collect the amount of lovelace in the collateral inputs
+  Api.Lovelace collateralInsLovelace <- foldOf (folded % txSkelOutValueL % valueLovelaceL) . Map.elems <$> lookupUtxos collateralInsList
+  -- We collect the amount of lovelace in the return collateral output
+  let Api.Lovelace returnCollateralLovelace = maybe 0 (view (txSkelOutValueL % valueLovelaceL)) mReturnCollateral
+  -- The total collateral is the difference between the two
+  let txTotalCollateral = Cardano.TxTotalCollateral Cardano.BabbageEraOnwardsConway $ Cardano.Coin $ collateralInsLovelace - returnCollateralLovelace
   txReturnCollateral <-
-    -- If the total collateral equal what the inputs provide, we return
-    -- `TxReturnCollateralNone`, otherwise, we compute the new output
-    if returnCollateralValue == mempty
-      then return Cardano.TxReturnCollateralNone
-      else do
-        -- The value is a translation of the remaining value
-        txReturnCollateralValue <- Ledger.toCardanoTxOutValue <$> fromEither (Ledger.toCardanoValue returnCollateralValue)
-        -- The address is the one from the return collateral user, which is
-        -- required to exist here.
-        networkId <- Emulator.pNetworkId <$> getParams
-        address <- fromEither $ Ledger.toCardanoAddressInEra networkId (Script.toAddress returnCollateralUser)
-        -- The return collateral is built up from those elements
-        return $
-          Cardano.TxReturnCollateral Cardano.BabbageEraOnwardsConway $
-            Cardano.TxOut address txReturnCollateralValue Cardano.TxOutDatumNone Cardano.ReferenceScriptNone
+    case mReturnCollateral of
+      Nothing -> return Cardano.TxReturnCollateralNone
+      Just collateralOut -> Cardano.TxReturnCollateral Cardano.BabbageEraOnwardsConway <$> toCardanoTxOut collateralOut
   return (txInsCollateral, txTotalCollateral, txReturnCollateral)

src/Cooked/MockChain/GenerateTx/Collateral.hs

@@ -32,7 +32,7 @@ data MockChainLogEntry
     MCLogSubmittedTxSkel TxSkel
   | -- | Logging a Skeleton as it has been adjusted by the balancing mechanism,
     -- alongside fee, and possible collateral utxos and return collateral user.
-    MCLogAdjustedTxSkel TxSkel Fee Collaterals
+    MCLogAdjustedTxSkel TxSkel Fee (Maybe Collaterals)
   | -- | Logging the successful validation of a new transaction, with its id and
     -- number of produced outputs.
     MCLogNewTx Api.TxId Integer

src/Cooked/MockChain/Log.hs

@@ -178,12 +178,13 @@ runMockChainWrite = interpret $ \case
     autoFillWithdrawalAmounts
     -- We balance the skeleton when requested in the skeleton option, and get
     -- the associated fee, collateral inputs and return collateral user
-    (finalTxSkel, fee, mCollaterals) <- viewTweak simple >>= balanceTxSkel
+    ExtendedTxSkel finalTxSkel fee mCollaterals body <- viewTweak simple >>= balanceTxSkel
     -- We log the adjusted skeleton
     logEvent $ MCLogAdjustedTxSkel finalTxSkel fee mCollaterals
     -- We generate the transaction asscoiated with the skeleton, and apply on it
     -- the modifications from the skeleton options
-    cardanoTx <- Ledger.CardanoEmulatorEraTx . txSkelOptModTx <$> txSkelToCardanoTx finalTxSkel fee mCollaterals
+    signatories <- viewTweak txSkelSignatoriesL
+    let cardanoTx = Ledger.CardanoEmulatorEraTx $ txSkelOptModTx $ txSignatoriesAndBodyToCardanoTx signatories body
     -- To run transaction validation we need a minimal ledger state
     eLedgerState <- gets mcstLedgerState
     -- We finally run the emulated validation. We update our internal state
@@ -193,18 +194,16 @@ runMockChainWrite = interpret $ \case
     newOutputs <- case Emulator.validateCardanoTx newParams eLedgerState cardanoTx of
       -- In case of a phase 1 error, we give back the same index
       (_, Ledger.FailPhase1 _ err) -> throw $ MCEValidationError Ledger.Phase1 err
-      (newELedgerState, Ledger.FailPhase2 _ err _) | Just (colInputs, retColUser) <- mCollaterals -> do
+      (newELedgerState, Ledger.FailPhase2 _ err _) | Just (colInputs, mRetColOutput) <- mCollaterals -> do
         -- We update the emulated ledger state
         modify' (set mcstLedgerStateL newELedgerState)
         -- We remove the collateral utxos from our own stored outputs
         forM_ colInputs $ modify' . removeOutput
-        -- We add the returned collateral to our outputs (in practice this map
-        -- either contains no element, or a single one)
-        forM_ (Map.toList $ Ledger.getCardanoTxProducedReturnCollateral cardanoTx) $ \(txIn, txOut) ->
-          modify' $
-            addOutput
-              (Ledger.fromCardanoTxIn txIn)
-              (retColUser `receives` Value (Api.txOutValue . Ledger.fromCardanoTxOutToPV2TxInfoTxOut . Ledger.getTxOut $ txOut))
+        -- We add the returned collateral to our outputs when it exists
+        case (mRetColOutput, Map.toList $ Ledger.getCardanoTxProducedReturnCollateral cardanoTx) of
+          (Nothing, []) -> return ()
+          (Just retColOutput, [(txIn, _)]) -> modify' $ addOutput (Ledger.fromCardanoTxIn txIn) retColOutput
+          _ -> fail "Unreachable case when processing return collaterals, please report a bug at https://github.com/tweag/cooked-validators/issues"
         -- We throw a mockchain error
         throw $ MCEValidationError Ledger.Phase2 err
       -- In case of success, we update the index with all inputs and outputs

src/Cooked/MockChain/Write.hs

@@ -67,21 +67,15 @@ instance (Show a) => PrettyCooked (MockChainReturn a) where
 instance PrettyCooked Peer where
   prettyCookedOpt opts = prettyHash opts . Script.toPubKeyHash
 
-instance PrettyCooked MockChainError where
-  prettyCookedOpt opts (MCEValidationError plutusPhase plutusError) =
-    PP.vsep ["Validation error " <+> prettyCookedOpt opts plutusPhase, PP.indent 2 (prettyCookedOpt opts plutusError)]
-  prettyCookedOpt _ (MCEMissingBalancingUser msg) = "Missing balancing user:" <+> PP.pretty msg
-  prettyCookedOpt opts (MCEUnbalanceable balUser missingValue) =
-    prettyItemize
-      opts
-      "Unbalanceable:"
-      "-"
-      [ prettyCookedOpt opts balUser <+> "does not have enough funds",
-        if missingValue == mempty
-          then "Not enough funds to sustain the minimal ada of the return utxo"
-          else "Unable to find" <+> prettyCookedOpt opts missingValue
-      ]
-  prettyCookedOpt opts (MCENoSuitableCollateral fee percentage colVal) =
+instance PrettyCooked BalancingError where
+  prettyCookedOpt opts (NotEnoughFundForExtraMinAda peer) =
+    prettyCookedOpt opts peer <+> "does not have enough funds to account for the min ADA of the surplus payment"
+  prettyCookedOpt opts (NotEnoughFundForProperFee peer) =
+    prettyCookedOpt opts peer <+> "does not have enough funds to account for the minimum required fee"
+  prettyCookedOpt opts (NotEnoughFund peer missingValue) =
+    prettyCookedOpt opts peer <+> "does not have enough funds to account for this missing value:" <+> prettyCookedOpt opts missingValue
+  prettyCookedOpt _ MissingBalancingUser = "Missing balancing user"
+  prettyCookedOpt opts (NoSuitableCollateral fee percentage colVal) =
     prettyItemize
       opts
       "No suitable collateral"
@@ -90,6 +84,11 @@ instance PrettyCooked MockChainError where
         "Percentage in params was" <+> prettyCookedOpt opts percentage,
         "Resulting minimal collateral value was" <+> prettyCookedOpt opts colVal
       ]
+
+instance PrettyCooked MockChainError where
+  prettyCookedOpt opts (MCEValidationError plutusPhase plutusError) =
+    PP.vsep ["Validation error " <+> prettyCookedOpt opts plutusPhase, PP.indent 2 (prettyCookedOpt opts plutusError)]
+  prettyCookedOpt opts (MCEBalancingError err) = prettyCookedOpt opts err
   prettyCookedOpt _ (MCEToCardanoError cardanoError) =
     "Transaction generation error:" <+> PP.pretty cardanoError
   prettyCookedOpt opts (MCEUnknownOutRef txOutRef) = "Unknown transaction output ref:" <+> prettyCookedOpt opts txOutRef
@@ -136,9 +135,11 @@ instance PrettyCooked (Contextualized MockChainLogEntry) where
           ++ ( ("Fee:" <+> prettyCookedOpt opts (Script.lovelace fee))
                  : maybe
                    ["No collateral required"]
-                   ( \(collaterals, returnUser) ->
+                   ( \(collaterals, mRetColOutput) ->
                        [ prettyItemize opts "Collateral inputs:" "-" (Contextualized outputs . CollateralInput <$> Set.toList collaterals),
-                         "Return collateral target:" <+> prettyCookedOpt opts returnUser
+                         case mRetColOutput of
+                           Nothing -> "No return collateral output"
+                           Just retColOutput -> prettyItemize opts "Return collateral output:" "-" retColOutput
                        ]
                    )
                    mCollaterals

src/Cooked/Pretty/MockChain.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveFunctor #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- | This module implements 'PrettyCooked', 'PrettyCookedList' and
@@ -13,7 +12,7 @@ import Cooked.Wallet (Wallet)
 import Data.Default
 import Data.Map (Map)
 import Data.Map qualified as Map
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, fromJust)
 import Data.Set qualified as Set
 import Ledger.Slot qualified as Ledger
 import Optics.Core
@@ -293,13 +292,17 @@ instance PrettyCookedList TxSkelOpts where
         txSkelOptBalancingUtxos
         _
         txSkelOptCollateralUtxos
+        txSkelOptDeferFailures
+        txSkelOptMaxNbOfBalancingUtxos
       ) =
       [ prettyIfNot True prettyAutoSlotIncrease txSkelOptAutoSlotIncrease,
         prettyIfNot def prettyBalanceOutputPolicy txSkelOptBalanceOutputPolicy,
         prettyIfNot def prettyBalanceFeePolicy txSkelOptFeePolicy,
         prettyIfNot def prettyBalancingPolicy txSkelOptBalancingPolicy,
         prettyIfNot def prettyBalancingUtxos txSkelOptBalancingUtxos,
-        prettyIfNot def prettyCollateralUtxos txSkelOptCollateralUtxos
+        prettyIfNot def prettyCollateralUtxos txSkelOptCollateralUtxos,
+        prettyIfNot False (const "Defer Phase 2 failures during balancing") txSkelOptDeferFailures,
+        prettyIfNot Nothing (("Limit the number of balancing Utxos to " <>) . PP.pretty . fromJust) txSkelOptMaxNbOfBalancingUtxos
       ]
       where
         prettyIfNot :: (Eq a) => a -> (a -> DocCooked) -> a -> Maybe DocCooked