-- | This module handles auto-balancing of transaction skeleton. This includes
-- computation of fees and collaterals because their computation cannot be
-- separated from the balancing.
module Cooked.MockChain.Balancing
  ( balanceTxSkel,
    getMinAndMaxFee,
    estimateTxSkelFee,
  )
where

import Cardano.Api.Ledger qualified as Cardano
import Cardano.Api.Shelley qualified as Cardano
import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator
import Cardano.Node.Emulator.Internal.Node.Validation qualified as Emulator
import Control.Monad
import Control.Monad.Except
import Cooked.Conversion
import Cooked.MockChain.BlockChain
import Cooked.MockChain.GenerateTx.Body
import Cooked.MockChain.MinAda
import Cooked.MockChain.UtxoSearch
import Cooked.Output
import Cooked.Skeleton
import Cooked.Wallet
import Data.Bifunctor
import Data.Function
import Data.List (find, partition, sortBy)
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.Tx.CardanoAPI qualified as Ledger
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

-- * A few types to make the functions in this module more readable

type Fee = Integer

type Collaterals = Set Api.TxOutRef

type BalancingOutputs = [(Api.TxOutRef, Api.TxOut)]

-- | This is the main entry point of our balancing mechanism. This function
-- takes a skeleton and returns a (possibly) balanced skeleton alongside the
-- associated fee, collateral inputs and return collateral wallet, which might
-- be empty when no script is involved in the transaction. The options from the
-- skeleton control whether it should be balanced, and how to compute its
-- associated elements.
balanceTxSkel :: (MonadBlockChainBalancing m) => TxSkel -> m (TxSkel, Fee, Maybe (Collaterals, Wallet))
balanceTxSkel :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
balanceTxSkel skelUnbal :: TxSkel
skelUnbal@TxSkel {[Wallet]
[TxSkelProposal]
[TxSkelOut]
Collaterals
Set TxLabel
TxSkelWithdrawals
Map TxOutRef TxSkelRedeemer
TxSkelMints
SlotRange
TxOpts
txSkelLabel :: Set TxLabel
txSkelOpts :: TxOpts
txSkelMints :: TxSkelMints
txSkelSigners :: [Wallet]
txSkelValidityRange :: SlotRange
txSkelIns :: Map TxOutRef TxSkelRedeemer
txSkelInsReference :: Collaterals
txSkelOuts :: [TxSkelOut]
txSkelProposals :: [TxSkelProposal]
txSkelWithdrawals :: TxSkelWithdrawals
txSkelLabel :: TxSkel -> Set TxLabel
txSkelOpts :: TxSkel -> TxOpts
txSkelMints :: TxSkel -> TxSkelMints
txSkelSigners :: TxSkel -> [Wallet]
txSkelValidityRange :: TxSkel -> SlotRange
txSkelIns :: TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelInsReference :: TxSkel -> Collaterals
txSkelOuts :: TxSkel -> [TxSkelOut]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelWithdrawals :: TxSkel -> TxSkelWithdrawals
..} = do
  -- We retrieve the possible balancing wallet. Any extra payment will be
  -- redirected to them, and utxos will be taken from their wallet if associated
  -- with the BalancingUtxosFromBalancingWallet policy
  Maybe Wallet
balancingWallet <- case TxOpts -> BalancingPolicy
txOptBalancingPolicy TxOpts
txSkelOpts of
    BalancingPolicy
BalanceWithFirstSigner -> case [Wallet]
txSkelSigners of
      [] -> String -> m (Maybe Wallet)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't select a balancing wallet from the list of signers because it is empty."
      Wallet
bw : [Wallet]
_ -> Maybe Wallet -> m (Maybe Wallet)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Wallet -> m (Maybe Wallet))
-> Maybe Wallet -> m (Maybe Wallet)
forall a b. (a -> b) -> a -> b
$ Wallet -> Maybe Wallet
forall a. a -> Maybe a
Just Wallet
bw
    BalanceWith Wallet
bWallet -> Maybe Wallet -> m (Maybe Wallet)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Wallet -> m (Maybe Wallet))
-> Maybe Wallet -> m (Maybe Wallet)
forall a b. (a -> b) -> a -> b
$ Wallet -> Maybe Wallet
forall a. a -> Maybe a
Just Wallet
bWallet
    BalancingPolicy
DoNotBalance -> Maybe Wallet -> m (Maybe Wallet)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Wallet
forall a. Maybe a
Nothing

  -- The protocol parameters indirectly dictate a minimal and maximal value for a
  -- single transaction fee, which we retrieve.
  (Integer
minFee, Integer
maxFee) <- m (Integer, Integer)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
m (Integer, Integer)
getMinAndMaxFee

  -- We collect collateral inputs candidates. They might be directly provided in
  -- the skeleton, or should be retrieved from a given wallet. They are
  -- associated with a return collateral wallet, which we retrieve as well. All
  -- of this is wrapped in a `Maybe` type to represent the case when the
  -- transaction does not involve script and should not have any kind of
  -- collaterals attached to it.
  Maybe (Collaterals, Wallet)
mCollaterals <- do
    -- We retrieve the various kinds of scripts
    Map ValidatorHash (Versioned Validator)
spendingScripts <- TxSkel -> m (Map ValidatorHash (Versioned Validator))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m (Map ValidatorHash (Versioned Validator))
txSkelInputValidators TxSkel
skelUnbal
    -- The transaction will only require collaterals when involving scripts
    let noScriptInvolved :: Bool
noScriptInvolved =
          TxSkelMints -> Bool
forall k a. Map k a -> Bool
Map.null TxSkelMints
txSkelMints
            Bool -> Bool -> Bool
&& [(Versioned Script, TxSkelRedeemer)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((TxSkelProposal -> Maybe (Versioned Script, TxSkelRedeemer))
-> [TxSkelProposal] -> [(Versioned Script, TxSkelRedeemer)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxSkelProposal -> Maybe (Versioned Script, TxSkelRedeemer)
txSkelProposalWitness [TxSkelProposal]
txSkelProposals)
            Bool -> Bool -> Bool
&& Map ValidatorHash (Versioned Validator) -> Bool
forall k a. Map k a -> Bool
Map.null Map ValidatorHash (Versioned Validator)
spendingScripts
            Bool -> Bool -> Bool
&& [Versioned Script] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TxSkel -> [Versioned Script]
txSkelWithdrawalsScripts TxSkel
skelUnbal)
    case (Bool
noScriptInvolved, TxOpts -> CollateralUtxos
txOptCollateralUtxos TxOpts
txSkelOpts) of
      (Bool
True, CollateralUtxosFromSet Collaterals
utxos Wallet
_) -> MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (Either Wallet Collaterals -> MockChainLogEntry
MCLogUnusedCollaterals (Either Wallet Collaterals -> MockChainLogEntry)
-> Either Wallet Collaterals -> MockChainLogEntry
forall a b. (a -> b) -> a -> b
$ Collaterals -> Either Wallet Collaterals
forall a b. b -> Either a b
Right Collaterals
utxos) m ()
-> m (Maybe (Collaterals, Wallet))
-> m (Maybe (Collaterals, Wallet))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Collaterals, Wallet)
forall a. Maybe a
Nothing
      (Bool
True, CollateralUtxosFromWallet Wallet
cWallet) -> MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (Either Wallet Collaterals -> MockChainLogEntry
MCLogUnusedCollaterals (Either Wallet Collaterals -> MockChainLogEntry)
-> Either Wallet Collaterals -> MockChainLogEntry
forall a b. (a -> b) -> a -> b
$ Wallet -> Either Wallet Collaterals
forall a b. a -> Either a b
Left Wallet
cWallet) m ()
-> m (Maybe (Collaterals, Wallet))
-> m (Maybe (Collaterals, Wallet))
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Collaterals, Wallet)
forall a. Maybe a
Nothing
      (Bool
True, CollateralUtxos
CollateralUtxosFromBalancingWallet) -> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Collaterals, Wallet)
forall a. Maybe a
Nothing
      (Bool
False, CollateralUtxosFromSet Collaterals
utxos Wallet
rWallet) -> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet)))
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall a b. (a -> b) -> a -> b
$ (Collaterals, Wallet) -> Maybe (Collaterals, Wallet)
forall a. a -> Maybe a
Just (Collaterals
utxos, Wallet
rWallet)
      (Bool
False, CollateralUtxosFromWallet Wallet
cWallet) -> (Collaterals, Wallet) -> Maybe (Collaterals, Wallet)
forall a. a -> Maybe a
Just ((Collaterals, Wallet) -> Maybe (Collaterals, Wallet))
-> ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
    -> (Collaterals, Wallet))
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> Maybe (Collaterals, Wallet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Wallet
cWallet) (Collaterals -> (Collaterals, Wallet))
-> ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
    -> Collaterals)
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> (Collaterals, Wallet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOutRef] -> Collaterals
forall a. Ord a => [a] -> Set a
Set.fromList ([TxOutRef] -> Collaterals)
-> ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
    -> [TxOutRef])
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> Collaterals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxOutRef, ConcreteOutput Credential () Value ScriptHash)
 -> TxOutRef)
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> [TxOutRef]
forall a b. (a -> b) -> [a] -> [b]
map (TxOutRef, ConcreteOutput Credential () Value ScriptHash)
-> TxOutRef
forall a b. (a, b) -> a
fst ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
 -> Maybe (Collaterals, Wallet))
-> m [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> m (Maybe (Collaterals, Wallet))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
-> m [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch (Wallet
-> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
forall (m :: * -> *) addr.
(MonadBlockChainBalancing m, ToAddress addr) =>
addr
-> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
onlyValueOutputsAtSearch Wallet
cWallet)
      (Bool
False, CollateralUtxos
CollateralUtxosFromBalancingWallet) -> case Maybe Wallet
balancingWallet of
        Maybe Wallet
Nothing -> String -> m (Maybe (Collaterals, Wallet))
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't select collateral utxos from a balancing wallet because it does not exist."
        Just Wallet
bWallet -> (Collaterals, Wallet) -> Maybe (Collaterals, Wallet)
forall a. a -> Maybe a
Just ((Collaterals, Wallet) -> Maybe (Collaterals, Wallet))
-> ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
    -> (Collaterals, Wallet))
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> Maybe (Collaterals, Wallet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Wallet
bWallet) (Collaterals -> (Collaterals, Wallet))
-> ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
    -> Collaterals)
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> (Collaterals, Wallet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOutRef] -> Collaterals
forall a. Ord a => [a] -> Set a
Set.fromList ([TxOutRef] -> Collaterals)
-> ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
    -> [TxOutRef])
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> Collaterals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxOutRef, ConcreteOutput Credential () Value ScriptHash)
 -> TxOutRef)
-> [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> [TxOutRef]
forall a b. (a -> b) -> [a] -> [b]
map (TxOutRef, ConcreteOutput Credential () Value ScriptHash)
-> TxOutRef
forall a b. (a, b) -> a
fst ([(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
 -> Maybe (Collaterals, Wallet))
-> m [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
-> m (Maybe (Collaterals, Wallet))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
-> m [(TxOutRef, ConcreteOutput Credential () Value ScriptHash)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch (Wallet
-> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
forall (m :: * -> *) addr.
(MonadBlockChainBalancing m, ToAddress addr) =>
addr
-> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
onlyValueOutputsAtSearch Wallet
bWallet)

  -- At this point, the presence (or absence) of balancing wallet dictates
  -- whether the transaction should be automatically balanced or not.
  (TxSkel
txSkelBal, Integer
fee, Maybe (Collaterals, Wallet)
adjustedColsAndWallet) <- case Maybe Wallet
balancingWallet of
    Maybe Wallet
Nothing ->
      -- The balancing should not be performed. We still adjust the collaterals
      -- though around a provided fee, or the maximum fee.
      let fee :: Integer
fee = case TxOpts -> FeePolicy
txOptFeePolicy TxOpts
txSkelOpts of
            FeePolicy
AutoFeeComputation -> Integer
maxFee
            ManualFee Integer
fee' -> Integer
fee'
       in (TxSkel
skelUnbal,Integer
fee,) (Maybe (Collaterals, Wallet)
 -> (TxSkel, Integer, Maybe (Collaterals, Wallet)))
-> m (Maybe (Collaterals, Wallet))
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Integer
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
collateralsFromFees Integer
fee Maybe (Collaterals, Wallet)
mCollaterals
    Just Wallet
bWallet -> do
      -- The balancing should be performed. We collect the candidates balancing
      -- utxos based on the associated policy
      [(TxOutRef, TxOut)]
balancingUtxos <-
        case TxOpts -> BalancingUtxos
txOptBalancingUtxos TxOpts
txSkelOpts of
          BalancingUtxos
BalancingUtxosFromBalancingWallet -> UtxoSearch m TxOut -> m [(TxOutRef, TxOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch (UtxoSearch m TxOut -> m [(TxOutRef, TxOut)])
-> UtxoSearch m TxOut -> m [(TxOutRef, TxOut)]
forall a b. (a -> b) -> a -> b
$ Wallet
-> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
forall (m :: * -> *) addr.
(MonadBlockChainBalancing m, ToAddress addr) =>
addr
-> UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
onlyValueOutputsAtSearch Wallet
bWallet UtxoSearch m (ConcreteOutput Credential () Value ScriptHash)
-> (ConcreteOutput Credential () Value ScriptHash -> TxOut)
-> UtxoSearch m TxOut
forall (m :: * -> *) a b.
Monad m =>
UtxoSearch m a -> (a -> b) -> UtxoSearch m b
`filterWithAlways` ConcreteOutput Credential () Value ScriptHash -> TxOut
forall o. IsTxInfoOutput o => o -> TxOut
outputTxOut
          BalancingUtxosFromSet Collaterals
utxos ->
            -- We resolve the given set of utxos
            UtxoSearch m TxOut -> m [(TxOutRef, TxOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch ([TxOutRef] -> UtxoSearch m TxOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[TxOutRef] -> UtxoSearch m TxOut
txOutByRefSearch (Collaterals -> [TxOutRef]
forall a. Set a -> [a]
Set.toList Collaterals
utxos))
              -- We filter out those belonging to scripts, while throwing a
              -- warning if any was actually discarded.
              m [(TxOutRef, TxOut)]
-> ([(TxOutRef, TxOut)] -> m [(TxOutRef, TxOut)])
-> m [(TxOutRef, TxOut)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((TxOutRef, TxOut) -> Bool)
-> String -> [(TxOutRef, TxOut)] -> m [(TxOutRef, TxOut)]
forall {m :: * -> *} {a}.
MonadBlockChainBalancing m =>
(a -> Bool) -> String -> [a] -> m [a]
filterAndWarn (Maybe (ConcreteOutput PubKeyHash OutputDatum Value ScriptHash)
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ConcreteOutput PubKeyHash OutputDatum Value ScriptHash)
 -> Bool)
-> ((TxOutRef, TxOut)
    -> Maybe (ConcreteOutput PubKeyHash OutputDatum Value ScriptHash))
-> (TxOutRef, TxOut)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut
-> Maybe (ConcreteOutput PubKeyHash OutputDatum Value ScriptHash)
TxOut
-> Maybe
     (ConcreteOutput
        PubKeyHash
        (DatumType TxOut)
        (ValueType TxOut)
        (ReferenceScriptType TxOut))
forall out.
IsTxInfoOutput out =>
out
-> Maybe
     (ConcreteOutput
        PubKeyHash
        (DatumType out)
        (ValueType out)
        (ReferenceScriptType out))
isPKOutput (TxOut
 -> Maybe (ConcreteOutput PubKeyHash OutputDatum Value ScriptHash))
-> ((TxOutRef, TxOut) -> TxOut)
-> (TxOutRef, TxOut)
-> Maybe (ConcreteOutput PubKeyHash OutputDatum Value ScriptHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxOut) -> TxOut
forall a b. (a, b) -> b
snd) String
"They belong to scripts."
          -- We filter the candidate utxos by removing those already present in the
          -- skeleton, throwing a warning if any was actually discarded
          m [(TxOutRef, TxOut)]
-> ([(TxOutRef, TxOut)] -> m [(TxOutRef, TxOut)])
-> m [(TxOutRef, TxOut)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((TxOutRef, TxOut) -> Bool)
-> String -> [(TxOutRef, TxOut)] -> m [(TxOutRef, TxOut)]
forall {m :: * -> *} {a}.
MonadBlockChainBalancing m =>
(a -> Bool) -> String -> [a] -> m [a]
filterAndWarn ((TxOutRef -> [TxOutRef] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TxSkel -> [TxOutRef]
txSkelKnownTxOutRefs TxSkel
skelUnbal) (TxOutRef -> Bool)
-> ((TxOutRef, TxOut) -> TxOutRef) -> (TxOutRef, TxOut) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxOut) -> TxOutRef
forall a b. (a, b) -> a
fst) String
"They are already used in the skeleton."

      case TxOpts -> FeePolicy
txOptFeePolicy TxOpts
txSkelOpts of
        -- If fees are left for us to compute, we run a dichotomic search. This
        -- is full auto mode, the most powerful but time-consuming.
        FeePolicy
AutoFeeComputation ->
          Wallet
-> Integer
-> Integer
-> [(TxOutRef, TxOut)]
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet
-> Integer
-> Integer
-> [(TxOutRef, TxOut)]
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
computeFeeAndBalance Wallet
bWallet Integer
minFee Integer
maxFee [(TxOutRef, TxOut)]
balancingUtxos Maybe (Collaterals, Wallet)
mCollaterals TxSkel
skelUnbal
        -- If fee are provided manually, we adjust the collaterals and the
        -- skeleton around them directly.
        ManualFee Integer
fee -> do
          Maybe (Collaterals, Wallet)
adjustedColsAndWallet <- Integer
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Integer
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
collateralsFromFees Integer
fee Maybe (Collaterals, Wallet)
mCollaterals
          TxSkel
attemptedSkel <- Wallet -> [(TxOutRef, TxOut)] -> TxSkel -> Integer -> m TxSkel
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet -> [(TxOutRef, TxOut)] -> TxSkel -> Integer -> m TxSkel
computeBalancedTxSkel Wallet
bWallet [(TxOutRef, TxOut)]
balancingUtxos TxSkel
skelUnbal Integer
fee
          (TxSkel, Integer, Maybe (Collaterals, Wallet))
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel
attemptedSkel, Integer
fee, Maybe (Collaterals, Wallet)
adjustedColsAndWallet)

  (TxSkel, Integer, Maybe (Collaterals, Wallet))
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel
txSkelBal, Integer
fee, Maybe (Collaterals, Wallet)
adjustedColsAndWallet)
  where
    filterAndWarn :: (a -> Bool) -> String -> [a] -> m [a]
filterAndWarn a -> Bool
f String
s [a]
l
      | ([a]
ok, Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> ([a] -> Int) -> [a] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length -> Integer
koLength) <- (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition a -> Bool
f [a]
l =
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Integer
koLength Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (MockChainLogEntry -> m ()) -> MockChainLogEntry -> m ()
forall a b. (a -> b) -> a -> b
$ Integer -> String -> MockChainLogEntry
MCLogDiscardedUtxos Integer
koLength String
s) m () -> m [a] -> m [a]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ok

-- | This computes the minimum and maximum possible fee a transaction can cost
-- based on the current protocol parameters
getMinAndMaxFee :: (MonadBlockChainBalancing m) => m (Fee, Fee)
getMinAndMaxFee :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
m (Integer, Integer)
getMinAndMaxFee = do
  -- Default parameters in case they are not present. It is unclear when/if this
  -- could actually happen though. These default values have been taken from the
  -- current default instance of the protocol parameters.
  let defMaxTxExecutionUnits :: ExecutionUnits
defMaxTxExecutionUnits =
        Cardano.ExecutionUnits {executionSteps :: Natural
executionSteps = Natural
10_000_000_000, executionMemory :: Natural
executionMemory = Natural
14_000_000}
      defExecutionUnitPrices :: ExecutionUnitPrices
defExecutionUnitPrices =
        Cardano.ExecutionUnitPrices {priceExecutionSteps :: Rational
priceExecutionSteps = Integer
721 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
Rat.% Integer
10_000_000, priceExecutionMemory :: Rational
priceExecutionMemory = Integer
577 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
Rat.% Integer
10_000}
  -- Parameters necessary to compute the maximum possible fee for a transaction
  ProtocolParameters
params <- Params -> ProtocolParameters
Emulator.pProtocolParams (Params -> ProtocolParameters) -> m Params -> m ProtocolParameters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  let maxTxSize :: Integer
maxTxSize = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Natural -> Integer) -> Natural -> Integer
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Natural
Cardano.protocolParamMaxTxSize ProtocolParameters
params
      Emulator.Coin Integer
txFeePerByte = ProtocolParameters -> Coin
Cardano.protocolParamTxFeePerByte ProtocolParameters
params
      Emulator.Coin Integer
txFeeFixed = ProtocolParameters -> Coin
Cardano.protocolParamTxFeeFixed ProtocolParameters
params
      Cardano.ExecutionUnitPrices Rational
priceESteps Rational
priceEMem = ExecutionUnitPrices
-> Maybe ExecutionUnitPrices -> ExecutionUnitPrices
forall a. a -> Maybe a -> a
fromMaybe ExecutionUnitPrices
defExecutionUnitPrices (Maybe ExecutionUnitPrices -> ExecutionUnitPrices)
-> Maybe ExecutionUnitPrices -> ExecutionUnitPrices
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Maybe ExecutionUnitPrices
Cardano.protocolParamPrices ProtocolParameters
params
      Cardano.ExecutionUnits (Natural -> Integer
forall a. Integral a => a -> Integer
toInteger -> Integer
eSteps) (Natural -> Integer
forall a. Integral a => a -> Integer
toInteger -> Integer
eMem) = ExecutionUnits -> Maybe ExecutionUnits -> ExecutionUnits
forall a. a -> Maybe a -> a
fromMaybe ExecutionUnits
defMaxTxExecutionUnits (Maybe ExecutionUnits -> ExecutionUnits)
-> Maybe ExecutionUnits -> ExecutionUnits
forall a b. (a -> b) -> a -> b
$ ProtocolParameters -> Maybe ExecutionUnits
Cardano.protocolParamMaxTxExUnits ProtocolParameters
params
  -- Final fee accounts for the size of the transaction and the units consumed
  -- by the execution of scripts from the transaction
  let sizeFees :: Integer
sizeFees = Integer
txFeeFixed Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer
maxTxSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
txFeePerByte)
      eStepsFees :: Integer
eStepsFees = (Integer
eSteps Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Rational -> Integer
forall a. Ratio a -> a
Rat.numerator Rational
priceESteps) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Rational -> Integer
forall a. Ratio a -> a
Rat.denominator Rational
priceESteps
      eMemFees :: Integer
eMemFees = (Integer
eMem Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Rational -> Integer
forall a. Ratio a -> a
Rat.numerator Rational
priceEMem) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Rational -> Integer
forall a. Ratio a -> a
Rat.denominator Rational
priceEMem
  (Integer, Integer) -> m (Integer, Integer)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
txFeeFixed, Integer
sizeFees Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
eStepsFees Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
eMemFees)

-- | Computes optimal fee for a given skeleton and balances it around those fees.
-- This uses a dichotomic search for an optimal "balanceable around" fee.
computeFeeAndBalance :: (MonadBlockChainBalancing m) => Wallet -> Fee -> Fee -> BalancingOutputs -> Maybe (Collaterals, Wallet) -> TxSkel -> m (TxSkel, Fee, Maybe (Collaterals, Wallet))
computeFeeAndBalance :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet
-> Integer
-> Integer
-> [(TxOutRef, TxOut)]
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
computeFeeAndBalance Wallet
_ Integer
minFee Integer
maxFee [(TxOutRef, TxOut)]
_ Maybe (Collaterals, Wallet)
_ TxSkel
_
  | Integer
minFee Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
maxFee =
      MockChainError -> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError
 -> m (TxSkel, Integer, Maybe (Collaterals, Wallet)))
-> MockChainError
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall a b. (a -> b) -> a -> b
$ String -> MockChainError
FailWith String
"Unreachable case, please report a bug at https://github.com/tweag/cooked-validators/issues"
computeFeeAndBalance Wallet
balancingWallet Integer
minFee Integer
maxFee [(TxOutRef, TxOut)]
balancingUtxos Maybe (Collaterals, Wallet)
mCollaterals TxSkel
skel
  | Integer
minFee Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
maxFee = do
      -- The fee interval is reduced to a single element, we balance around it
      (Maybe (Collaterals, Wallet)
adjustedColsAndWallet, TxSkel
attemptedSkel) <- Wallet
-> [(TxOutRef, TxOut)]
-> Integer
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (Maybe (Collaterals, Wallet), TxSkel)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet
-> [(TxOutRef, TxOut)]
-> Integer
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (Maybe (Collaterals, Wallet), TxSkel)
attemptBalancingAndCollaterals Wallet
balancingWallet [(TxOutRef, TxOut)]
balancingUtxos Integer
minFee Maybe (Collaterals, Wallet)
mCollaterals TxSkel
skel
      (TxSkel, Integer, Maybe (Collaterals, Wallet))
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel
attemptedSkel, Integer
minFee, Maybe (Collaterals, Wallet)
adjustedColsAndWallet)
computeFeeAndBalance Wallet
balancingWallet Integer
minFee Integer
maxFee [(TxOutRef, TxOut)]
balancingUtxos Maybe (Collaterals, Wallet)
mCollaterals TxSkel
skel
  | Integer
fee <- (Integer
minFee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
maxFee) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2 = do
      -- The fee interval is larger than a single element. We attempt to balance
      -- around its central point, which can fail due to missing value in
      -- balancing utxos or collateral utxos.
      Maybe (Maybe (Collaterals, Wallet), TxSkel)
attemptedBalancing <- m (Maybe (Maybe (Collaterals, Wallet), TxSkel))
-> (MockChainError
    -> m (Maybe (Maybe (Collaterals, Wallet), TxSkel)))
-> m (Maybe (Maybe (Collaterals, Wallet), TxSkel))
forall a. m a -> (MockChainError -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError
        ((Maybe (Collaterals, Wallet), TxSkel)
-> Maybe (Maybe (Collaterals, Wallet), TxSkel)
forall a. a -> Maybe a
Just ((Maybe (Collaterals, Wallet), TxSkel)
 -> Maybe (Maybe (Collaterals, Wallet), TxSkel))
-> m (Maybe (Collaterals, Wallet), TxSkel)
-> m (Maybe (Maybe (Collaterals, Wallet), TxSkel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Wallet
-> [(TxOutRef, TxOut)]
-> Integer
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (Maybe (Collaterals, Wallet), TxSkel)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet
-> [(TxOutRef, TxOut)]
-> Integer
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (Maybe (Collaterals, Wallet), TxSkel)
attemptBalancingAndCollaterals Wallet
balancingWallet [(TxOutRef, TxOut)]
balancingUtxos Integer
fee Maybe (Collaterals, Wallet)
mCollaterals TxSkel
skel)
        ((MockChainError
  -> m (Maybe (Maybe (Collaterals, Wallet), TxSkel)))
 -> m (Maybe (Maybe (Collaterals, Wallet), TxSkel)))
-> (MockChainError
    -> m (Maybe (Maybe (Collaterals, Wallet), TxSkel)))
-> m (Maybe (Maybe (Collaterals, Wallet), TxSkel))
forall a b. (a -> b) -> a -> b
$ \case
          -- If it fails, and the remaining fee interval is not reduced to the
          -- current fee attempt, we return `Nothing` which signifies that we
          -- need to keep searching. Otherwise, the whole balancing process
          -- fails and we spread the error.
          MCEUnbalanceable {} | Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
minFee Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 -> Maybe (Maybe (Collaterals, Wallet), TxSkel)
-> m (Maybe (Maybe (Collaterals, Wallet), TxSkel))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe (Collaterals, Wallet), TxSkel)
forall a. Maybe a
Nothing
          MCENoSuitableCollateral {} | Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
minFee Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 -> Maybe (Maybe (Collaterals, Wallet), TxSkel)
-> m (Maybe (Maybe (Collaterals, Wallet), TxSkel))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe (Collaterals, Wallet), TxSkel)
forall a. Maybe a
Nothing
          MockChainError
err -> MockChainError -> m (Maybe (Maybe (Collaterals, Wallet), TxSkel))
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MockChainError
err

      (Integer
newMinFee, Integer
newMaxFee) <- case Maybe (Maybe (Collaterals, Wallet), TxSkel)
attemptedBalancing of
        -- The skeleton was not balanceable, we try strictly smaller fee
        Maybe (Maybe (Collaterals, Wallet), TxSkel)
Nothing -> (Integer, Integer) -> m (Integer, Integer)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
minFee, Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
        -- The skeleton was balanceable, we compute and analyse the resulting
        -- fee to seach upwards or downwards for an optimal solution
        Just (Maybe (Collaterals, Wallet)
adjustedColsAndWallet, TxSkel
attemptedSkel) -> do
          Integer
newFee <- TxSkel -> Integer -> Maybe (Collaterals, Wallet) -> m Integer
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> Integer -> Maybe (Collaterals, Wallet) -> m Integer
estimateTxSkelFee TxSkel
attemptedSkel Integer
fee Maybe (Collaterals, Wallet)
adjustedColsAndWallet
          (Integer, Integer) -> m (Integer, Integer)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, Integer) -> m (Integer, Integer))
-> (Integer, Integer) -> m (Integer, Integer)
forall a b. (a -> b) -> a -> b
$ case Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
newFee of
            -- Current fee is insufficient, we look on the right (strictly)
            Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 -> (Integer
fee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1, Integer
maxFee)
            -- Current fee is sufficient, but the set of balancing utxos cannot
            -- necessarily account for less fee, since it was (magically)
            -- exactly enough to compensate for the missing value. Reducing the
            -- fee would ruin this perfect balancing and force an output to be
            -- created at the balancing wallet address, thus we cannot assume
            -- the actual estimated fee can be accounted for with the current
            -- set of balancing utxos and we cannot speed up search.
            Integer
_ | TxSkel -> Value
txSkelValueInOutputs TxSkel
attemptedSkel Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== TxSkel -> Value
txSkelValueInOutputs TxSkel
skel -> (Integer
minFee, Integer
fee)
            -- Current fee is sufficient, and the set of utxo could account for
            -- less fee by feeding into whatever output already goes back to the
            -- balancing wallet. We can speed up search, because the current
            -- attempted skeleton could necessarily account for the estimated
            -- fee of the input skeleton.
            Integer
_ -> (Integer
minFee, Integer
newFee)

      Wallet
-> Integer
-> Integer
-> [(TxOutRef, TxOut)]
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet
-> Integer
-> Integer
-> [(TxOutRef, TxOut)]
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (TxSkel, Integer, Maybe (Collaterals, Wallet))
computeFeeAndBalance Wallet
balancingWallet Integer
newMinFee Integer
newMaxFee [(TxOutRef, TxOut)]
balancingUtxos Maybe (Collaterals, Wallet)
mCollaterals TxSkel
skel

-- | Helper function to group the two real steps of the balancing: balance a
-- skeleton around a given fee, and compute the associated collateral inputs
attemptBalancingAndCollaterals :: (MonadBlockChainBalancing m) => Wallet -> BalancingOutputs -> Fee -> Maybe (Collaterals, Wallet) -> TxSkel -> m (Maybe (Collaterals, Wallet), TxSkel)
attemptBalancingAndCollaterals :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet
-> [(TxOutRef, TxOut)]
-> Integer
-> Maybe (Collaterals, Wallet)
-> TxSkel
-> m (Maybe (Collaterals, Wallet), TxSkel)
attemptBalancingAndCollaterals Wallet
balancingWallet [(TxOutRef, TxOut)]
balancingUtxos Integer
fee Maybe (Collaterals, Wallet)
mCollaterals TxSkel
skel = do
  Maybe (Collaterals, Wallet)
adjustedCollateralIns <- Integer
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Integer
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
collateralsFromFees Integer
fee Maybe (Collaterals, Wallet)
mCollaterals
  TxSkel
attemptedSkel <- Wallet -> [(TxOutRef, TxOut)] -> TxSkel -> Integer -> m TxSkel
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet -> [(TxOutRef, TxOut)] -> TxSkel -> Integer -> m TxSkel
computeBalancedTxSkel Wallet
balancingWallet [(TxOutRef, TxOut)]
balancingUtxos TxSkel
skel Integer
fee
  (Maybe (Collaterals, Wallet), TxSkel)
-> m (Maybe (Collaterals, Wallet), TxSkel)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Collaterals, Wallet)
adjustedCollateralIns, TxSkel
attemptedSkel)

-- | This selects a subset of suitable collateral inputs from a given set while
-- accounting for the ratio to respect between fees and total collaterals, the
-- min ada requirements in the associated return collateral and the maximum
-- number of collateral inputs authorized by protocol parameters.
collateralInsFromFees :: (MonadBlockChainBalancing m) => Fee -> Collaterals -> Wallet -> m Collaterals
collateralInsFromFees :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Integer -> Collaterals -> Wallet -> m Collaterals
collateralInsFromFees Integer
fee Collaterals
collateralIns Wallet
returnCollateralWallet = do
  -- We retrieve the max number of collateral inputs, with a default of 10. In
  -- practice this will be around 3.
  Integer
nbMax <- Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Natural -> Integer) -> (Params -> Natural) -> Params -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
10 (Maybe Natural -> Natural)
-> (Params -> Maybe Natural) -> Params -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolParameters -> Maybe Natural
Cardano.protocolParamMaxCollateralInputs (ProtocolParameters -> Maybe Natural)
-> (Params -> ProtocolParameters) -> Params -> Maybe Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> ProtocolParameters
Emulator.pProtocolParams (Params -> Integer) -> m Params -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  -- We retrieve the percentage to respect between fees and total collaterals
  Integer
percentage <- Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Natural -> Integer) -> (Params -> Natural) -> Params -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe Natural
100 (Maybe Natural -> Natural)
-> (Params -> Maybe Natural) -> Params -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolParameters -> Maybe Natural
Cardano.protocolParamCollateralPercent (ProtocolParameters -> Maybe Natural)
-> (Params -> ProtocolParameters) -> Params -> Maybe Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> ProtocolParameters
Emulator.pProtocolParams (Params -> Integer) -> m Params -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  -- We compute the total collateral to be associated to the transaction as a
  -- value. This will be the target value to be reached by collateral inputs. We
  -- add one because of ledger requirement which seem to round up this value.
  let totalCollateral :: Value
totalCollateral = Coin -> Value
forall a. ToValue a => a -> Value
toValue (Coin -> Value) -> (Integer -> Coin) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Cardano.Coin (Integer -> Coin) -> (Integer -> Integer) -> Integer -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
100) (Integer -> Integer) -> (Integer -> Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
percentage) (Integer -> Value) -> Integer -> Value
forall a b. (a -> b) -> a -> b
$ Integer
fee
  -- Collateral tx outputs sorted by decreasing ada amount
  [(TxOutRef, TxOut)]
collateralTxOuts <- UtxoSearch m TxOut -> m [(TxOutRef, TxOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch ([TxOutRef] -> UtxoSearch m TxOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[TxOutRef] -> UtxoSearch m TxOut
txOutByRefSearch ([TxOutRef] -> UtxoSearch m TxOut)
-> [TxOutRef] -> UtxoSearch m TxOut
forall a b. (a -> b) -> a -> b
$ Collaterals -> [TxOutRef]
forall a. Set a -> [a]
Set.toList Collaterals
collateralIns)
  -- Candidate subsets of utxos to be used as collaterals
  let candidatesRaw :: [([(TxOutRef, TxOut)], Value)]
candidatesRaw = [(TxOutRef, TxOut)]
-> Value -> Integer -> [([(TxOutRef, TxOut)], Value)]
reachValue [(TxOutRef, TxOut)]
collateralTxOuts Value
totalCollateral Integer
nbMax
  -- Preparing a possible collateral error
  let noSuitableCollateralError :: MockChainError
noSuitableCollateralError = Integer -> Integer -> Value -> MockChainError
MCENoSuitableCollateral Integer
fee Integer
percentage Value
totalCollateral
  -- Retrieving and returning the best candidate as a utxo set
  [TxOutRef] -> Collaterals
forall a. Ord a => [a] -> Set a
Set.fromList ([TxOutRef] -> Collaterals)
-> (([TxOutRef], Value) -> [TxOutRef])
-> ([TxOutRef], Value)
-> Collaterals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxOutRef], Value) -> [TxOutRef]
forall a b. (a, b) -> a
fst (([TxOutRef], Value) -> Collaterals)
-> m ([TxOutRef], Value) -> m Collaterals
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([(TxOutRef, TxOut)], Value)]
-> Wallet -> MockChainError -> m ([TxOutRef], Value)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxOut)], Value)]
-> Wallet -> MockChainError -> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxOut)], Value)]
candidatesRaw Wallet
returnCollateralWallet MockChainError
noSuitableCollateralError

-- | This adjusts collateral inputs when necessary
collateralsFromFees :: (MonadBlockChainBalancing m) => Fee -> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
collateralsFromFees :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Integer
-> Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
collateralsFromFees Integer
_ Maybe (Collaterals, Wallet)
Nothing = Maybe (Collaterals, Wallet) -> m (Maybe (Collaterals, Wallet))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Collaterals, Wallet)
forall a. Maybe a
Nothing
collateralsFromFees Integer
fee (Just (Collaterals
collateralIns, Wallet
returnCollateralWallet)) =
  (Collaterals, Wallet) -> Maybe (Collaterals, Wallet)
forall a. a -> Maybe a
Just ((Collaterals, Wallet) -> Maybe (Collaterals, Wallet))
-> (Collaterals -> (Collaterals, Wallet))
-> Collaterals
-> Maybe (Collaterals, Wallet)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Wallet
returnCollateralWallet) (Collaterals -> Maybe (Collaterals, Wallet))
-> m Collaterals -> m (Maybe (Collaterals, Wallet))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Collaterals -> Wallet -> m Collaterals
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Integer -> Collaterals -> Wallet -> m Collaterals
collateralInsFromFees Integer
fee Collaterals
collateralIns Wallet
returnCollateralWallet

-- | The main computing function for optimal balancing and collaterals. It
-- computes the subsets of a set of UTxOs that sum up to a certain target. It
-- stops when the target is reached, not adding superfluous UTxOs. Despite
-- optimizations, this function is theoretically in 2^n where n is the number of
-- candidate UTxOs. Use with caution.
reachValue :: BalancingOutputs -> Api.Value -> Integer -> [(BalancingOutputs, Api.Value)]
-- Target is smaller than the empty value (which means in only contains negative
-- entries), we stop looking as adding more elements would be superfluous.
reachValue :: [(TxOutRef, TxOut)]
-> Value -> Integer -> [([(TxOutRef, TxOut)], Value)]
reachValue [(TxOutRef, TxOut)]
_ Value
target Integer
_ | Value
target Value -> Value -> Bool
`Api.leq` Value
forall a. Monoid a => a
mempty = [([], Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
target)]
-- The target is not reached, but the max number of elements is reached, we
-- would need more elements but are not allowed to look for them.
reachValue [(TxOutRef, TxOut)]
_ Value
_ Integer
maxEls | Integer
maxEls Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = []
-- The target is not reached, and cannot possibly be reached, as the remaining
-- candidates do not sum up to the target.
reachValue [(TxOutRef, TxOut)]
l Value
target Integer
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value
target Value -> Value -> Bool
`Api.leq` [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat (TxOut -> Value
Api.txOutValue (TxOut -> Value)
-> ((TxOutRef, TxOut) -> TxOut) -> (TxOutRef, TxOut) -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxOut) -> TxOut
forall a b. (a, b) -> b
snd ((TxOutRef, TxOut) -> Value) -> [(TxOutRef, TxOut)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxOut)]
l) = []
-- There is no more elements to go through and the target has not been
-- reached. Encompassed by the previous case, but needed by GHC.
reachValue [] Value
_ Integer
_ = []
-- Main recursive case, where we either pick or drop the head. We only pick the
-- head if it contributes to reaching the target, i.e. if its intersection with
-- the positive part of the target is not empty.
reachValue (h :: (TxOutRef, TxOut)
h@(TxOutRef
_, TxOut -> Value
Api.txOutValue -> Value
hVal) : [(TxOutRef, TxOut)]
t) Value
target Integer
maxEls =
  [([(TxOutRef, TxOut)], Value)]
-> [([(TxOutRef, TxOut)], Value)] -> [([(TxOutRef, TxOut)], Value)]
forall a. [a] -> [a] -> [a]
(++) ([(TxOutRef, TxOut)]
-> Value -> Integer -> [([(TxOutRef, TxOut)], Value)]
reachValue [(TxOutRef, TxOut)]
t Value
target Integer
maxEls) ([([(TxOutRef, TxOut)], Value)] -> [([(TxOutRef, TxOut)], Value)])
-> [([(TxOutRef, TxOut)], Value)] -> [([(TxOutRef, TxOut)], Value)]
forall a b. (a -> b) -> a -> b
$
    if (Value, Value) -> Value
forall a b. (a, b) -> b
snd (Value -> (Value, Value)
Api.split Value
target) Value -> Value -> Value
forall a. MeetSemiLattice a => a -> a -> a
PlutusTx./\ Value
hVal Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty
      then []
      else ([(TxOutRef, TxOut)] -> [(TxOutRef, TxOut)])
-> ([(TxOutRef, TxOut)], Value) -> ([(TxOutRef, TxOut)], Value)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((TxOutRef, TxOut)
h (TxOutRef, TxOut) -> [(TxOutRef, TxOut)] -> [(TxOutRef, TxOut)]
forall a. a -> [a] -> [a]
:) (([(TxOutRef, TxOut)], Value) -> ([(TxOutRef, TxOut)], Value))
-> [([(TxOutRef, TxOut)], Value)] -> [([(TxOutRef, TxOut)], Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxOut)]
-> Value -> Integer -> [([(TxOutRef, TxOut)], Value)]
reachValue [(TxOutRef, TxOut)]
t (Value
target Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
hVal) (Integer
maxEls Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)

-- | A helper function to grab an optimal candidate in terms of having a minimal
-- enough amount of ada to sustain itself meant to be used after calling
-- `reachValue`. This throws an error when there are no suitable candidates.
getOptimalCandidate :: (MonadBlockChainBalancing m) => [(BalancingOutputs, Api.Value)] -> Wallet -> MockChainError -> m ([Api.TxOutRef], Api.Value)
getOptimalCandidate :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxOut)], Value)]
-> Wallet -> MockChainError -> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxOut)], Value)]
candidates Wallet
paymentTarget MockChainError
mceError = do
  -- We decorate the candidates with their current ada and min ada requirements
  [([(TxOutRef, TxOut)], Value, Ada, Integer)]
candidatesDecorated <- [([(TxOutRef, TxOut)], Value)]
-> (([(TxOutRef, TxOut)], Value)
    -> m ([(TxOutRef, TxOut)], Value, Ada, Integer))
-> m [([(TxOutRef, TxOut)], Value, Ada, Integer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([(TxOutRef, TxOut)], Value)]
candidates ((([(TxOutRef, TxOut)], Value)
  -> m ([(TxOutRef, TxOut)], Value, Ada, Integer))
 -> m [([(TxOutRef, TxOut)], Value, Ada, Integer)])
-> (([(TxOutRef, TxOut)], Value)
    -> m ([(TxOutRef, TxOut)], Value, Ada, Integer))
-> m [([(TxOutRef, TxOut)], Value, Ada, Integer)]
forall a b. (a -> b) -> a -> b
$ \([(TxOutRef, TxOut)]
output, Value
val) ->
    ([(TxOutRef, TxOut)]
output,Value
val,Value -> Ada
Script.fromValue Value
val,) (Integer -> ([(TxOutRef, TxOut)], Value, Ada, Integer))
-> m Integer -> m ([(TxOutRef, TxOut)], Value, Ada, Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkelOut -> m Integer
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m Integer
getTxSkelOutMinAda (Wallet
paymentTarget Wallet -> Payable '["Value"] -> TxSkelOut
forall owner (els :: [Symbol]).
(Show owner, Typeable owner, IsTxSkelOutAllowedOwner owner,
 ToCredential owner) =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '["Value"]
forall a1. ToValue a1 => a1 -> Payable '["Value"]
Value Value
val)
  -- We filter the candidates that have enough ada to sustain themselves
  let candidatesFiltered :: [(Integer, ([TxOutRef], Value))]
candidatesFiltered = [(Integer
minLv, ((TxOutRef, TxOut) -> TxOutRef
forall a b. (a, b) -> a
fst ((TxOutRef, TxOut) -> TxOutRef)
-> [(TxOutRef, TxOut)] -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxOut)]
l, Value
val)) | ([(TxOutRef, TxOut)]
l, Value
val, Script.Lovelace Integer
lv, Integer
minLv) <- [([(TxOutRef, TxOut)], Value, Ada, Integer)]
candidatesDecorated, Integer
minLv Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
lv]
  case ((Integer, ([TxOutRef], Value))
 -> (Integer, ([TxOutRef], Value)) -> Ordering)
-> [(Integer, ([TxOutRef], Value))]
-> [(Integer, ([TxOutRef], Value))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Integer -> Integer -> Ordering)
-> ((Integer, ([TxOutRef], Value)) -> Integer)
-> (Integer, ([TxOutRef], Value))
-> (Integer, ([TxOutRef], Value))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Integer, ([TxOutRef], Value)) -> Integer
forall a b. (a, b) -> a
fst) [(Integer, ([TxOutRef], Value))]
candidatesFiltered of
    -- If the list of candidates is empty, we throw an error
    [] -> MockChainError -> m ([TxOutRef], Value)
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MockChainError
mceError
    (Integer
_, ([TxOutRef], Value)
ret) : [(Integer, ([TxOutRef], Value))]
_ -> ([TxOutRef], Value) -> m ([TxOutRef], Value)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxOutRef], Value)
ret

-- | This function is essentially a copy of
-- https://github.com/input-output-hk/plutus-apps/blob/d4255f05477fd8477ee9673e850ebb9ebb8c9657/plutus-ledger/src/Ledger/Fee.hs#L19
estimateTxSkelFee :: (MonadBlockChainBalancing m) => TxSkel -> Fee -> Maybe (Collaterals, Wallet) -> m Fee
estimateTxSkelFee :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> Integer -> Maybe (Collaterals, Wallet) -> m Integer
estimateTxSkelFee TxSkel
skel Integer
fee Maybe (Collaterals, Wallet)
mCollaterals = do
  -- We retrieve the necessary data to generate the transaction body
  Params
params <- m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  let collateralIns :: [TxOutRef]
collateralIns = case Maybe (Collaterals, Wallet)
mCollaterals of
        Maybe (Collaterals, Wallet)
Nothing -> []
        Just (Collaterals
s, Wallet
_) -> Collaterals -> [TxOutRef]
forall a. Set a -> [a]
Set.toList Collaterals
s
  -- We generate the transaction body content, handling errors in the meantime
  TxBodyContent BuildTx ConwayEra
txBodyContent <- TxSkel
-> Integer
-> Maybe (Collaterals, Wallet)
-> m (TxBodyContent BuildTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel
-> Integer
-> Maybe (Collaterals, Wallet)
-> m (TxBodyContent BuildTx ConwayEra)
txSkelToTxBodyContent TxSkel
skel Integer
fee Maybe (Collaterals, Wallet)
mCollaterals
  -- We create the actual body and send if for validation
  TxBody ConwayEra
txBody <- TxBodyContent BuildTx ConwayEra -> TxSkel -> m (TxBody ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxBodyContent BuildTx ConwayEra -> TxSkel -> m (TxBody ConwayEra)
txBodyContentToTxBody TxBodyContent BuildTx ConwayEra
txBodyContent TxSkel
skel
  -- We retrieve the estimate number of required witness in the transaction
  let nkeys :: Word
nkeys = TxBodyContent BuildTx ConwayEra -> Word
forall era. TxBodyContent BuildTx era -> Word
Cardano.estimateTransactionKeyWitnessCount TxBodyContent BuildTx ConwayEra
txBodyContent
  -- We need to reconstruct an index to pass to the fee estimate function
  -- We begin by retrieving the relevant utxos used in the skeleton
  ([TxOutRef]
knownTxORefs, [TxOut]
knownTxOuts) <- [(TxOutRef, TxOut)] -> ([TxOutRef], [TxOut])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(TxOutRef, TxOut)] -> ([TxOutRef], [TxOut]))
-> (Map TxOutRef TxOut -> [(TxOutRef, TxOut)])
-> Map TxOutRef TxOut
-> ([TxOutRef], [TxOut])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxOutRef TxOut -> [(TxOutRef, TxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxOutRef TxOut -> ([TxOutRef], [TxOut]))
-> m (Map TxOutRef TxOut) -> m ([TxOutRef], [TxOut])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOutRef] -> m (Map TxOutRef TxOut)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[TxOutRef] -> m (Map TxOutRef TxOut)
lookupUtxos (TxSkel -> [TxOutRef]
txSkelKnownTxOutRefs TxSkel
skel [TxOutRef] -> [TxOutRef] -> [TxOutRef]
forall a. Semigroup a => a -> a -> a
<> [TxOutRef]
collateralIns)
  -- We then compute their Cardano counterparts
  let indexOrError :: Either ToCardanoError (UTxO ConwayEra)
indexOrError = do
        [TxIn]
txInL <- [TxOutRef]
-> (TxOutRef -> Either ToCardanoError TxIn)
-> Either ToCardanoError [TxIn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TxOutRef]
knownTxORefs TxOutRef -> Either ToCardanoError TxIn
Ledger.toCardanoTxIn
        [TxOut CtxTx ConwayEra]
txOutL <- [TxOut]
-> (TxOut -> Either ToCardanoError (TxOut CtxTx ConwayEra))
-> Either ToCardanoError [TxOut CtxTx ConwayEra]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TxOut]
knownTxOuts ((TxOut -> Either ToCardanoError (TxOut CtxTx ConwayEra))
 -> Either ToCardanoError [TxOut CtxTx ConwayEra])
-> (TxOut -> Either ToCardanoError (TxOut CtxTx ConwayEra))
-> Either ToCardanoError [TxOut CtxTx ConwayEra]
forall a b. (a -> b) -> a -> b
$ NetworkId -> TxOut -> Either ToCardanoError (TxOut CtxTx ConwayEra)
Ledger.toCardanoTxOut (NetworkId
 -> TxOut -> Either ToCardanoError (TxOut CtxTx ConwayEra))
-> NetworkId
-> TxOut
-> Either ToCardanoError (TxOut CtxTx ConwayEra)
forall a b. (a -> b) -> a -> b
$ Params -> NetworkId
Emulator.pNetworkId Params
params
        UTxO ConwayEra -> Either ToCardanoError (UTxO ConwayEra)
forall a. a -> Either ToCardanoError a
forall (m :: * -> *) a. Monad m => a -> m a
return (UTxO ConwayEra -> Either ToCardanoError (UTxO ConwayEra))
-> UTxO ConwayEra -> Either ToCardanoError (UTxO ConwayEra)
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO ConwayEra) -> UTxO ConwayEra
forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
Cardano.UTxO (Map TxIn (TxOut CtxUTxO ConwayEra) -> UTxO ConwayEra)
-> Map TxIn (TxOut CtxUTxO ConwayEra) -> UTxO ConwayEra
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO ConwayEra)]
-> Map TxIn (TxOut CtxUTxO ConwayEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TxIn, TxOut CtxUTxO ConwayEra)]
 -> Map TxIn (TxOut CtxUTxO ConwayEra))
-> [(TxIn, TxOut CtxUTxO ConwayEra)]
-> Map TxIn (TxOut CtxUTxO ConwayEra)
forall a b. (a -> b) -> a -> b
$ [TxIn]
-> [TxOut CtxUTxO ConwayEra] -> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn]
txInL ([TxOut CtxUTxO ConwayEra] -> [(TxIn, TxOut CtxUTxO ConwayEra)])
-> [TxOut CtxUTxO ConwayEra] -> [(TxIn, TxOut CtxUTxO ConwayEra)]
forall a b. (a -> b) -> a -> b
$ TxOut CtxTx ConwayEra -> TxOut CtxUTxO ConwayEra
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
Cardano.toCtxUTxOTxOut (TxOut CtxTx ConwayEra -> TxOut CtxUTxO ConwayEra)
-> [TxOut CtxTx ConwayEra] -> [TxOut CtxUTxO ConwayEra]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOut CtxTx ConwayEra]
txOutL
  -- We retrieve the index when it was successfully created
  UTxO ConwayEra
index <- case Either ToCardanoError (UTxO ConwayEra)
indexOrError of
    Left ToCardanoError
err -> MockChainError -> m (UTxO ConwayEra)
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m (UTxO ConwayEra))
-> MockChainError -> m (UTxO ConwayEra)
forall a b. (a -> b) -> a -> b
$ GenerateTxError -> MockChainError
MCEGenerationError (GenerateTxError -> MockChainError)
-> GenerateTxError -> MockChainError
forall a b. (a -> b) -> a -> b
$ String -> ToCardanoError -> GenerateTxError
ToCardanoError String
"estimateTxSkelFee: toCardanoError" ToCardanoError
err
    Right UTxO ConwayEra
index' -> UTxO ConwayEra -> m (UTxO ConwayEra)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return UTxO ConwayEra
index'
  -- We finally can the fee estimate function
  Integer -> m Integer
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> m Integer) -> (Coin -> Integer) -> Coin -> m Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Integer
Emulator.unCoin (Coin -> m Integer) -> Coin -> m Integer
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra ConwayEra
-> PParams (ShelleyLedgerEra ConwayEra)
-> UTxO ConwayEra
-> TxBody ConwayEra
-> Word
-> Coin
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era)
-> UTxO era
-> TxBody era
-> Word
-> Coin
Cardano.calculateMinTxFee ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway (Params -> PParams
Emulator.pEmulatorPParams Params
params) UTxO ConwayEra
index TxBody ConwayEra
txBody Word
nkeys

-- | 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 + withdrawn value = output value + burned value + fee + deposits
computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Wallet -> BalancingOutputs -> TxSkel -> Fee -> m TxSkel
computeBalancedTxSkel :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Wallet -> [(TxOutRef, TxOut)] -> TxSkel -> Integer -> m TxSkel
computeBalancedTxSkel Wallet
balancingWallet [(TxOutRef, TxOut)]
balancingUtxos txSkel :: TxSkel
txSkel@TxSkel {[Wallet]
[TxSkelProposal]
[TxSkelOut]
Collaterals
Set TxLabel
TxSkelWithdrawals
Map TxOutRef TxSkelRedeemer
TxSkelMints
SlotRange
TxOpts
txSkelLabel :: TxSkel -> Set TxLabel
txSkelOpts :: TxSkel -> TxOpts
txSkelMints :: TxSkel -> TxSkelMints
txSkelSigners :: TxSkel -> [Wallet]
txSkelValidityRange :: TxSkel -> SlotRange
txSkelIns :: TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelInsReference :: TxSkel -> Collaterals
txSkelOuts :: TxSkel -> [TxSkelOut]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelWithdrawals :: TxSkel -> TxSkelWithdrawals
txSkelLabel :: Set TxLabel
txSkelOpts :: TxOpts
txSkelMints :: TxSkelMints
txSkelSigners :: [Wallet]
txSkelValidityRange :: SlotRange
txSkelIns :: Map TxOutRef TxSkelRedeemer
txSkelInsReference :: Collaterals
txSkelOuts :: [TxSkelOut]
txSkelProposals :: [TxSkelProposal]
txSkelWithdrawals :: TxSkelWithdrawals
..} (Integer -> Value
Script.lovelace -> Value
feeValue) = do
  -- We compute the necessary values from the skeleton that are part of the
  -- equation, except for the `feeValue` which we already have.
  let (Value
burnedValue, Value
mintedValue) = Value -> (Value, Value)
Api.split (Value -> (Value, Value)) -> Value -> (Value, Value)
forall a b. (a -> b) -> a -> b
$ TxSkelMints -> Value
txSkelMintsValue TxSkelMints
txSkelMints
      outValue :: Value
outValue = TxSkel -> Value
txSkelValueInOutputs TxSkel
txSkel
      withdrawnValue :: Value
withdrawnValue = TxSkel -> Value
txSkelWithdrawnValue TxSkel
txSkel
  Value
inValue <- TxSkel -> m Value
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m Value
txSkelInputValue TxSkel
txSkel
  Value
depositedValue <- Lovelace -> Value
forall a. ToValue a => a -> Value
toValue (Lovelace -> Value) -> m Lovelace -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkel -> m Lovelace
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m Lovelace
txSkelProposalsDeposit TxSkel
txSkel
  -- We compute the values missing in the left and right side of the equation
  let (Value
missingRight, Value
missingLeft) = Value -> (Value, Value)
Api.split (Value -> (Value, Value)) -> Value -> (Value, Value)
forall a b. (a -> b) -> a -> b
$ Value
outValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
burnedValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
feeValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
depositedValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate (Value
inValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
mintedValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
withdrawnValue)
  -- We compute the minimal ada requirement of the missing payment
  Integer
rightMinAda <- TxSkelOut -> m Integer
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m Integer
getTxSkelOutMinAda (TxSkelOut -> m Integer) -> TxSkelOut -> m Integer
forall a b. (a -> b) -> a -> b
$ Wallet
balancingWallet Wallet -> Payable '["Value"] -> TxSkelOut
forall owner (els :: [Symbol]).
(Show owner, Typeable owner, IsTxSkelOutAllowedOwner owner,
 ToCredential owner) =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '["Value"]
forall a1. ToValue a1 => a1 -> Payable '["Value"]
Value Value
missingRight
  -- We compute the current ada of the missing payment. If the missing payment
  -- is not empty and the minimal ada is not present, some value is missing.
  let Script.Lovelace Integer
rightAda = Value
missingRight Value -> Optic' A_Lens NoIx Value Ada -> Ada
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Value Ada
Script.adaL
      missingAda :: Integer
missingAda = Integer
rightMinAda Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
rightAda
      missingAdaValue :: Value
missingAdaValue = if Value
missingRight Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& Integer
missingAda Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 then Integer -> Value
Script.lovelace Integer
missingAda else Value
forall a. Monoid a => a
mempty
  -- The actual missing value on the left might needs to account for any missing
  -- min ada on the missing payment of the transaction skeleton. This also has
  -- to be repercuted on the missing value on the right.
  let missingLeft' :: Value
missingLeft' = Value
missingLeft Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingAdaValue
      missingRight' :: Value
missingRight' = Value
missingRight Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingAdaValue
  -- This gives us what we need to run our `reachValue` algorithm and append to
  -- the resulting values whatever payment was missing in the initial skeleton
  let candidatesRaw :: [([(TxOutRef, TxOut)], Value)]
candidatesRaw = (Value -> Value)
-> ([(TxOutRef, TxOut)], Value) -> ([(TxOutRef, TxOut)], Value)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingRight') (([(TxOutRef, TxOut)], Value) -> ([(TxOutRef, TxOut)], Value))
-> [([(TxOutRef, TxOut)], Value)] -> [([(TxOutRef, TxOut)], Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxOut)]
-> Value -> Integer -> [([(TxOutRef, TxOut)], Value)]
reachValue [(TxOutRef, TxOut)]
balancingUtxos Value
missingLeft' (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [(TxOutRef, TxOut)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxOutRef, TxOut)]
balancingUtxos)
  -- We prepare a possible balancing error with the difference between the
  -- requested amount and the maximum amount provided by the balancing wallet
  let totalValue :: Value
totalValue = [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ TxOut -> Value
Api.txOutValue (TxOut -> Value)
-> ((TxOutRef, TxOut) -> TxOut) -> (TxOutRef, TxOut) -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxOut) -> TxOut
forall a b. (a, b) -> b
snd ((TxOutRef, TxOut) -> Value) -> [(TxOutRef, TxOut)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxOut)]
balancingUtxos
      difference :: Value
difference = (Value, Value) -> Value
forall a b. (a, b) -> b
snd ((Value, Value) -> Value) -> (Value, Value) -> Value
forall a b. (a -> b) -> a -> b
$ Value -> (Value, Value)
Api.split (Value -> (Value, Value)) -> Value -> (Value, Value)
forall a b. (a -> b) -> a -> b
$ Value
missingLeft' Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
totalValue
      balancingError :: MockChainError
balancingError = Wallet -> Value -> TxSkel -> MockChainError
MCEUnbalanceable Wallet
balancingWallet Value
difference TxSkel
txSkel
  -- Which one of our candidates should be picked depends on three factors
  -- - Whether there exists a perfect candidate set with empty surplus value
  -- - The `BalancingOutputPolicy` in the skeleton options
  -- - The presence of an existing output at the balancing wallet address
  ([TxOutRef]
additionalInsTxOutRefs, [TxSkelOut]
newTxSkelOuts) <- case (([(TxOutRef, TxOut)], Value) -> Bool)
-> [([(TxOutRef, TxOut)], Value)]
-> Maybe ([(TxOutRef, TxOut)], Value)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty) (Value -> Bool)
-> (([(TxOutRef, TxOut)], Value) -> Value)
-> ([(TxOutRef, TxOut)], Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(TxOutRef, TxOut)], Value) -> Value
forall a b. (a, b) -> b
snd) [([(TxOutRef, TxOut)], Value)]
candidatesRaw of
    -- There exists a perfect candidate, this is the rarest and easiest
    -- scenario, as the outputs will not change due to balancing. This means
    -- that there was no missing value on the right and the balancing utxos
    -- exactly account for what was missing on the left.
    Just ([(TxOutRef, TxOut)]
txOutRefs, Value
_) -> ([TxOutRef], [TxSkelOut]) -> m ([TxOutRef], [TxSkelOut])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TxOutRef, TxOut) -> TxOutRef
forall a b. (a, b) -> a
fst ((TxOutRef, TxOut) -> TxOutRef)
-> [(TxOutRef, TxOut)] -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxOut)]
txOutRefs, [TxSkelOut]
txSkelOuts)
    -- There in an existing output at the owner's address and the balancing
    -- policy allows us to adjust it with additional value.
    Maybe ([(TxOutRef, TxOut)], Value)
Nothing
      | ([TxSkelOut]
before, TxSkelOut
txSkelOut : [TxSkelOut]
after) <- (TxSkelOut -> Bool) -> [TxSkelOut] -> ([TxSkelOut], [TxSkelOut])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\(Pays o
o) -> OwnerType o -> Credential
forall a. ToCredential a => a -> Credential
toCredential (o
o o -> Optic' A_Lens NoIx o (OwnerType o) -> OwnerType o
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx o (OwnerType o)
forall o. IsAbstractOutput o => Lens' o (OwnerType o)
outputOwnerL) Credential -> Credential -> Bool
forall a. Eq a => a -> a -> Bool
== Wallet -> Credential
forall a. ToCredential a => a -> Credential
toCredential Wallet
balancingWallet) [TxSkelOut]
txSkelOuts,
        BalanceOutputPolicy
AdjustExistingOutput <- TxOpts -> BalanceOutputPolicy
txOptBalanceOutputPolicy TxOpts
txSkelOpts -> do
          -- We get the optimal candidate based on an updated value. We update
          -- the `txSkelOuts` by replacing the value content of the selected
          -- output. We keep intact the orders of those outputs.
          let candidatesRaw' :: [([(TxOutRef, TxOut)], Value)]
candidatesRaw' = (Value -> Value)
-> ([(TxOutRef, TxOut)], Value) -> ([(TxOutRef, TxOut)], Value)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> TxSkelOut
txSkelOut TxSkelOut -> Optic' A_Lens NoIx TxSkelOut Value -> Value
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. (Lens' TxSkelOut TxSkelOutValue
txSkelOutValueL Lens' TxSkelOut TxSkelOutValue
-> Optic A_Lens NoIx TxSkelOutValue TxSkelOutValue Value Value
-> Optic' A_Lens NoIx TxSkelOut Value
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx TxSkelOutValue TxSkelOutValue Value Value
txSkelOutValueContentL)) (([(TxOutRef, TxOut)], Value) -> ([(TxOutRef, TxOut)], Value))
-> [([(TxOutRef, TxOut)], Value)] -> [([(TxOutRef, TxOut)], Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([(TxOutRef, TxOut)], Value)]
candidatesRaw
          ([TxOutRef]
txOutRefs, Value
val) <- [([(TxOutRef, TxOut)], Value)]
-> Wallet -> MockChainError -> m ([TxOutRef], Value)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxOut)], Value)]
-> Wallet -> MockChainError -> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxOut)], Value)]
candidatesRaw' Wallet
balancingWallet MockChainError
balancingError
          ([TxOutRef], [TxSkelOut]) -> m ([TxOutRef], [TxSkelOut])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxOutRef]
txOutRefs, [TxSkelOut]
before [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ (TxSkelOut
txSkelOut TxSkelOut -> (TxSkelOut -> TxSkelOut) -> TxSkelOut
forall a b. a -> (a -> b) -> b
& (Lens' TxSkelOut TxSkelOutValue
txSkelOutValueL Lens' TxSkelOut TxSkelOutValue
-> Optic A_Lens NoIx TxSkelOutValue TxSkelOutValue Value Value
-> Optic' A_Lens NoIx TxSkelOut Value
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx TxSkelOutValue TxSkelOutValue Value Value
txSkelOutValueContentL) Optic' A_Lens NoIx TxSkelOut Value
-> Value -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Value
val) TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall a. a -> [a] -> [a]
: [TxSkelOut]
after)
    -- There is no output at the balancing wallet address, or the balancing
    -- policy forces us to create a new output, both yielding the same result.
    Maybe ([(TxOutRef, TxOut)], Value)
_ -> do
      -- We get the optimal candidate, and update the `txSkelOuts` by appending
      -- a new output at the end of the list, to keep the order intact.
      ([TxOutRef]
txOutRefs, Value
val) <- [([(TxOutRef, TxOut)], Value)]
-> Wallet -> MockChainError -> m ([TxOutRef], Value)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxOut)], Value)]
-> Wallet -> MockChainError -> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxOut)], Value)]
candidatesRaw Wallet
balancingWallet MockChainError
balancingError
      ([TxOutRef], [TxSkelOut]) -> m ([TxOutRef], [TxSkelOut])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxOutRef]
txOutRefs, [TxSkelOut]
txSkelOuts [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ [Wallet
balancingWallet Wallet -> Payable '["Value"] -> TxSkelOut
forall owner (els :: [Symbol]).
(Show owner, Typeable owner, IsTxSkelOutAllowedOwner owner,
 ToCredential owner) =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '["Value"]
forall a1. ToValue a1 => a1 -> Payable '["Value"]
Value Value
val])
  let newTxSkelIns :: Map TxOutRef TxSkelRedeemer
newTxSkelIns = Map TxOutRef TxSkelRedeemer
txSkelIns Map TxOutRef TxSkelRedeemer
-> Map TxOutRef TxSkelRedeemer -> Map TxOutRef TxSkelRedeemer
forall a. Semigroup a => a -> a -> a
<> [(TxOutRef, TxSkelRedeemer)] -> Map TxOutRef TxSkelRedeemer
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((,TxSkelRedeemer
emptyTxSkelRedeemer) (TxOutRef -> (TxOutRef, TxSkelRedeemer))
-> [TxOutRef] -> [(TxOutRef, TxSkelRedeemer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOutRef]
additionalInsTxOutRefs)
  TxSkel -> m TxSkel
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel -> m TxSkel) -> TxSkel -> m TxSkel
forall a b. (a -> b) -> a -> b
$ (TxSkel
txSkel TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Lens' TxSkel [TxSkelOut]
txSkelOutsL Lens' TxSkel [TxSkelOut] -> [TxSkelOut] -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [TxSkelOut]
newTxSkelOuts) TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInsL Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Map TxOutRef TxSkelRedeemer -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Map TxOutRef TxSkelRedeemer
newTxSkelIns