-- | 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 qualified as Cardano
import Cardano.Ledger.BaseTypes qualified as Cardano
import Cardano.Ledger.Conway.Core qualified as Conway
import Cardano.Ledger.Conway.PParams qualified as Conway
import Cardano.Ledger.Plutus.ExUnits qualified as Cardano
import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator
import Control.Monad
import Control.Monad.Except
import Cooked.MockChain.AutoFilling
import Cooked.MockChain.BlockChain
import Cooked.MockChain.GenerateTx.Body
import Cooked.MockChain.UtxoSearch
import Cooked.Skeleton
import Data.Bifunctor
import Data.Function
import Data.List (find, partition, sortBy)
import Data.Map qualified as Map
import Data.Ratio qualified as Rat
import Data.Set qualified as Set
import Lens.Micro.Extras qualified as MicroLens
import Optics.Core
import Optics.Core.Extras
import Plutus.Script.Utils.Address 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

-- | 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 user, 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, Collaterals)
balanceTxSkel :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m (TxSkel, Fee, Collaterals)
balanceTxSkel skelUnbal :: TxSkel
skelUnbal@TxSkel {[TxSkelSignatory]
[TxSkelProposal]
[TxSkelCertificate]
[TxSkelOut]
Set TxOutRef
Set TxSkelLabel
Map TxOutRef TxSkelRedeemer
SlotRange
TxSkelOpts
TxSkelWithdrawals
TxSkelMints
txSkelLabel :: Set TxSkelLabel
txSkelOpts :: TxSkelOpts
txSkelMints :: TxSkelMints
txSkelSignatories :: [TxSkelSignatory]
txSkelValidityRange :: SlotRange
txSkelIns :: Map TxOutRef TxSkelRedeemer
txSkelInsReference :: Set TxOutRef
txSkelOuts :: [TxSkelOut]
txSkelProposals :: [TxSkelProposal]
txSkelWithdrawals :: TxSkelWithdrawals
txSkelCertificates :: [TxSkelCertificate]
txSkelLabel :: TxSkel -> Set TxSkelLabel
txSkelOpts :: TxSkel -> TxSkelOpts
txSkelMints :: TxSkel -> TxSkelMints
txSkelSignatories :: TxSkel -> [TxSkelSignatory]
txSkelValidityRange :: TxSkel -> SlotRange
txSkelIns :: TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelInsReference :: TxSkel -> Set TxOutRef
txSkelOuts :: TxSkel -> [TxSkelOut]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelWithdrawals :: TxSkel -> TxSkelWithdrawals
txSkelCertificates :: TxSkel -> [TxSkelCertificate]
..} = do
  -- We retrieve the possible balancing user. Any extra payment will be
  -- redirected to them, and utxos will be taken from their user if associated
  -- with the BalancingUtxosFromBalancingUser policy
  Maybe (User 'IsPubKey 'Allocation)
balancingUser <- case TxSkelOpts -> BalancingPolicy
txSkelOptBalancingPolicy TxSkelOpts
txSkelOpts of
    BalancingPolicy
BalanceWithFirstSignatory -> case [TxSkelSignatory]
txSkelSignatories of
      [] -> MockChainError -> m (Maybe (User 'IsPubKey 'Allocation))
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m (Maybe (User 'IsPubKey 'Allocation)))
-> MockChainError -> m (Maybe (User 'IsPubKey 'Allocation))
forall a b. (a -> b) -> a -> b
$ String -> MockChainError
MCEMissingBalancingUser String
"The list of signatories is empty, but the balancing user is supposed to be the first signatory."
      TxSkelSignatory
bw : [TxSkelSignatory]
_ -> Maybe (User 'IsPubKey 'Allocation)
-> m (Maybe (User 'IsPubKey 'Allocation))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (User 'IsPubKey 'Allocation)
 -> m (Maybe (User 'IsPubKey 'Allocation)))
-> Maybe (User 'IsPubKey 'Allocation)
-> m (Maybe (User 'IsPubKey 'Allocation))
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation -> Maybe (User 'IsPubKey 'Allocation)
forall a. a -> Maybe a
Just (User 'IsPubKey 'Allocation -> Maybe (User 'IsPubKey 'Allocation))
-> User 'IsPubKey 'Allocation -> Maybe (User 'IsPubKey 'Allocation)
forall a b. (a -> b) -> a -> b
$ PubKeyHash -> User 'IsPubKey 'Allocation
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey (PubKeyHash -> User 'IsPubKey 'Allocation)
-> PubKeyHash -> User 'IsPubKey 'Allocation
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens NoIx TxSkelSignatory PubKeyHash
-> TxSkelSignatory -> PubKeyHash
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelSignatory PubKeyHash
txSkelSignatoryPubKeyHashL TxSkelSignatory
bw
    BalanceWith pkh
bUser -> Maybe (User 'IsPubKey 'Allocation)
-> m (Maybe (User 'IsPubKey 'Allocation))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (User 'IsPubKey 'Allocation)
 -> m (Maybe (User 'IsPubKey 'Allocation)))
-> Maybe (User 'IsPubKey 'Allocation)
-> m (Maybe (User 'IsPubKey 'Allocation))
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation -> Maybe (User 'IsPubKey 'Allocation)
forall a. a -> Maybe a
Just (User 'IsPubKey 'Allocation -> Maybe (User 'IsPubKey 'Allocation))
-> User 'IsPubKey 'Allocation -> Maybe (User 'IsPubKey 'Allocation)
forall a b. (a -> b) -> a -> b
$ pkh -> User 'IsPubKey 'Allocation
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey pkh
bUser
    BalancingPolicy
DoNotBalance -> Maybe (User 'IsPubKey 'Allocation)
-> m (Maybe (User 'IsPubKey 'Allocation))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (User 'IsPubKey 'Allocation)
forall a. Maybe a
Nothing

  -- We retrieve the number of scripts involved in the transaction
  Fee
nbOfScripts <- Int -> Fee
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Fee) -> ([VScript] -> Int) -> [VScript] -> Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VScript] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([VScript] -> Fee) -> m [VScript] -> m Fee
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkel -> m [VScript]
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m [VScript]
txSkelAllScripts TxSkel
skelUnbal

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

  -- We collect collateral inputs candidates. They might be directly provided in
  -- the skeleton, or should be retrieved from a given user. They are
  -- associated with a return collateral user, 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.
  Collaterals
mCollaterals <- do
    -- The transaction will only require collaterals when involving scripts
    case (Fee
nbOfScripts Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
0, TxSkelOpts -> CollateralUtxos
txSkelOptCollateralUtxos TxSkelOpts
txSkelOpts) of
      (Bool
True, CollateralUtxosFromSet Set TxOutRef
utxos pkh
_) -> MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
-> MockChainLogEntry
MCLogUnusedCollaterals (Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
 -> MockChainLogEntry)
-> Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
-> MockChainLogEntry
forall a b. (a -> b) -> a -> b
$ Set TxOutRef -> Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
forall a b. b -> Either a b
Right Set TxOutRef
utxos) m () -> m Collaterals -> m Collaterals
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Collaterals -> m Collaterals
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Collaterals
forall a. Maybe a
Nothing
      (Bool
True, CollateralUtxosFromUser pkh
cUser) -> MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
-> MockChainLogEntry
MCLogUnusedCollaterals (Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
 -> MockChainLogEntry)
-> Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
-> MockChainLogEntry
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation
-> Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
forall a b. a -> Either a b
Left (User 'IsPubKey 'Allocation
 -> Either (User 'IsPubKey 'Allocation) (Set TxOutRef))
-> User 'IsPubKey 'Allocation
-> Either (User 'IsPubKey 'Allocation) (Set TxOutRef)
forall a b. (a -> b) -> a -> b
$ pkh -> User 'IsPubKey 'Allocation
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey pkh
cUser) m () -> m Collaterals -> m Collaterals
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Collaterals -> m Collaterals
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Collaterals
forall a. Maybe a
Nothing
      (Bool
True, CollateralUtxos
CollateralUtxosFromBalancingUser) -> Collaterals -> m Collaterals
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Collaterals
forall a. Maybe a
Nothing
      (Bool
False, CollateralUtxosFromSet Set TxOutRef
utxos pkh
rUser) -> Collaterals -> m Collaterals
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Collaterals -> m Collaterals) -> Collaterals -> m Collaterals
forall a b. (a -> b) -> a -> b
$ (Set TxOutRef, User 'IsPubKey 'Allocation) -> Collaterals
forall a. a -> Maybe a
Just (Set TxOutRef
utxos, pkh -> User 'IsPubKey 'Allocation
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey pkh
rUser)
      (Bool
False, CollateralUtxosFromUser pkh
cUser) -> (Set TxOutRef, User 'IsPubKey 'Allocation) -> Collaterals
forall a. a -> Maybe a
Just ((Set TxOutRef, User 'IsPubKey 'Allocation) -> Collaterals)
-> ([(TxOutRef, TxSkelOut)]
    -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> [(TxOutRef, TxSkelOut)]
-> Collaterals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,pkh -> User 'IsPubKey 'Allocation
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey pkh
cUser) (Set TxOutRef -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> ([(TxOutRef, TxSkelOut)] -> Set TxOutRef)
-> [(TxOutRef, TxSkelOut)]
-> (Set TxOutRef, User 'IsPubKey 'Allocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOutRef] -> Set TxOutRef
forall a. Ord a => [a] -> Set a
Set.fromList ([TxOutRef] -> Set TxOutRef)
-> ([(TxOutRef, TxSkelOut)] -> [TxOutRef])
-> [(TxOutRef, TxSkelOut)]
-> Set TxOutRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxOutRef, TxSkelOut) -> TxOutRef)
-> [(TxOutRef, TxSkelOut)] -> [TxOutRef]
forall a b. (a -> b) -> [a] -> [b]
map (TxOutRef, TxSkelOut) -> TxOutRef
forall a b. (a, b) -> a
fst ([(TxOutRef, TxSkelOut)] -> Collaterals)
-> m [(TxOutRef, TxSkelOut)] -> m Collaterals
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch (PubKeyHash -> UtxoSearch m TxSkelOut
forall (m :: * -> *) addr.
(MonadBlockChainBalancing m, ToAddress addr) =>
addr -> UtxoSearch m TxSkelOut
onlyValueOutputsAtSearch (PubKeyHash -> UtxoSearch m TxSkelOut)
-> PubKeyHash -> UtxoSearch m TxSkelOut
forall a b. (a -> b) -> a -> b
$ pkh -> PubKeyHash
forall a. ToPubKeyHash a => a -> PubKeyHash
Script.toPubKeyHash pkh
cUser)
      (Bool
False, CollateralUtxos
CollateralUtxosFromBalancingUser) -> case Maybe (User 'IsPubKey 'Allocation)
balancingUser of
        Maybe (User 'IsPubKey 'Allocation)
Nothing -> MockChainError -> m Collaterals
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m Collaterals)
-> MockChainError -> m Collaterals
forall a b. (a -> b) -> a -> b
$ String -> MockChainError
MCEMissingBalancingUser String
"Collateral utxos should be taken from the balancing user, but it does not exist."
        Just User 'IsPubKey 'Allocation
bUser -> (Set TxOutRef, User 'IsPubKey 'Allocation) -> Collaterals
forall a. a -> Maybe a
Just ((Set TxOutRef, User 'IsPubKey 'Allocation) -> Collaterals)
-> ([(TxOutRef, TxSkelOut)]
    -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> [(TxOutRef, TxSkelOut)]
-> Collaterals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,User 'IsPubKey 'Allocation
bUser) (Set TxOutRef -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> ([(TxOutRef, TxSkelOut)] -> Set TxOutRef)
-> [(TxOutRef, TxSkelOut)]
-> (Set TxOutRef, User 'IsPubKey 'Allocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOutRef] -> Set TxOutRef
forall a. Ord a => [a] -> Set a
Set.fromList ([TxOutRef] -> Set TxOutRef)
-> ([(TxOutRef, TxSkelOut)] -> [TxOutRef])
-> [(TxOutRef, TxSkelOut)]
-> Set TxOutRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxOutRef, TxSkelOut) -> TxOutRef)
-> [(TxOutRef, TxSkelOut)] -> [TxOutRef]
forall a b. (a -> b) -> [a] -> [b]
map (TxOutRef, TxSkelOut) -> TxOutRef
forall a b. (a, b) -> a
fst ([(TxOutRef, TxSkelOut)] -> Collaterals)
-> m [(TxOutRef, TxSkelOut)] -> m Collaterals
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch (User 'IsPubKey 'Allocation -> UtxoSearch m TxSkelOut
forall (m :: * -> *) addr.
(MonadBlockChainBalancing m, ToAddress addr) =>
addr -> UtxoSearch m TxSkelOut
onlyValueOutputsAtSearch User 'IsPubKey 'Allocation
bUser)

  -- At this point, the presence (or absence) of balancing user dictates
  -- whether the transaction should be automatically balanced or not.
  (TxSkel
txSkelBal, Fee
fee, Collaterals
adjustedColsAndUser) <- case Maybe (User 'IsPubKey 'Allocation)
balancingUser of
    Maybe (User 'IsPubKey 'Allocation)
Nothing ->
      -- The balancing should not be performed. We still adjust the collaterals
      -- though around a provided fee, or the maximum fee.
      let fee :: Fee
fee = case TxSkelOpts -> FeePolicy
txSkelOptFeePolicy TxSkelOpts
txSkelOpts of
            FeePolicy
AutoFeeComputation -> Fee
maxFee
            ManualFee Fee
fee' -> Fee
fee'
       in (TxSkel
skelUnbal,Fee
fee,) (Collaterals -> (TxSkel, Fee, Collaterals))
-> m Collaterals -> m (TxSkel, Fee, Collaterals)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fee -> Collaterals -> m Collaterals
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Fee -> Collaterals -> m Collaterals
collateralsFromFees Fee
fee Collaterals
mCollaterals
    Just User 'IsPubKey 'Allocation
bUser -> do
      -- The balancing should be performed. We collect the candidates balancing
      -- utxos based on the associated policy
      [(TxOutRef, TxSkelOut)]
balancingUtxos <-
        case TxSkelOpts -> BalancingUtxos
txSkelOptBalancingUtxos TxSkelOpts
txSkelOpts of
          BalancingUtxos
BalancingUtxosFromBalancingUser -> UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch (UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)])
-> UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)]
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation -> UtxoSearch m TxSkelOut
forall (m :: * -> *) addr.
(MonadBlockChainBalancing m, ToAddress addr) =>
addr -> UtxoSearch m TxSkelOut
onlyValueOutputsAtSearch User 'IsPubKey 'Allocation
bUser
          BalancingUtxosFromSet Set TxOutRef
utxos ->
            -- We resolve the given set of utxos
            UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch ([TxOutRef] -> UtxoSearch m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[TxOutRef] -> UtxoSearch m TxSkelOut
txSkelOutByRefSearch (Set TxOutRef -> [TxOutRef]
forall a. Set a -> [a]
Set.toList Set TxOutRef
utxos))
              -- We filter out those belonging to scripts, while throwing a
              -- warning if any was actually discarded.
              m [(TxOutRef, TxSkelOut)]
-> ([(TxOutRef, TxSkelOut)] -> m [(TxOutRef, TxSkelOut)])
-> m [(TxOutRef, TxSkelOut)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((TxOutRef, TxSkelOut) -> Bool)
-> String -> [(TxOutRef, TxSkelOut)] -> m [(TxOutRef, TxSkelOut)]
forall {m :: * -> *} {a}.
MonadBlockChainBalancing m =>
(a -> Bool) -> String -> [a] -> m [a]
filterAndWarn (Optic' An_AffineTraversal NoIx TxSkelOut PubKeyHash
-> TxSkelOut -> Bool
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Bool
is (Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> Optic
     An_AffineTraversal
     NoIx
     (User 'IsEither 'Allocation)
     (User 'IsEither 'Allocation)
     PubKeyHash
     PubKeyHash
-> Optic' An_AffineTraversal NoIx TxSkelOut PubKeyHash
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
  An_AffineTraversal
  NoIx
  (User 'IsEither 'Allocation)
  (User 'IsEither 'Allocation)
  PubKeyHash
  PubKeyHash
forall (kind :: UserKind) (mode :: UserMode).
AffineTraversal' (User kind mode) PubKeyHash
userPubKeyHashAT) (TxSkelOut -> Bool)
-> ((TxOutRef, TxSkelOut) -> TxSkelOut)
-> (TxOutRef, TxSkelOut)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxSkelOut) -> TxSkelOut
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, TxSkelOut)]
-> ([(TxOutRef, TxSkelOut)] -> m [(TxOutRef, TxSkelOut)])
-> m [(TxOutRef, TxSkelOut)]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((TxOutRef, TxSkelOut) -> Bool)
-> String -> [(TxOutRef, TxSkelOut)] -> m [(TxOutRef, TxSkelOut)]
forall {m :: * -> *} {a}.
MonadBlockChainBalancing m =>
(a -> Bool) -> String -> [a] -> m [a]
filterAndWarn ((TxOutRef -> Set TxOutRef -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` TxSkel -> Set TxOutRef
txSkelKnownTxOutRefs TxSkel
skelUnbal) (TxOutRef -> Bool)
-> ((TxOutRef, TxSkelOut) -> TxOutRef)
-> (TxOutRef, TxSkelOut)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxSkelOut) -> TxOutRef
forall a b. (a, b) -> a
fst) String
"They are already used in the skeleton."

      case TxSkelOpts -> FeePolicy
txSkelOptFeePolicy TxSkelOpts
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 ->
          User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [(TxOutRef, TxSkelOut)]
-> Collaterals
-> TxSkel
-> m (TxSkel, Fee, Collaterals)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [(TxOutRef, TxSkelOut)]
-> Collaterals
-> TxSkel
-> m (TxSkel, Fee, Collaterals)
computeFeeAndBalance User 'IsPubKey 'Allocation
bUser Fee
minFee Fee
maxFee [(TxOutRef, TxSkelOut)]
balancingUtxos Collaterals
mCollaterals TxSkel
skelUnbal
        -- If fee are provided manually, we adjust the collaterals and the
        -- skeleton around them directly.
        ManualFee Fee
fee -> do
          Collaterals
adjustedColsAndUser <- Fee -> Collaterals -> m Collaterals
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Fee -> Collaterals -> m Collaterals
collateralsFromFees Fee
fee Collaterals
mCollaterals
          TxSkel
attemptedSkel <- User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)] -> TxSkel -> Fee -> m TxSkel
forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)] -> TxSkel -> Fee -> m TxSkel
computeBalancedTxSkel User 'IsPubKey 'Allocation
bUser [(TxOutRef, TxSkelOut)]
balancingUtxos TxSkel
skelUnbal Fee
fee
          (TxSkel, Fee, Collaterals) -> m (TxSkel, Fee, Collaterals)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel
attemptedSkel, Fee
fee, Collaterals
adjustedColsAndUser)

  (TxSkel, Fee, Collaterals) -> m (TxSkel, Fee, Collaterals)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel
txSkelBal, Fee
fee, Collaterals
adjustedColsAndUser)
  where
    filterAndWarn :: (a -> Bool) -> String -> [a] -> m [a]
filterAndWarn a -> Bool
f String
s [a]
l
      | ([a]
ok, Int -> Fee
forall a. Integral a => a -> Fee
toInteger (Int -> Fee) -> ([a] -> Int) -> [a] -> Fee
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 -> Fee
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 (Fee
koLength Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
0) (MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (MockChainLogEntry -> m ()) -> MockChainLogEntry -> m ()
forall a b. (a -> b) -> a -> b
$ Fee -> String -> MockChainLogEntry
MCLogDiscardedUtxos Fee
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 and its number of scripts.
getMinAndMaxFee :: (MonadBlockChainBalancing m) => Fee -> m (Fee, Fee)
getMinAndMaxFee :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Fee -> m (Fee, Fee)
getMinAndMaxFee Fee
nbOfScripts = do
  -- We retrieve the necessary parameters to compute the maximum possible fee
  -- for a transaction. There are quite a few of them.
  PParams
params <- Params -> PParams
Emulator.pEmulatorPParams (Params -> PParams) -> m Params -> m PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  let maxTxSize :: Fee
maxTxSize = Word32 -> Fee
forall a. Integral a => a -> Fee
toInteger (Word32 -> Fee) -> Word32 -> Fee
forall a b. (a -> b) -> a -> b
$ Getting Word32 PParams Word32 -> PParams -> Word32
forall a s. Getting a s a -> s -> a
MicroLens.view Getting Word32 PParams Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' PParams Word32
Conway.ppMaxTxSizeL PParams
params
      Cardano.Coin Fee
txFeePerByte = Getting Coin PParams Coin -> PParams -> Coin
forall a s. Getting a s a -> s -> a
MicroLens.view Getting Coin PParams Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' PParams Coin
Conway.ppMinFeeAL PParams
params
      Cardano.Coin Fee
txFeeFixed = Getting Coin PParams Coin -> PParams -> Coin
forall a s. Getting a s a -> s -> a
MicroLens.view Getting Coin PParams Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' PParams Coin
Conway.ppMinFeeBL PParams
params
      Cardano.Prices (NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
Cardano.unboundRational -> Rational
priceESteps) (NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
Cardano.unboundRational -> Rational
priceEMem) = Getting Prices PParams Prices -> PParams -> Prices
forall a s. Getting a s a -> s -> a
MicroLens.view Getting Prices PParams Prices
forall era. AlonzoEraPParams era => Lens' (PParams era) Prices
Lens' PParams Prices
Conway.ppPricesL PParams
params
      Cardano.ExUnits (Natural -> Fee
forall a. Integral a => a -> Fee
toInteger -> Fee
eSteps) (Natural -> Fee
forall a. Integral a => a -> Fee
toInteger -> Fee
eMem) = Getting ExUnits PParams ExUnits -> PParams -> ExUnits
forall a s. Getting a s a -> s -> a
MicroLens.view Getting ExUnits PParams ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' PParams ExUnits
Conway.ppMaxTxExUnitsL PParams
params
      (NonNegativeInterval -> Rational
forall r. BoundedRational r => r -> Rational
Cardano.unboundRational -> Rational
refScriptFeePerByte) = Getting NonNegativeInterval PParams NonNegativeInterval
-> PParams -> NonNegativeInterval
forall a s. Getting a s a -> s -> a
MicroLens.view Getting NonNegativeInterval PParams NonNegativeInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' PParams NonNegativeInterval
Conway.ppMinFeeRefScriptCostPerByteL PParams
params
  -- We compute the components of the maximum possible fee, starting with the
  -- maximum fee associated with the transaction size
  let txSizeMaxFees :: Fee
txSizeMaxFees = Fee
maxTxSize Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
* Fee
txFeePerByte
  -- maximum fee associated with the number of execution steps for scripts
  let eStepsMaxFees :: Fee
eStepsMaxFees = (Fee
eSteps Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
* Rational -> Fee
forall a. Ratio a -> a
Rat.numerator Rational
priceESteps) Fee -> Fee -> Fee
forall a. Integral a => a -> a -> a
`div` Rational -> Fee
forall a. Ratio a -> a
Rat.denominator Rational
priceESteps
  -- maximum fee associated with the number of execution memory for scripts
  let eMemMaxFees :: Fee
eMemMaxFees = (Fee
eMem Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
* Rational -> Fee
forall a. Ratio a -> a
Rat.numerator Rational
priceEMem) Fee -> Fee -> Fee
forall a. Integral a => a -> a -> a
`div` Rational -> Fee
forall a. Ratio a -> a
Rat.denominator Rational
priceEMem
  -- maximum fee associated with the size of all reference scripts
  let refScriptsMaxFees :: Fee
refScriptsMaxFees = (Fee
maxTxSize Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
* Rational -> Fee
forall a. Ratio a -> a
Rat.numerator Rational
refScriptFeePerByte) Fee -> Fee -> Fee
forall a. Integral a => a -> a -> a
`div` Rational -> Fee
forall a. Ratio a -> a
Rat.denominator Rational
refScriptFeePerByte
  (Fee, Fee) -> m (Fee, Fee)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( -- Minimal fee is just the fixed portion of the fee
      Fee
txFeeFixed,
      -- Maximal fee is the fixed portion plus all the other maximum fees
      Fee
txFeeFixed Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
txSizeMaxFees Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
nbOfScripts Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
* (Fee
eStepsMaxFees Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
eMemMaxFees) Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
refScriptsMaxFees
    )

-- | 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) => Peer -> Fee -> Fee -> Utxos -> Collaterals -> TxSkel -> m (TxSkel, Fee, Collaterals)
computeFeeAndBalance :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [(TxOutRef, TxSkelOut)]
-> Collaterals
-> TxSkel
-> m (TxSkel, Fee, Collaterals)
computeFeeAndBalance User 'IsPubKey 'Allocation
_ Fee
minFee Fee
maxFee [(TxOutRef, TxSkelOut)]
_ Collaterals
_ TxSkel
_
  | Fee
minFee Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
> Fee
maxFee =
      MockChainError -> m (TxSkel, Fee, Collaterals)
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MockChainError -> m (TxSkel, Fee, Collaterals))
-> MockChainError -> m (TxSkel, Fee, Collaterals)
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 User 'IsPubKey 'Allocation
balancingUser Fee
minFee Fee
maxFee [(TxOutRef, TxSkelOut)]
balancingUtxos Collaterals
mCollaterals TxSkel
skel
  | Fee
minFee Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
maxFee = do
      -- The fee interval is reduced to a single element, we balance around it
      (Collaterals
adjustedColsAndUser, TxSkel
attemptedSkel) <- User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)]
-> Fee
-> Collaterals
-> TxSkel
-> m (Collaterals, TxSkel)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)]
-> Fee
-> Collaterals
-> TxSkel
-> m (Collaterals, TxSkel)
attemptBalancingAndCollaterals User 'IsPubKey 'Allocation
balancingUser [(TxOutRef, TxSkelOut)]
balancingUtxos Fee
minFee Collaterals
mCollaterals TxSkel
skel
      (TxSkel, Fee, Collaterals) -> m (TxSkel, Fee, Collaterals)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel
attemptedSkel, Fee
minFee, Collaterals
adjustedColsAndUser)
computeFeeAndBalance User 'IsPubKey 'Allocation
balancingUser Fee
minFee Fee
maxFee [(TxOutRef, TxSkelOut)]
balancingUtxos Collaterals
mCollaterals TxSkel
skel
  | Fee
fee <- (Fee
minFee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
maxFee) Fee -> Fee -> Fee
forall a. Integral a => a -> a -> a
`div` Fee
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 (Collaterals, TxSkel)
attemptedBalancing <- m (Maybe (Collaterals, TxSkel))
-> (MockChainError -> m (Maybe (Collaterals, TxSkel)))
-> m (Maybe (Collaterals, 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
        ((Collaterals, TxSkel) -> Maybe (Collaterals, TxSkel)
forall a. a -> Maybe a
Just ((Collaterals, TxSkel) -> Maybe (Collaterals, TxSkel))
-> m (Collaterals, TxSkel) -> m (Maybe (Collaterals, TxSkel))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)]
-> Fee
-> Collaterals
-> TxSkel
-> m (Collaterals, TxSkel)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)]
-> Fee
-> Collaterals
-> TxSkel
-> m (Collaterals, TxSkel)
attemptBalancingAndCollaterals User 'IsPubKey 'Allocation
balancingUser [(TxOutRef, TxSkelOut)]
balancingUtxos Fee
fee Collaterals
mCollaterals TxSkel
skel)
        ((MockChainError -> m (Maybe (Collaterals, TxSkel)))
 -> m (Maybe (Collaterals, TxSkel)))
-> (MockChainError -> m (Maybe (Collaterals, TxSkel)))
-> m (Maybe (Collaterals, 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 {} | Fee
fee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
minFee Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
> Fee
0 -> Maybe (Collaterals, TxSkel) -> m (Maybe (Collaterals, TxSkel))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Collaterals, TxSkel)
forall a. Maybe a
Nothing
          MCENoSuitableCollateral {} | Fee
fee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
minFee Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
> Fee
0 -> Maybe (Collaterals, TxSkel) -> m (Maybe (Collaterals, TxSkel))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Collaterals, TxSkel)
forall a. Maybe a
Nothing
          MockChainError
err -> MockChainError -> m (Maybe (Collaterals, TxSkel))
forall a. MockChainError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError MockChainError
err

      (Fee
newMinFee, Fee
newMaxFee) <- case Maybe (Collaterals, TxSkel)
attemptedBalancing of
        -- The skeleton was not balanceable, we try strictly smaller fee
        Maybe (Collaterals, TxSkel)
Nothing -> (Fee, Fee) -> m (Fee, Fee)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fee
minFee, Fee
fee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
1)
        -- The skeleton was balanceable, we compute and analyse the resulting
        -- fee to seach upwards or downwards for an optimal solution
        Just (Collaterals
adjustedColsAndUser, TxSkel
attemptedSkel) -> do
          Fee
newFee <- TxSkel -> Fee -> Collaterals -> m Fee
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> Fee -> Collaterals -> m Fee
estimateTxSkelFee TxSkel
attemptedSkel Fee
fee Collaterals
adjustedColsAndUser
          (Fee, Fee) -> m (Fee, Fee)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Fee, Fee) -> m (Fee, Fee)) -> (Fee, Fee) -> m (Fee, Fee)
forall a b. (a -> b) -> a -> b
$ case Fee
fee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
newFee of
            -- Current fee is insufficient, we look on the right (strictly)
            Fee
n | Fee
n Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
< Fee
0 -> (Fee
fee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
1, Fee
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 user 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.
            Fee
_ | TxSkel -> Value
txSkelValueInOutputs TxSkel
attemptedSkel Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== TxSkel -> Value
txSkelValueInOutputs TxSkel
skel -> (Fee
minFee, Fee
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 user. We can speed up search, because the current
            -- attempted skeleton could necessarily account for the estimated
            -- fee of the input skeleton.
            Fee
_ -> (Fee
minFee, Fee
newFee)

      User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [(TxOutRef, TxSkelOut)]
-> Collaterals
-> TxSkel
-> m (TxSkel, Fee, Collaterals)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [(TxOutRef, TxSkelOut)]
-> Collaterals
-> TxSkel
-> m (TxSkel, Fee, Collaterals)
computeFeeAndBalance User 'IsPubKey 'Allocation
balancingUser Fee
newMinFee Fee
newMaxFee [(TxOutRef, TxSkelOut)]
balancingUtxos Collaterals
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) => Peer -> Utxos -> Fee -> Collaterals -> TxSkel -> m (Collaterals, TxSkel)
attemptBalancingAndCollaterals :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)]
-> Fee
-> Collaterals
-> TxSkel
-> m (Collaterals, TxSkel)
attemptBalancingAndCollaterals User 'IsPubKey 'Allocation
balancingUser [(TxOutRef, TxSkelOut)]
balancingUtxos Fee
fee Collaterals
mCollaterals TxSkel
skel = do
  Collaterals
adjustedCollateralIns <- Fee -> Collaterals -> m Collaterals
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Fee -> Collaterals -> m Collaterals
collateralsFromFees Fee
fee Collaterals
mCollaterals
  TxSkel
attemptedSkel <- User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)] -> TxSkel -> Fee -> m TxSkel
forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)] -> TxSkel -> Fee -> m TxSkel
computeBalancedTxSkel User 'IsPubKey 'Allocation
balancingUser [(TxOutRef, TxSkelOut)]
balancingUtxos TxSkel
skel Fee
fee
  (Collaterals, TxSkel) -> m (Collaterals, TxSkel)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Collaterals
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 -> CollateralIns -> Peer -> m CollateralIns
collateralInsFromFees :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Fee
-> Set TxOutRef -> User 'IsPubKey 'Allocation -> m (Set TxOutRef)
collateralInsFromFees Fee
fee Set TxOutRef
collateralIns User 'IsPubKey 'Allocation
returnCollateralUser = do
  -- We retrieve the protocal parameters
  PParams
params <- Params -> PParams
Emulator.pEmulatorPParams (Params -> PParams) -> m Params -> m PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  -- We retrieve the max number of collateral inputs, with a default of 10. In
  -- practice this will be around 3.
  let nbMax :: Fee
nbMax = Natural -> Fee
forall a. Integral a => a -> Fee
toInteger (Natural -> Fee) -> Natural -> Fee
forall a b. (a -> b) -> a -> b
$ Getting Natural PParams Natural -> PParams -> Natural
forall a s. Getting a s a -> s -> a
MicroLens.view Getting Natural PParams Natural
forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' PParams Natural
Conway.ppMaxCollateralInputsL PParams
params
  -- We retrieve the percentage to respect between fees and total collaterals
  let percentage :: Fee
percentage = Natural -> Fee
forall a. Integral a => a -> Fee
toInteger (Natural -> Fee) -> Natural -> Fee
forall a b. (a -> b) -> a -> b
$ Getting Natural PParams Natural -> PParams -> Natural
forall a s. Getting a s a -> s -> a
MicroLens.view Getting Natural PParams Natural
forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' PParams Natural
Conway.ppCollateralPercentageL PParams
params
  -- 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 = Fee -> Value
Script.lovelace (Fee -> Value) -> (Fee -> Fee) -> Fee -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
1) (Fee -> Fee) -> (Fee -> Fee) -> Fee -> Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fee -> Fee -> Fee
forall a. Integral a => a -> a -> a
`div` Fee
100) (Fee -> Fee) -> (Fee -> Fee) -> Fee -> Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
* Fee
percentage) (Fee -> Value) -> Fee -> Value
forall a b. (a -> b) -> a -> b
$ Fee
fee
  -- Collateral tx outputs sorted by decreasing ada amount
  [(TxOutRef, TxSkelOut)]
collateralTxOuts <- UtxoSearch m TxSkelOut -> m [(TxOutRef, TxSkelOut)]
forall (m :: * -> *) a.
Monad m =>
UtxoSearch m a -> m [(TxOutRef, a)]
runUtxoSearch ([TxOutRef] -> UtxoSearch m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[TxOutRef] -> UtxoSearch m TxSkelOut
txSkelOutByRefSearch ([TxOutRef] -> UtxoSearch m TxSkelOut)
-> [TxOutRef] -> UtxoSearch m TxSkelOut
forall a b. (a -> b) -> a -> b
$ Set TxOutRef -> [TxOutRef]
forall a. Set a -> [a]
Set.toList Set TxOutRef
collateralIns)
  -- Candidate subsets of utxos to be used as collaterals
  let candidatesRaw :: [([(TxOutRef, TxSkelOut)], Value)]
candidatesRaw = [(TxOutRef, TxSkelOut)]
-> Value -> Fee -> [([(TxOutRef, TxSkelOut)], Value)]
reachValue [(TxOutRef, TxSkelOut)]
collateralTxOuts Value
totalCollateral Fee
nbMax
  -- Preparing a possible collateral error
  let noSuitableCollateralError :: MockChainError
noSuitableCollateralError = Fee -> Fee -> Value -> MockChainError
MCENoSuitableCollateral Fee
fee Fee
percentage Value
totalCollateral
  -- Retrieving and returning the best candidate as a utxo set
  [TxOutRef] -> Set TxOutRef
forall a. Ord a => [a] -> Set a
Set.fromList ([TxOutRef] -> Set TxOutRef)
-> (([TxOutRef], Value) -> [TxOutRef])
-> ([TxOutRef], Value)
-> Set TxOutRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([TxOutRef], Value) -> [TxOutRef]
forall a b. (a, b) -> a
fst (([TxOutRef], Value) -> Set TxOutRef)
-> m ([TxOutRef], Value) -> m (Set TxOutRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([(TxOutRef, TxSkelOut)], Value)]
-> User 'IsPubKey 'Allocation
-> MockChainError
-> m ([TxOutRef], Value)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxSkelOut)], Value)]
-> User 'IsPubKey 'Allocation
-> MockChainError
-> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxSkelOut)], Value)]
candidatesRaw User 'IsPubKey 'Allocation
returnCollateralUser MockChainError
noSuitableCollateralError

-- | This adjusts collateral inputs when necessary
collateralsFromFees :: (MonadBlockChainBalancing m) => Fee -> Collaterals -> m Collaterals
collateralsFromFees :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
Fee -> Collaterals -> m Collaterals
collateralsFromFees Fee
_ Collaterals
Nothing = Collaterals -> m Collaterals
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Collaterals
forall a. Maybe a
Nothing
collateralsFromFees Fee
fee (Just (Set TxOutRef
collateralIns, User 'IsPubKey 'Allocation
returnCollateralUser)) =
  (Set TxOutRef, User 'IsPubKey 'Allocation) -> Collaterals
forall a. a -> Maybe a
Just ((Set TxOutRef, User 'IsPubKey 'Allocation) -> Collaterals)
-> (Set TxOutRef -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> Set TxOutRef
-> Collaterals
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,User 'IsPubKey 'Allocation
returnCollateralUser) (Set TxOutRef -> Collaterals) -> m (Set TxOutRef) -> m Collaterals
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fee
-> Set TxOutRef -> User 'IsPubKey 'Allocation -> m (Set TxOutRef)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
Fee
-> Set TxOutRef -> User 'IsPubKey 'Allocation -> m (Set TxOutRef)
collateralInsFromFees Fee
fee Set TxOutRef
collateralIns User 'IsPubKey 'Allocation
returnCollateralUser

-- | 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 :: Utxos -> Api.Value -> Fee -> [(Utxos, 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, TxSkelOut)]
-> Value -> Fee -> [([(TxOutRef, TxSkelOut)], Value)]
reachValue [(TxOutRef, TxSkelOut)]
_ Value
target Fee
_ | 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, TxSkelOut)]
_ Value
_ Fee
maxEls | Fee
maxEls Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
0 = []
-- The target is not reached, and cannot possibly be reached, as the remaining
-- candidates do not sum up to the target.
reachValue [(TxOutRef, TxSkelOut)]
l Value
target Fee
_ | 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 (Optic' A_Lens NoIx TxSkelOut Value -> TxSkelOut -> Value
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL (TxSkelOut -> Value)
-> ((TxOutRef, TxSkelOut) -> TxSkelOut)
-> (TxOutRef, TxSkelOut)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxSkelOut) -> TxSkelOut
forall a b. (a, b) -> b
snd ((TxOutRef, TxSkelOut) -> Value)
-> [(TxOutRef, TxSkelOut)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxSkelOut)]
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
_ Fee
_ = []
-- 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, TxSkelOut)
h@(TxOutRef
_, Optic' A_Lens NoIx TxSkelOut Value -> TxSkelOut -> Value
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL -> Value
hVal) : [(TxOutRef, TxSkelOut)]
t) Value
target Fee
maxEls =
  [([(TxOutRef, TxSkelOut)], Value)]
-> [([(TxOutRef, TxSkelOut)], Value)]
-> [([(TxOutRef, TxSkelOut)], Value)]
forall a. [a] -> [a] -> [a]
(++) ([(TxOutRef, TxSkelOut)]
-> Value -> Fee -> [([(TxOutRef, TxSkelOut)], Value)]
reachValue [(TxOutRef, TxSkelOut)]
t Value
target Fee
maxEls) ([([(TxOutRef, TxSkelOut)], Value)]
 -> [([(TxOutRef, TxSkelOut)], Value)])
-> [([(TxOutRef, TxSkelOut)], Value)]
-> [([(TxOutRef, TxSkelOut)], 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, TxSkelOut)] -> [(TxOutRef, TxSkelOut)])
-> ([(TxOutRef, TxSkelOut)], Value)
-> ([(TxOutRef, TxSkelOut)], 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, TxSkelOut)
h (TxOutRef, TxSkelOut)
-> [(TxOutRef, TxSkelOut)] -> [(TxOutRef, TxSkelOut)]
forall a. a -> [a] -> [a]
:) (([(TxOutRef, TxSkelOut)], Value)
 -> ([(TxOutRef, TxSkelOut)], Value))
-> [([(TxOutRef, TxSkelOut)], Value)]
-> [([(TxOutRef, TxSkelOut)], Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxSkelOut)]
-> Value -> Fee -> [([(TxOutRef, TxSkelOut)], Value)]
reachValue [(TxOutRef, TxSkelOut)]
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) (Fee
maxEls Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
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) => [(Utxos, Api.Value)] -> Peer -> MockChainError -> m ([Api.TxOutRef], Api.Value)
getOptimalCandidate :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxSkelOut)], Value)]
-> User 'IsPubKey 'Allocation
-> MockChainError
-> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxSkelOut)], Value)]
candidates User 'IsPubKey 'Allocation
paymentTarget MockChainError
mceError = do
  -- We decorate the candidates with their current ada and min ada requirements
  [([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee)]
candidatesDecorated <- [([(TxOutRef, TxSkelOut)], Value)]
-> (([(TxOutRef, TxSkelOut)], Value)
    -> m ([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee))
-> m [([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([(TxOutRef, TxSkelOut)], Value)]
candidates ((([(TxOutRef, TxSkelOut)], Value)
  -> m ([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee))
 -> m [([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee)])
-> (([(TxOutRef, TxSkelOut)], Value)
    -> m ([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee))
-> m [([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee)]
forall a b. (a -> b) -> a -> b
$ \([(TxOutRef, TxSkelOut)]
output, Value
val) ->
    ([(TxOutRef, TxSkelOut)]
output,Value
val,Value -> Lovelace
Api.lovelaceValueOf Value
val,) (Fee -> ([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee))
-> m Fee -> m ([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkelOut -> m Fee
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m Fee
getTxSkelOutMinAda (User 'IsPubKey 'Allocation
paymentTarget User 'IsPubKey 'Allocation -> Payable '[ 'IsValue] -> TxSkelOut
forall owner (els :: [PayableKind]).
IsTxSkelOutAllowedOwner owner =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '[ 'IsValue]
forall a1. ToValue a1 => a1 -> Payable '[ 'IsValue]
Value Value
val)
  -- We filter the candidates that have enough ada to sustain themselves
  let candidatesFiltered :: [(Fee, ([TxOutRef], Value))]
candidatesFiltered = [(Fee
minLv, ((TxOutRef, TxSkelOut) -> TxOutRef
forall a b. (a, b) -> a
fst ((TxOutRef, TxSkelOut) -> TxOutRef)
-> [(TxOutRef, TxSkelOut)] -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxSkelOut)]
l, Value
val)) | ([(TxOutRef, TxSkelOut)]
l, Value
val, Api.Lovelace Fee
lv, Fee
minLv) <- [([(TxOutRef, TxSkelOut)], Value, Lovelace, Fee)]
candidatesDecorated, Fee
minLv Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
<= Fee
lv]
  case ((Fee, ([TxOutRef], Value))
 -> (Fee, ([TxOutRef], Value)) -> Ordering)
-> [(Fee, ([TxOutRef], Value))] -> [(Fee, ([TxOutRef], Value))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Fee -> Fee -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Fee -> Fee -> Ordering)
-> ((Fee, ([TxOutRef], Value)) -> Fee)
-> (Fee, ([TxOutRef], Value))
-> (Fee, ([TxOutRef], Value))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Fee, ([TxOutRef], Value)) -> Fee
forall a b. (a, b) -> a
fst) [(Fee, ([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
    (Fee
_, ([TxOutRef], Value)
ret) : [(Fee, ([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 was originally inspired by
-- https://github.com/input-output-hk/plutus-apps/blob/d4255f05477fd8477ee9673e850ebb9ebb8c9657/plutus-ledger/src/Ledger/Fee.hs#L19
estimateTxSkelFee :: (MonadBlockChainBalancing m) => TxSkel -> Fee -> Collaterals -> m Fee
estimateTxSkelFee :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> Fee -> Collaterals -> m Fee
estimateTxSkelFee TxSkel
skel Fee
fee Collaterals
mCollaterals = do
  -- We retrieve the necessary data to generate the transaction body
  Params
params <- m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m Params
getParams
  -- We build the index known to the skeleton
  UTxO ConwayEra
index <- TxSkel -> Collaterals -> m (UTxO ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> Collaterals -> m (UTxO ConwayEra)
txSkelToIndex TxSkel
skel Collaterals
mCollaterals
  -- We build the transaction body
  TxBody ConwayEra
txBody <- TxSkel -> Fee -> Collaterals -> m (TxBody ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> Fee -> Collaterals -> m (TxBody ConwayEra)
txSkelToTxBody TxSkel
skel Fee
fee Collaterals
mCollaterals
  -- We finally can the fee estimate function
  Fee -> m Fee
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fee -> m Fee) -> Fee -> m Fee
forall a b. (a -> b) -> a -> b
$
    Coin -> Fee
Cardano.unCoin (Coin -> Fee) -> Coin -> Fee
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 -> Coin) -> Word -> Coin
forall a b. (a -> b) -> a -> b
$
        Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([TxSkelSignatory] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TxSkelSignatory] -> Int) -> [TxSkelSignatory] -> Int
forall a b. (a -> b) -> a -> b
$ TxSkel -> [TxSkelSignatory]
txSkelSignatories TxSkel
skel)

-- | 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) => Peer -> Utxos -> TxSkel -> Fee -> m TxSkel
computeBalancedTxSkel :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
User 'IsPubKey 'Allocation
-> [(TxOutRef, TxSkelOut)] -> TxSkel -> Fee -> m TxSkel
computeBalancedTxSkel User 'IsPubKey 'Allocation
balancingUser [(TxOutRef, TxSkelOut)]
balancingUtxos txSkel :: TxSkel
txSkel@TxSkel {[TxSkelSignatory]
[TxSkelProposal]
[TxSkelCertificate]
[TxSkelOut]
Set TxOutRef
Set TxSkelLabel
Map TxOutRef TxSkelRedeemer
SlotRange
TxSkelOpts
TxSkelWithdrawals
TxSkelMints
txSkelLabel :: TxSkel -> Set TxSkelLabel
txSkelOpts :: TxSkel -> TxSkelOpts
txSkelMints :: TxSkel -> TxSkelMints
txSkelSignatories :: TxSkel -> [TxSkelSignatory]
txSkelValidityRange :: TxSkel -> SlotRange
txSkelIns :: TxSkel -> Map TxOutRef TxSkelRedeemer
txSkelInsReference :: TxSkel -> Set TxOutRef
txSkelOuts :: TxSkel -> [TxSkelOut]
txSkelProposals :: TxSkel -> [TxSkelProposal]
txSkelWithdrawals :: TxSkel -> TxSkelWithdrawals
txSkelCertificates :: TxSkel -> [TxSkelCertificate]
txSkelLabel :: Set TxSkelLabel
txSkelOpts :: TxSkelOpts
txSkelMints :: TxSkelMints
txSkelSignatories :: [TxSkelSignatory]
txSkelValidityRange :: SlotRange
txSkelIns :: Map TxOutRef TxSkelRedeemer
txSkelInsReference :: Set TxOutRef
txSkelOuts :: [TxSkelOut]
txSkelProposals :: [TxSkelProposal]
txSkelWithdrawals :: TxSkelWithdrawals
txSkelCertificates :: [TxSkelCertificate]
..} (Fee -> 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
forall a. ToValue a => a -> Value
Script.toValue 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
certificatesDepositedValue <- Lovelace -> Value
forall a. ToValue a => a -> Value
Script.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
txSkelDepositedValueInCertificates TxSkel
txSkel
  Value
proposalsDepositedValue <- Lovelace -> Value
forall a. ToValue a => a -> Value
Script.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
txSkelDepositedValueInProposals 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
proposalsDepositedValue
            Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
certificatesDepositedValue
            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
  Fee
rightMinAda <- TxSkelOut -> m Fee
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m Fee
getTxSkelOutMinAda (TxSkelOut -> m Fee) -> TxSkelOut -> m Fee
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation
balancingUser User 'IsPubKey 'Allocation -> Payable '[ 'IsValue] -> TxSkelOut
forall owner (els :: [PayableKind]).
IsTxSkelOutAllowedOwner owner =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '[ 'IsValue]
forall a1. ToValue a1 => a1 -> Payable '[ 'IsValue]
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 Api.Lovelace Fee
rightAda = Value
missingRight Value -> Optic' A_Lens NoIx Value Lovelace -> Lovelace
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Value Lovelace
valueLovelaceL
      missingAda :: Fee
missingAda = Fee
rightMinAda Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
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
&& Fee
missingAda Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
> Fee
0 then Fee -> Value
Script.lovelace Fee
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
  -- At this point, we only need to account for the possible case were the
  -- inputs are empty and there is nothing missing on the left, as the ledger
  -- does not allow for transaction to have no inputs. When this is the case, we
  -- artificially add a requirement of 1 lovelace to force the consumption of a
  -- dummy input.
  let noInputs :: Bool
noInputs = Value
inValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty Bool -> Bool -> Bool
&& Value
missingLeft' Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty
      missingLeft'' :: Value
missingLeft'' = if Bool
noInputs then Fee -> Value
Script.lovelace Fee
1 else Value
missingLeft'
      missingRight'' :: Value
missingRight'' = if Bool
noInputs then Value
missingRight' Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Fee -> Value
Script.lovelace Fee
1 else Value
missingRight'
  -- 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, TxSkelOut)], Value)]
candidatesRaw = (Value -> Value)
-> ([(TxOutRef, TxSkelOut)], Value)
-> ([(TxOutRef, TxSkelOut)], 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, TxSkelOut)], Value)
 -> ([(TxOutRef, TxSkelOut)], Value))
-> [([(TxOutRef, TxSkelOut)], Value)]
-> [([(TxOutRef, TxSkelOut)], Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxSkelOut)]
-> Value -> Fee -> [([(TxOutRef, TxSkelOut)], Value)]
reachValue [(TxOutRef, TxSkelOut)]
balancingUtxos Value
missingLeft'' (Int -> Fee
forall a. Integral a => a -> Fee
toInteger (Int -> Fee) -> Int -> Fee
forall a b. (a -> b) -> a -> b
$ [(TxOutRef, TxSkelOut)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxOutRef, TxSkelOut)]
balancingUtxos)
  -- We prepare a possible balancing error with the difference between the
  -- requested amount and the maximum amount provided by the balancing user
  let totalValue :: Value
totalValue = [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens NoIx TxSkelOut Value -> TxSkelOut -> Value
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL (TxSkelOut -> Value)
-> ((TxOutRef, TxSkelOut) -> TxSkelOut)
-> (TxOutRef, TxSkelOut)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxSkelOut) -> TxSkelOut
forall a b. (a, b) -> b
snd ((TxOutRef, TxSkelOut) -> Value)
-> [(TxOutRef, TxSkelOut)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxSkelOut)]
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 = User 'IsPubKey 'Allocation -> Value -> MockChainError
MCEUnbalanceable User 'IsPubKey 'Allocation
balancingUser Value
difference
  -- 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 user address
  ([TxOutRef]
additionalInsTxOutRefs, [TxSkelOut]
newTxSkelOuts) <- case (([(TxOutRef, TxSkelOut)], Value) -> Bool)
-> [([(TxOutRef, TxSkelOut)], Value)]
-> Maybe ([(TxOutRef, TxSkelOut)], 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, TxSkelOut)], Value) -> Value)
-> ([(TxOutRef, TxSkelOut)], Value)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(TxOutRef, TxSkelOut)], Value) -> Value
forall a b. (a, b) -> b
snd) [([(TxOutRef, TxSkelOut)], 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, TxSkelOut)]
txOutRefs, Value
_) -> ([TxOutRef], [TxSkelOut]) -> m ([TxOutRef], [TxSkelOut])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TxOutRef, TxSkelOut) -> TxOutRef
forall a b. (a, b) -> a
fst ((TxOutRef, TxSkelOut) -> TxOutRef)
-> [(TxOutRef, TxSkelOut)] -> [TxOutRef]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, TxSkelOut)]
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, TxSkelOut)], Value)
Nothing
      | ([TxSkelOut]
before, TxSkelOut
txSkelOut : [TxSkelOut]
after) <- (TxSkelOut -> Bool) -> [TxSkelOut] -> ([TxSkelOut], [TxSkelOut])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Credential -> Credential -> Bool
forall a. Eq a => a -> a -> Bool
== User 'IsPubKey 'Allocation -> Credential
forall a. ToCredential a => a -> Credential
Script.toCredential User 'IsPubKey 'Allocation
balancingUser) (Credential -> Bool)
-> (TxSkelOut -> Credential) -> TxSkelOut -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Getter NoIx TxSkelOut Credential
-> TxSkelOut -> Credential
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Getter NoIx TxSkelOut Credential
txSkelOutCredentialG) [TxSkelOut]
txSkelOuts,
        BalanceOutputPolicy
AdjustExistingOutput <- TxSkelOpts -> BalanceOutputPolicy
txSkelOptBalanceOutputPolicy TxSkelOpts
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, TxSkelOut)], Value)]
candidatesRaw' = (Value -> Value)
-> ([(TxOutRef, TxSkelOut)], Value)
-> ([(TxOutRef, TxSkelOut)], 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
^. Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL) (([(TxOutRef, TxSkelOut)], Value)
 -> ([(TxOutRef, TxSkelOut)], Value))
-> [([(TxOutRef, TxSkelOut)], Value)]
-> [([(TxOutRef, TxSkelOut)], Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([(TxOutRef, TxSkelOut)], Value)]
candidatesRaw
          ([TxOutRef]
txOutRefs, Value
val) <- [([(TxOutRef, TxSkelOut)], Value)]
-> User 'IsPubKey 'Allocation
-> MockChainError
-> m ([TxOutRef], Value)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxSkelOut)], Value)]
-> User 'IsPubKey 'Allocation
-> MockChainError
-> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxSkelOut)], Value)]
candidatesRaw' User 'IsPubKey 'Allocation
balancingUser 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
& Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL 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 user address, or the balancing
    -- policy forces us to create a new output, both yielding the same result.
    Maybe ([(TxOutRef, TxSkelOut)], 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, TxSkelOut)], Value)]
-> User 'IsPubKey 'Allocation
-> MockChainError
-> m ([TxOutRef], Value)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
[([(TxOutRef, TxSkelOut)], Value)]
-> User 'IsPubKey 'Allocation
-> MockChainError
-> m ([TxOutRef], Value)
getOptimalCandidate [([(TxOutRef, TxSkelOut)], Value)]
candidatesRaw User 'IsPubKey 'Allocation
balancingUser 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]
++ [User 'IsPubKey 'Allocation
balancingUser User 'IsPubKey 'Allocation -> Payable '[ 'IsValue] -> TxSkelOut
forall owner (els :: [PayableKind]).
IsTxSkelOutAllowedOwner owner =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '[ 'IsValue]
forall a1. ToValue a1 => a1 -> Payable '[ 'IsValue]
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