Balancing overhaul

src/Cooked/MockChain/Common.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/Error.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/GenerateTx/Body.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/Collateral.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/Log.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/Write.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/Pretty/MockChain.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/Skeleton.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