-- | 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
  ( Body,
    ExtendedTxSkel (..),
    balanceTxSkel,
    getMinAndMaxFee,
    estimateTxSkelFee,
  )
where

import Cardano.Api qualified as Cardano
import Cardano.Api.Ledger qualified as Cardano
import Cardano.Ledger.Conway.Core qualified as Conway
import Cardano.Ledger.Conway.PParams qualified as Conway
import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator
import Control.Monad
import Cooked.MockChain.AutoFilling
import Cooked.MockChain.Common
import Cooked.MockChain.Error
import Cooked.MockChain.GenerateTx.Body
import Cooked.MockChain.GenerateTx.Output
import Cooked.MockChain.Log
import Cooked.MockChain.Read
import Cooked.MockChain.UtxoSearch
import Cooked.Skeleton
import Data.ByteString qualified as BS
import Data.Function
import Data.List (find, partition)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Ratio qualified as Rat
import Data.Set qualified as Set
import Ledger.Tx qualified as Ledger
import Ledger.Tx.CardanoAPI qualified as Ledger
import Lens.Micro.Extras qualified as Micro
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
import Polysemy
import Polysemy.Error
import Polysemy.Fail

-- | A transaction body
type Body = Cardano.TxBody Cardano.ConwayEra

-- | A `TxSkel` with extra pieces of information produced during balancing
data ExtendedTxSkel = ExtendedTxSkel
  { -- | The skeleton itself
    ExtendedTxSkel -> TxSkel
eSkel :: TxSkel,
    -- | The fee associated with this skeleton
    ExtendedTxSkel -> Fee
eFee :: Fee,
    -- | The optional collaterals associated with this skeleton
    ExtendedTxSkel -> Maybe Collaterals
eMCollaterals :: Maybe Collaterals,
    -- | The Cardano body generated from this skeleton
    ExtendedTxSkel -> Body
eBody :: Body
  }

-- | 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 ::
  (Members '[MockChainRead, MockChainLog, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) =>
  TxSkel ->
  Sem effs ExtendedTxSkel
balanceTxSkel :: forall (effs :: EffectRow).
Members
  '[MockChainRead, MockChainLog, Error MockChainError,
    Error ToCardanoError, Fail]
  effs =>
TxSkel -> Sem effs ExtendedTxSkel
balanceTxSkel skelUnbal :: TxSkel
skelUnbal@TxSkel {[TxSkelSignatory]
[TxSkelProposal]
[TxSkelCertificate]
[TxSkelOut]
Set TxOutRef
Set TxSkelLabel
Map TxOutRef TxSkelRedeemer
SlotRange
TxSkelOpts
TxSkelWithdrawals
TxSkelMints
txSkelLabels :: 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]
txSkelLabels :: 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 wallet 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 -> Sem effs (Maybe (User 'IsPubKey 'Allocation))
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MockChainError -> Sem effs (Maybe (User 'IsPubKey 'Allocation)))
-> MockChainError -> Sem effs (Maybe (User 'IsPubKey 'Allocation))
forall a b. (a -> b) -> a -> b
$ BalancingError -> MockChainError
MCEBalancingError BalancingError
MissingBalancingUser
      TxSkelSignatory
bw : [TxSkelSignatory]
_ -> Maybe (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe (User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (User 'IsPubKey 'Allocation)
 -> Sem effs (Maybe (User 'IsPubKey 'Allocation)))
-> Maybe (User 'IsPubKey 'Allocation)
-> Sem effs (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
$ TxSkelSignatory -> User 'IsPubKey 'Allocation
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey TxSkelSignatory
bw
    BalanceWith pkh
bUser -> Maybe (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe (User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (User 'IsPubKey 'Allocation)
 -> Sem effs (Maybe (User 'IsPubKey 'Allocation)))
-> Maybe (User 'IsPubKey 'Allocation)
-> Sem effs (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)
-> Sem effs (Maybe (User 'IsPubKey 'Allocation))
forall a. a -> Sem effs 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. This is used
  -- to compute the maximum possible fee, as each of those script with
  -- contribute, through its execution units, to the cost of 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) -> Sem effs [VScript] -> Sem effs Fee
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkel -> Sem effs [VScript]
forall (effs :: EffectRow).
Member MockChainRead effs =>
TxSkel -> Sem effs [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 -> Sem effs (Fee, Fee)
forall (effs :: EffectRow).
Members '[MockChainRead] effs =>
Fee -> Sem effs (Fee, Fee)
getMinAndMaxFee Fee
nbOfScripts

  -- We collect potential collateral inputs candidates, and return collateral
  -- user. They will be absent when the transaction does not involve script and
  -- thus does not require collaterals.
  Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals <- do
    case (Fee
nbOfScripts Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
0, TxSkelOpts -> CollateralUtxos
txSkelOptCollateralUtxos TxSkelOpts
txSkelOpts) of
      -- No script involved, but manual collateral UTxOs provided
      (Bool
True, CollateralUtxosFromSet Set TxOutRef
utxos pkh
_) -> MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
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) Sem effs ()
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a b. Sem effs a -> Sem effs b -> Sem effs b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
forall a. Maybe a
Nothing
      -- No script involved, but manual collateral user provided
      (Bool
True, CollateralUtxosFromUser pkh
cUser) -> MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
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) Sem effs ()
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a b. Sem effs a -> Sem effs b -> Sem effs b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
forall a. Maybe a
Nothing
      -- No script involved, and no particular collateral option provided
      (Bool
True, CollateralUtxos
CollateralUtxosFromBalancingUser) -> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
forall a. Maybe a
Nothing
      -- Some scripts involved, and a specific set of UTxOs, alongside a
      -- collateral user provided. In this case, we just return them.
      (Bool
False, CollateralUtxosFromSet Set TxOutRef
utxos pkh
rUser) -> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
 -> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)))
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a b. (a -> b) -> a -> b
$ (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
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)
      -- Some scripts involved, and a specific collateral user provided.
      -- We fetch vanilla UTxOs from this user and return them.
      (Bool
False, CollateralUtxosFromUser (pkh -> PubKeyHash
forall a. ToPubKeyHash a => a -> PubKeyHash
Script.toPubKeyHash -> PubKeyHash
cUser)) ->
        (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
forall a. a -> Maybe a
Just ((Set TxOutRef, User 'IsPubKey 'Allocation)
 -> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
-> ([TxOutRef] -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> [TxOutRef]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,PubKeyHash -> User 'IsPubKey 'Allocation
forall pkh (a :: UserKind) (b :: UserMode).
(a ∈ '[ 'IsPubKey, 'IsEither], ToPubKeyHash pkh, Typeable pkh) =>
pkh -> User a b
UserPubKey PubKeyHash
cUser) (Set TxOutRef -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> ([TxOutRef] -> Set TxOutRef)
-> [TxOutRef]
-> (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] -> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
-> Sem effs [TxOutRef]
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem effs (UtxoSearchResult NoIx) -> Sem effs [TxOutRef]
forall (effs :: EffectRow) (elems :: IxList).
Sem effs (UtxoSearchResult elems) -> Sem effs [TxOutRef]
getTxOutRefs (PubKeyHash
-> (Sem effs (UtxoSearchResult NoIx)
    -> Sem effs (UtxoSearchResult NoIx))
-> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow) pkh (els :: IxList).
(Member MockChainRead effs, ToCredential pkh) =>
pkh
-> (UtxoSearch effs NoIx -> UtxoSearch effs els)
-> UtxoSearch effs els
utxosAtSearch PubKeyHash
cUser Sem effs (UtxoSearchResult NoIx)
-> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow) (els :: IxList).
UtxoSearch effs els -> UtxoSearch effs els
ensureOnlyValueOutputs)
      -- Some scripts involved, and no specific collateral options provided.
      (Bool
False, CollateralUtxos
CollateralUtxosFromBalancingUser) -> case Maybe (User 'IsPubKey 'Allocation)
balancingUser of
        -- If no balancing wallet exists, we throw an error
        Maybe (User 'IsPubKey 'Allocation)
Nothing -> MockChainError
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MockChainError
 -> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)))
-> MockChainError
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall a b. (a -> b) -> a -> b
$ BalancingError -> MockChainError
MCEBalancingError BalancingError
MissingBalancingUser
        -- If a balancing wallet exists, we use it as collateral user
        Just User 'IsPubKey 'Allocation
bUser -> (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
forall a. a -> Maybe a
Just ((Set TxOutRef, User 'IsPubKey 'Allocation)
 -> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
-> ([TxOutRef] -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> [TxOutRef]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,User 'IsPubKey 'Allocation
bUser) (Set TxOutRef -> (Set TxOutRef, User 'IsPubKey 'Allocation))
-> ([TxOutRef] -> Set TxOutRef)
-> [TxOutRef]
-> (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] -> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
-> Sem effs [TxOutRef]
-> Sem effs (Maybe (Set TxOutRef, User 'IsPubKey 'Allocation))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem effs (UtxoSearchResult NoIx) -> Sem effs [TxOutRef]
forall (effs :: EffectRow) (elems :: IxList).
Sem effs (UtxoSearchResult elems) -> Sem effs [TxOutRef]
getTxOutRefs (User 'IsPubKey 'Allocation
-> (Sem effs (UtxoSearchResult NoIx)
    -> Sem effs (UtxoSearchResult NoIx))
-> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow) pkh (els :: IxList).
(Member MockChainRead effs, ToCredential pkh) =>
pkh
-> (UtxoSearch effs NoIx -> UtxoSearch effs els)
-> UtxoSearch effs els
utxosAtSearch User 'IsPubKey 'Allocation
bUser Sem effs (UtxoSearchResult NoIx)
-> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow) (els :: IxList).
UtxoSearch effs els -> UtxoSearch effs els
ensureOnlyValueOutputs)

  -- At this point, the presence (or absence) of balancing user dictates
  -- whether the transaction should be automatically balanced or not.
  case Maybe (User 'IsPubKey 'Allocation)
balancingUser of
    Maybe (User 'IsPubKey 'Allocation)
Nothing -> do
      -- 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'
      Maybe Collaterals
mCols <- Fee
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe Collaterals)
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
Fee
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe Collaterals)
collateralsFromFee Fee
fee Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals
      Body
cBody <- TxSkel -> Fee -> Maybe Collaterals -> Sem effs Body
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
TxSkel -> Fee -> Maybe Collaterals -> Sem effs Body
txSkelToTxBody TxSkel
skelUnbal Fee
fee Maybe Collaterals
mCols
      ExtendedTxSkel -> Sem effs ExtendedTxSkel
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtendedTxSkel -> Sem effs ExtendedTxSkel)
-> ExtendedTxSkel -> Sem effs ExtendedTxSkel
forall a b. (a -> b) -> a -> b
$ TxSkel -> Fee -> Maybe Collaterals -> Body -> ExtendedTxSkel
ExtendedTxSkel TxSkel
skelUnbal Fee
fee Maybe Collaterals
mCols Body
cBody
    Just User 'IsPubKey 'Allocation
bUser -> do
      -- The balancing should be performed. We collect the candidates balancing
      -- utxos based on the associated policy
      [Utxo]
balancingUtxos <-
        case TxSkelOpts -> BalancingUtxos
txSkelOptBalancingUtxos TxSkelOpts
txSkelOpts of
          BalancingUtxos
BalancingUtxosFromBalancingUser -> Sem effs (UtxoSearchResult NoIx) -> Sem effs [Utxo]
forall (effs :: EffectRow) (elems :: IxList).
Sem effs (UtxoSearchResult elems) -> Sem effs [Utxo]
getTxOutRefsAndOutputs (Sem effs (UtxoSearchResult NoIx) -> Sem effs [Utxo])
-> Sem effs (UtxoSearchResult NoIx) -> Sem effs [Utxo]
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation
-> (Sem effs (UtxoSearchResult NoIx)
    -> Sem effs (UtxoSearchResult NoIx))
-> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow) pkh (els :: IxList).
(Member MockChainRead effs, ToCredential pkh) =>
pkh
-> (UtxoSearch effs NoIx -> UtxoSearch effs els)
-> UtxoSearch effs els
utxosAtSearch User 'IsPubKey 'Allocation
bUser Sem effs (UtxoSearchResult NoIx)
-> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow) (els :: IxList).
UtxoSearch effs els -> UtxoSearch effs els
ensureOnlyValueOutputs
          BalancingUtxosFromSet Set TxOutRef
utxos ->
            -- We resolve the given set of utxos
            Sem effs (UtxoSearchResult NoIx) -> Sem effs [Utxo]
forall (effs :: EffectRow) (elems :: IxList).
Sem effs (UtxoSearchResult elems) -> Sem effs [Utxo]
getTxOutRefsAndOutputs ([TxOutRef] -> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow).
Member MockChainRead effs =>
[TxOutRef] -> UtxoSearch effs NoIx
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.
              Sem effs [Utxo] -> ([Utxo] -> Sem effs [Utxo]) -> Sem effs [Utxo]
forall a b. Sem effs a -> (a -> Sem effs b) -> Sem effs b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Utxo -> Bool) -> String -> [Utxo] -> Sem effs [Utxo]
forall {effs :: EffectRow} {a}.
Member MockChainLog effs =>
(a -> Bool) -> String -> [a] -> Sem effs [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) -> (Utxo -> TxSkelOut) -> Utxo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utxo -> 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
          Sem effs [Utxo] -> ([Utxo] -> Sem effs [Utxo]) -> Sem effs [Utxo]
forall a b. Sem effs a -> (a -> Sem effs b) -> Sem effs b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Utxo -> Bool) -> String -> [Utxo] -> Sem effs [Utxo]
forall {effs :: EffectRow} {a}.
Member MockChainLog effs =>
(a -> Bool) -> String -> [a] -> Sem effs [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) -> (Utxo -> TxOutRef) -> Utxo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utxo -> 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
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
computeFeeAndBalance User 'IsPubKey 'Allocation
bUser Fee
minFee Fee
maxFee [Utxo]
balancingUtxos Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals TxSkel
skelUnbal
        -- If fee are provided manually, we adjust the collaterals and the
        -- skeleton around them directly.
        ManualFee Fee
fee -> do
          Maybe Collaterals
mCols <- Fee
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe Collaterals)
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
Fee
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe Collaterals)
collateralsFromFee Fee
fee Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals
          TxSkel
balancedSkel <- User 'IsPubKey 'Allocation
-> [Utxo] -> TxSkel -> Fee -> Sem effs TxSkel
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
User 'IsPubKey 'Allocation
-> [Utxo] -> TxSkel -> Fee -> Sem effs TxSkel
computeBalancedTxSkel User 'IsPubKey 'Allocation
bUser [Utxo]
balancingUtxos TxSkel
skelUnbal Fee
fee
          Body
cBody <- TxSkel -> Fee -> Maybe Collaterals -> Sem effs Body
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
TxSkel -> Fee -> Maybe Collaterals -> Sem effs Body
txSkelToTxBody TxSkel
balancedSkel Fee
fee Maybe Collaterals
mCols
          ExtendedTxSkel -> Sem effs ExtendedTxSkel
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtendedTxSkel -> Sem effs ExtendedTxSkel)
-> ExtendedTxSkel -> Sem effs ExtendedTxSkel
forall a b. (a -> b) -> a -> b
$ TxSkel -> Fee -> Maybe Collaterals -> Body -> ExtendedTxSkel
ExtendedTxSkel TxSkel
balancedSkel Fee
fee Maybe Collaterals
mCols Body
cBody
  where
    filterAndWarn :: (a -> Bool) -> String -> [a] -> Sem effs [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 -> Sem effs () -> Sem effs ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Fee
koLength Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
0) (MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
logEvent (MockChainLogEntry -> Sem effs ())
-> MockChainLogEntry -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ Fee -> String -> MockChainLogEntry
MCLogDiscardedUtxos Fee
koLength String
s) Sem effs () -> Sem effs [a] -> Sem effs [a]
forall a b. Sem effs a -> Sem effs b -> Sem effs b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> Sem effs [a]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ok

-- | 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 ::
  (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) =>
  Peer ->
  Fee ->
  Fee ->
  Utxos ->
  Maybe (CollateralIns, Peer) ->
  TxSkel ->
  Sem effs ExtendedTxSkel
computeFeeAndBalance :: forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
computeFeeAndBalance User 'IsPubKey 'Allocation
_ Fee
minFee Fee
maxFee [Utxo]
_ Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
_ TxSkel
_
  | Fee
minFee Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
> Fee
maxFee =
      String -> Sem effs ExtendedTxSkel
forall a. String -> Sem effs a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unreachable case, please report a bug at https://github.com/tweag/cooked-validators/issues"
computeFeeAndBalance User 'IsPubKey 'Allocation
balancingUser Fee
minFee Fee
maxFee [Utxo]
balancingUtxos Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals TxSkel
skel = do
  let fee :: 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
  -- The fee interval is non-empty. We attempt to balance around its central
  -- point, and handle possible failures.
  Sem effs ExtendedTxSkel
-> (MockChainError -> Sem effs ExtendedTxSkel)
-> Sem effs ExtendedTxSkel
forall e (r :: EffectRow) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
catch
    ( do
        TxSkel
newSkel <- User 'IsPubKey 'Allocation
-> [Utxo] -> TxSkel -> Fee -> Sem effs TxSkel
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
User 'IsPubKey 'Allocation
-> [Utxo] -> TxSkel -> Fee -> Sem effs TxSkel
computeBalancedTxSkel User 'IsPubKey 'Allocation
balancingUser [Utxo]
balancingUtxos TxSkel
skel Fee
fee
        Maybe Collaterals
mCols <- Fee
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe Collaterals)
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
Fee
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe Collaterals)
collateralsFromFee Fee
fee Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals
        (Fee
newFee, Body
body) <- TxSkel -> Fee -> Maybe Collaterals -> Sem effs (Fee, Body)
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
TxSkel -> Fee -> Maybe Collaterals -> Sem effs (Fee, Body)
estimateTxSkelFee TxSkel
newSkel Fee
fee Maybe Collaterals
mCols
        if
          -- The skeleton was balanceable, we cannot try smaller fee, but
          -- the used fee is sufficient for the generated body
          | Fee
minFee Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
maxFee Bool -> Bool -> Bool
&& Fee
newFee Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
<= Fee
fee -> ExtendedTxSkel -> Sem effs ExtendedTxSkel
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtendedTxSkel -> Sem effs ExtendedTxSkel)
-> ExtendedTxSkel -> Sem effs ExtendedTxSkel
forall a b. (a -> b) -> a -> b
$ TxSkel -> Fee -> Maybe Collaterals -> Body -> ExtendedTxSkel
ExtendedTxSkel TxSkel
newSkel Fee
newFee Maybe Collaterals
mCols Body
body
          -- The skeleton was balanceable, we cannot try smaller fee, but
          -- the used fee is insufficient for the generated body
          | Fee
minFee Fee -> Fee -> Bool
forall a. Eq a => a -> a -> Bool
== Fee
maxFee -> MockChainError -> Sem effs ExtendedTxSkel
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MockChainError -> Sem effs ExtendedTxSkel)
-> MockChainError -> Sem effs ExtendedTxSkel
forall a b. (a -> b) -> a -> b
$ BalancingError -> MockChainError
MCEBalancingError (BalancingError -> MockChainError)
-> BalancingError -> MockChainError
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation -> BalancingError
NotEnoughFundForProperFee User 'IsPubKey 'Allocation
balancingUser
          -- Current fee is insufficient, we look on the right (strictly)
          | Fee
newFee Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
> Fee
fee -> User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
computeFeeAndBalance User 'IsPubKey 'Allocation
balancingUser Fee
newFee Fee
maxFee [Utxo]
balancingUtxos Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals TxSkel
skel
          -- 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 cannot speed up search.
          | TxSkel -> Value
txSkelValueInOutputs TxSkel
newSkel Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== TxSkel -> Value
txSkelValueInOutputs TxSkel
skel -> User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
computeFeeAndBalance User 'IsPubKey 'Allocation
balancingUser Fee
minFee Fee
fee [Utxo]
balancingUtxos Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals TxSkel
skel
          -- 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.
          | Bool
otherwise -> User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
computeFeeAndBalance User 'IsPubKey 'Allocation
balancingUser Fee
minFee Fee
newFee [Utxo]
balancingUtxos Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals TxSkel
skel
    )
    ((MockChainError -> Sem effs ExtendedTxSkel)
 -> Sem effs ExtendedTxSkel)
-> (MockChainError -> Sem effs ExtendedTxSkel)
-> Sem effs ExtendedTxSkel
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 can still hope for a solution by trying with
      -- smaller fee.
      MCEBalancingError {} | Fee
fee Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
> Fee
minFee -> User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
User 'IsPubKey 'Allocation
-> Fee
-> Fee
-> [Utxo]
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> TxSkel
-> Sem effs ExtendedTxSkel
computeFeeAndBalance User 'IsPubKey 'Allocation
balancingUser Fee
minFee (Fee
fee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
1) [Utxo]
balancingUtxos Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
mCollaterals TxSkel
skel
      -- Otherwise, the whole balancing process fails and we spread the error:
      -- the skeleton was not balanceable.
      MockChainError
err -> MockChainError -> Sem effs ExtendedTxSkel
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw MockChainError
err

-- | 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.
collateralsFromFee ::
  (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) =>
  -- | The fee from which these collaterals should be computed
  Fee ->
  -- | The optional candidate UTxOs to be used as collaterals, alongside the
  -- peer who should receive the return collateral output
  Maybe (CollateralIns, Peer) ->
  -- | Returns the collaterals computed from the above. Raises an error if no
  -- such collateral can be found.
  Sem effs (Maybe Collaterals)
collateralsFromFee :: forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
Fee
-> Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
-> Sem effs (Maybe Collaterals)
collateralsFromFee Fee
_ Maybe (Set TxOutRef, User 'IsPubKey 'Allocation)
Nothing = Maybe Collaterals -> Sem effs (Maybe Collaterals)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Collaterals
forall a. Maybe a
Nothing
collateralsFromFee Fee
fee (Just (Set TxOutRef
collateralIns, User 'IsPubKey 'Allocation
returnCollateralUser)) = do
  -- We retrieve the protocal parameters
  PParams
params <- Params -> PParams
Emulator.pEmulatorPParams (Params -> PParams) -> Sem effs Params -> Sem effs PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem effs Params
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs 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
  [Utxo]
collateralTxOuts <- Sem effs (UtxoSearchResult NoIx) -> Sem effs [Utxo]
forall (effs :: EffectRow) (elems :: IxList).
Sem effs (UtxoSearchResult elems) -> Sem effs [Utxo]
getTxOutRefsAndOutputs (Sem effs (UtxoSearchResult NoIx) -> Sem effs [Utxo])
-> Sem effs (UtxoSearchResult NoIx) -> Sem effs [Utxo]
forall a b. (a -> b) -> a -> b
$ [TxOutRef] -> Sem effs (UtxoSearchResult NoIx)
forall (effs :: EffectRow).
Member MockChainRead effs =>
[TxOutRef] -> UtxoSearch effs NoIx
txSkelOutByRefSearch' ([TxOutRef] -> Sem effs (UtxoSearchResult NoIx))
-> [TxOutRef] -> Sem effs (UtxoSearchResult NoIx)
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
  Maybe ([TxOutRef], Maybe TxSkelOut)
reachedValue <- [Utxo]
-> Value
-> Fee
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut))
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
[Utxo]
-> Value
-> Fee
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut))
reachValue [Utxo]
collateralTxOuts Value
totalCollateral Fee
nbMax (Either TxSkelOut (User 'IsPubKey 'Allocation)
 -> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut)))
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut))
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
forall a b. b -> Either a b
Right User 'IsPubKey 'Allocation
returnCollateralUser
  -- A value might, or might not have been reached
  case Maybe ([TxOutRef], Maybe TxSkelOut)
reachedValue of
    -- If no value was reached, the input UTxOs are insufficient to provide
    -- the necessary collaterals, and thus an error is raised
    Maybe ([TxOutRef], Maybe TxSkelOut)
Nothing -> MockChainError -> Sem effs (Maybe Collaterals)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MockChainError -> Sem effs (Maybe Collaterals))
-> MockChainError -> Sem effs (Maybe Collaterals)
forall a b. (a -> b) -> a -> b
$ BalancingError -> MockChainError
MCEBalancingError (BalancingError -> MockChainError)
-> BalancingError -> MockChainError
forall a b. (a -> b) -> a -> b
$ Fee -> Fee -> Value -> BalancingError
NoSuitableCollateral Fee
fee Fee
percentage Value
totalCollateral
    -- If a value was reached, we return it alongside the return collaterals
    Just ([TxOutRef]
oRefs, Maybe TxSkelOut
returnOutput) -> Maybe Collaterals -> Sem effs (Maybe Collaterals)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Collaterals -> Sem effs (Maybe Collaterals))
-> Maybe Collaterals -> Sem effs (Maybe Collaterals)
forall a b. (a -> b) -> a -> b
$ Collaterals -> Maybe Collaterals
forall a. a -> Maybe a
Just ([TxOutRef] -> Set TxOutRef
forall a. Ord a => [a] -> Set a
Set.fromList [TxOutRef]
oRefs, Maybe TxSkelOut
returnOutput)

reachValue ::
  forall effs.
  (Members '[MockChainRead, Error Ledger.ToCardanoError] effs) =>
  -- | The Utxos available to reach the value
  Utxos ->
  -- | The target value to reach
  Api.Value ->
  -- | The maximum number of Utxos allowed to reach the target. This is used
  -- when there is a hard limit (for collaterals for instance) or when the
  -- amount of input UTxOs is huge and thus the search needs to be limited.
  Integer ->
  -- | Either the output to which the generated surplus needs to be attached, or
  -- the users to which this surplus should be sent
  Either TxSkelOut Peer ->
  -- | Returns a possible solution. The solution is a list of new inputs, and
  -- the surplus output, which is either built from scratch or from the provided
  -- surplus output, if any.
  Sem effs (Maybe ([Api.TxOutRef], Maybe TxSkelOut))
reachValue :: forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
[Utxo]
-> Value
-> Fee
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut))
reachValue [Utxo]
utxos Value
target Fee
fuel Either TxSkelOut (User 'IsPubKey 'Allocation)
outputOrUser = do
  -- We retrieve the current protocol version, which is going to be used to
  -- compute the size of the inputs and outputs added by this function
  Cardano.ProtVer Version
majorVersion Natural
_ <- Getting ProtVer PParams ProtVer -> PParams -> ProtVer
forall a s. Getting a s a -> s -> a
Micro.view Getting ProtVer PParams ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' PParams ProtVer
Conway.ppProtocolVersionL (PParams -> ProtVer) -> (Params -> PParams) -> Params -> ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> PParams
Emulator.emulatorPParams (Params -> ProtVer) -> Sem effs Params -> Sem effs ProtVer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem effs Params
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs Params
getParams
  -- We annotate @outputOrUser@ with the size of the existing output, if any
  Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
outputOrUser' <- case Either TxSkelOut (User 'IsPubKey 'Allocation)
outputOrUser of
    Left TxSkelOut
output -> (TxSkelOut, Fee)
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
forall a b. a -> Either a b
Left ((TxSkelOut, Fee)
 -> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
-> (Fee -> (TxSkelOut, Fee))
-> Fee
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut
output,) (Fee -> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
-> Sem effs Fee
-> Sem effs (Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> TxSkelOut -> Sem effs Fee
outputSize Version
majorVersion TxSkelOut
output
    Right User 'IsPubKey 'Allocation
user -> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Sem effs (Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
 -> Sem effs (Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)))
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Sem effs (Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
forall a b. (a -> b) -> a -> b
$ User 'IsPubKey 'Allocation
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
forall a b. b -> Either a b
Right User 'IsPubKey 'Allocation
user
  -- We annotate each of the provided inputs with their sizes
  [(TxOutRef, Fee, Value)]
utxos' <- [Utxo]
-> (Utxo -> Sem effs (TxOutRef, Fee, Value))
-> Sem effs [(TxOutRef, Fee, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Utxo]
utxos ((Utxo -> Sem effs (TxOutRef, Fee, Value))
 -> Sem effs [(TxOutRef, Fee, Value)])
-> (Utxo -> Sem effs (TxOutRef, Fee, Value))
-> Sem effs [(TxOutRef, Fee, Value)]
forall a b. (a -> b) -> a -> b
$ \(TxOutRef
oRef, TxSkelOut
output) -> (TxOutRef
oRef,,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
output) (Fee -> (TxOutRef, Fee, Value))
-> Sem effs Fee -> Sem effs (TxOutRef, Fee, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> TxOutRef -> Sem effs Fee
inputSize Version
majorVersion TxOutRef
oRef
  -- We call the main computing function, @go@, by feeding it an initial
  -- available amount, computed from the available inputs. This will avoid any
  -- unnecessary recomputation of this value.
  (([TxOutRef], Maybe TxSkelOut, Fee)
 -> ([TxOutRef], Maybe TxSkelOut))
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Maybe ([TxOutRef], Maybe TxSkelOut)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([TxOutRef]
oRefs, Maybe TxSkelOut
mOut, Fee
_) -> ([TxOutRef]
oRefs, Maybe TxSkelOut
mOut))
    (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
 -> Maybe ([TxOutRef], Maybe TxSkelOut))
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version
-> [(TxOutRef, Fee, Value)]
-> Value
-> Fee
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Value
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
go Version
majorVersion [(TxOutRef, Fee, Value)]
utxos' Value
target Fee
fuel Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
outputOrUser' ([Value] -> Value
forall a. Monoid a => [a] -> a
mconcat ((\(TxOutRef
_, Fee
_, Value
val) -> Value
val) ((TxOutRef, Fee, Value) -> Value)
-> [(TxOutRef, Fee, Value)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TxOutRef, Fee, Value)]
utxos'))
  where
    go ::
      -- Current protocol major version
      Cardano.Version ->
      -- Currently available UTxOs, decreasing in recursive calls
      [(Api.TxOutRef, Integer, Api.Value)] ->
      -- Target value
      Api.Value ->
      -- Fuel (max number of UTxOs to pick)
      Integer ->
      -- Existing output where the surplus needs to be appended, or the peer
      -- to whom this surplus should be paid
      Either (TxSkelOut, Integer) Peer ->
      -- Total value of the available inputs
      Api.Value ->
      -- Returns a solution when one exists. This solution contains the inputs
      -- to add, the possible surplus payment and the total size added by these
      -- elements to the transaction.
      Sem effs (Maybe ([Api.TxOutRef], Maybe TxSkelOut, Integer))
    -- The target is reached. There might be surplus which we have to handle.
    go :: Version
-> [(TxOutRef, Fee, Value)]
-> Value
-> Fee
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Value
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
go Version
majorVersion [(TxOutRef, Fee, Value)]
goUtxos Value
goTarget Fee
goFuel Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser Value
goAvailable | Value
goTarget Value -> Value -> Bool
`Api.leq` Value
forall a. Monoid a => a
mempty = do
      let remainder :: Value
remainder = Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
goTarget
          newOutput :: TxSkelOut
newOutput = ((TxSkelOut, Fee) -> TxSkelOut)
-> (User 'IsPubKey 'Allocation -> TxSkelOut)
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> TxSkelOut
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Optic' A_Lens NoIx TxSkelOut Value
-> (Value -> Value) -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
remainder) (TxSkelOut -> TxSkelOut)
-> ((TxSkelOut, Fee) -> TxSkelOut) -> (TxSkelOut, Fee) -> TxSkelOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut, Fee) -> TxSkelOut
forall a b. (a, b) -> a
fst) (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
remainder) Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser
          newOutputValue :: Value
newOutputValue = 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
newOutput
      Lovelace
minAda <- Fee -> Lovelace
Api.Lovelace (Fee -> Lovelace) -> Sem effs Fee -> Sem effs Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkelOut -> Sem effs Fee
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs Fee
getTxSkelOutMinAda TxSkelOut
newOutput
      case Value
newOutputValue of
        -- There is no surplus
        Value
newVal | Value
newVal Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty -> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
 -> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)))
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a b. (a -> b) -> a -> b
$ ([TxOutRef], Maybe TxSkelOut, Fee)
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall a. a -> Maybe a
Just ([], Maybe TxSkelOut
forall a. Maybe a
Nothing, Fee
0)
        -- There is a surplus and it contains enough ADA
        Value
newVal | Optic' A_Lens NoIx Value Lovelace -> Value -> Lovelace
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Value Lovelace
valueLovelaceL Value
newVal Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Lovelace
minAda -> do
          -- We compute the cost of the new output
          Fee
newCost <- Version -> TxSkelOut -> Sem effs Fee
outputSize Version
majorVersion TxSkelOut
newOutput
          -- And compare it with the cost of the existing output
          Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
 -> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)))
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a b. (a -> b) -> a -> b
$ ([TxOutRef], Maybe TxSkelOut, Fee)
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall a. a -> Maybe a
Just ([], TxSkelOut -> Maybe TxSkelOut
forall a. a -> Maybe a
Just TxSkelOut
newOutput, ((TxSkelOut, Fee) -> Fee)
-> (User 'IsPubKey 'Allocation -> Fee)
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Fee
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((Fee
newCost Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
-) (Fee -> Fee)
-> ((TxSkelOut, Fee) -> Fee) -> (TxSkelOut, Fee) -> Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut, Fee) -> Fee
forall a b. (a, b) -> b
snd) (Fee -> User 'IsPubKey 'Allocation -> Fee
forall a b. a -> b -> a
const Fee
newCost) Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser)
        -- There is a surplus which does not contain enough ADA
        (Lovelace -> Value
forall a. ToValue a => a -> Value
Script.toValue (Lovelace -> Value) -> (Value -> Lovelace) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lovelace
minAda Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
-) (Lovelace -> Lovelace) -> (Value -> Lovelace) -> Value -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' A_Lens NoIx Value Lovelace -> Value -> Lovelace
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx Value Lovelace
valueLovelaceL -> Value
missingAdaValue) -> do
          -- We need to run a new search with a target increased by the missing
          -- amount of ADA. For that purpose, we also need to increase the
          -- surplus payment with the same amout, to keep everything balanced.
          -- As a consequence, we also need to add bytes to the transaction.
          (Fee
sizeAdded, Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser') <- case Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser of
            -- If the surplus already exist, we add @missingAdaValue@ to it
            Left (TxSkelOut
output, Fee
existingSize) -> do
              let enlargedOutput :: TxSkelOut
enlargedOutput = Optic' A_Lens NoIx TxSkelOut Value
-> (Value -> Value) -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingAdaValue) TxSkelOut
output
              Fee
newSize <- Version -> TxSkelOut -> Sem effs Fee
outputSize Version
majorVersion TxSkelOut
enlargedOutput
              (Fee, Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
-> Sem
     effs (Fee, Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fee
newSize Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
existingSize, (TxSkelOut, Fee)
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
forall a b. a -> Either a b
Left (TxSkelOut
enlargedOutput, Fee
newSize))
            -- If it does not, we create it and couple it with its size
            Right User 'IsPubKey 'Allocation
user -> do
              let output :: TxSkelOut
output = User 'IsPubKey 'Allocation
user 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
missingAdaValue
              Fee
size <- Version -> TxSkelOut -> Sem effs Fee
outputSize Version
majorVersion TxSkelOut
output
              (Fee, Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
-> Sem
     effs (Fee, Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fee
size, (TxSkelOut, Fee)
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
forall a b. a -> Either a b
Left (TxSkelOut
output, Fee
size))
          -- We keep looking with a greater target, surplus and size
          Optic
  An_AffineTraversal
  NoIx
  (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
  (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
  Fee
  Fee
-> (Fee -> Fee)
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over (Prism
  (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
  (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
  ([TxOutRef], Maybe TxSkelOut, Fee)
  ([TxOutRef], Maybe TxSkelOut, Fee)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism
  (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
  (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
  ([TxOutRef], Maybe TxSkelOut, Fee)
  ([TxOutRef], Maybe TxSkelOut, Fee)
-> Optic
     A_Lens
     NoIx
     ([TxOutRef], Maybe TxSkelOut, Fee)
     ([TxOutRef], Maybe TxSkelOut, Fee)
     Fee
     Fee
-> Optic
     An_AffineTraversal
     NoIx
     (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
     (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
     Fee
     Fee
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
  ([TxOutRef], Maybe TxSkelOut, Fee)
  ([TxOutRef], Maybe TxSkelOut, Fee)
  Fee
  Fee
forall s t a b. Field3 s t a b => Lens s t a b
_3) (Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
sizeAdded)
            (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
 -> Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version
-> [(TxOutRef, Fee, Value)]
-> Value
-> Fee
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Value
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
go Version
majorVersion [(TxOutRef, Fee, Value)]
goUtxos (Value
goTarget Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingAdaValue) Fee
goFuel Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser' Value
goAvailable
    -- We have not reached a solution, but we don't have fuel anymore
    go Version
_ [(TxOutRef, Fee, Value)]
_ Value
_ Fee
goFuel Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
_ Value
_ | Fee
goFuel Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
<= Fee
0 = Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall a. Maybe a
Nothing
    -- We have not reached a soultion, but no more UTxOs are available
    go Version
_ [] Value
_ Fee
_ Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
_ Value
_ = Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall a. Maybe a
Nothing
    -- We have not reached a solution, but the total available value is
    -- insufficient to ever find one
    go Version
_ [(TxOutRef, Fee, Value)]
_ Value
goTarget Fee
_ Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
_ Value
goAvailable | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Value
goTarget Value -> Value -> Bool
`Api.leq` Value
goAvailable = Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall a. Maybe a
Nothing
    -- We have not yet found a solution, but there are still available UTxOs
    go Version
majorVersion ((TxOutRef
hOref, Fee
hSize, Value
hValue) : [(TxOutRef, Fee, Value)]
t) Value
goTarget Fee
goFuel Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser ((Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
hValue) -> Value
goAvailable) = do
      -- We try to find a solution by dropping the head
      Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
dropH <- Version
-> [(TxOutRef, Fee, Value)]
-> Value
-> Fee
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Value
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
go Version
majorVersion [(TxOutRef, Fee, Value)]
t Value
goTarget Fee
goFuel Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser Value
goAvailable
      -- We also try to find a solution by picking the head
      Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
pickH <-
        -- We try to see if the head contributes to reaching the value, i.e. if
        -- it contains assets that help building towards the target.
        if (Value, Value) -> Value
forall a b. (a, b) -> b
snd (Value -> (Value, Value)
Api.split Value
goTarget) Value -> Value -> Value
forall a. MeetSemiLattice a => a -> a -> a
PlutusTx./\ Value
hValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty
          -- If not, we don't bother trying to pick the head
          then Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall a. Maybe a
Nothing
          -- If it does, we actually try to pick the head. This means decreasing
          -- most of the recursive parameters of @go@ accordingly
          else do
            Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
pickH' <- Version
-> [(TxOutRef, Fee, Value)]
-> Value
-> Fee
-> Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
-> Value
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
go Version
majorVersion [(TxOutRef, Fee, Value)]
t (Value
goTarget Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
hValue) (Fee
goFuel Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
- Fee
1) Either (TxSkelOut, Fee) (User 'IsPubKey 'Allocation)
goOutputOrUser Value
goAvailable
            Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
 -> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)))
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a b. (a -> b) -> a -> b
$ (\([TxOutRef]
oRefs, Maybe TxSkelOut
mOut, Fee
size) -> (TxOutRef
hOref TxOutRef -> [TxOutRef] -> [TxOutRef]
forall a. a -> [a] -> [a]
: [TxOutRef]
oRefs, Maybe TxSkelOut
mOut, Fee
hSize Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
size)) (([TxOutRef], Maybe TxSkelOut, Fee)
 -> ([TxOutRef], Maybe TxSkelOut, Fee))
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
pickH'
      -- We find the optimal solution by comparing both solutions
      Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
 -> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)))
-> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut, Fee))
forall a b. (a -> b) -> a -> b
$ case (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
dropH, Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
pickH) of
        -- Only picking the head yielded a solution, we return it
        (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
Nothing, Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
_) -> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
pickH
        -- Only dropping the head yielded a solution, we return it
        (Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
_, Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
Nothing) -> Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
dropH
        -- Both pickding and dropping the head yielded a solution, so we keep
        -- the one that produces the least increase in the transaction size
        (Just ([TxOutRef]
_, Maybe TxSkelOut
_, Fee
sizeDrop), Just ([TxOutRef]
_, Maybe TxSkelOut
_, Fee
sizePick)) -> if Fee
sizeDrop Fee -> Fee -> Bool
forall a. Ord a => a -> a -> Bool
<= Fee
sizePick then Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
dropH else Maybe ([TxOutRef], Maybe TxSkelOut, Fee)
pickH

    -- This computes the size of anything that can be serialized
    computeSize :: Version -> a -> c
computeSize Version
majorVersion = Int -> c
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> c) -> (a -> Int) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length (ByteString -> Int) -> (a -> ByteString) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> a -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
Cardano.serialize' Version
majorVersion

    -- This computes the size of a `TxSkelOut`
    outputSize :: Cardano.Version -> TxSkelOut -> Sem effs Integer
    outputSize :: Version -> TxSkelOut -> Sem effs Fee
outputSize Version
majorVersion = (TxOut CtxTx ConwayEra -> Fee)
-> Sem effs (TxOut CtxTx ConwayEra) -> Sem effs Fee
forall a b. (a -> b) -> Sem effs a -> Sem effs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version -> BabbageTxOut EmulatorEra -> Fee
forall {c} {a}. (Num c, EncCBOR a) => Version -> a -> c
computeSize Version
majorVersion (BabbageTxOut EmulatorEra -> Fee)
-> (TxOut CtxTx ConwayEra -> BabbageTxOut EmulatorEra)
-> TxOut CtxTx ConwayEra
-> Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra ConwayEra
-> TxOut CtxTx ConwayEra -> TxOut EmulatorEra
forall ctx era ledgerera.
(HasCallStack, ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut ctx era -> TxOut ledgerera
Cardano.toShelleyTxOutAny ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway) (Sem effs (TxOut CtxTx ConwayEra) -> Sem effs Fee)
-> (TxSkelOut -> Sem effs (TxOut CtxTx ConwayEra))
-> TxSkelOut
-> Sem effs Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSkelOut -> Sem effs (TxOut CtxTx ConwayEra)
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs (TxOut CtxTx ConwayEra)
toCardanoTxOut

    -- This computes the size of an `Api.TxOutRef` which is almost always
    -- gonna be the same, but can theoretically vary if coming from a
    -- transaction with many outputs.
    inputSize :: Cardano.Version -> Api.TxOutRef -> Sem effs Integer
    inputSize :: Version -> TxOutRef -> Sem effs Fee
inputSize Version
majorVersion = (TxIn -> Fee) -> Sem effs TxIn -> Sem effs Fee
forall a b. (a -> b) -> Sem effs a -> Sem effs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version -> TxIn -> Fee
forall {c} {a}. (Num c, EncCBOR a) => Version -> a -> c
computeSize Version
majorVersion (TxIn -> Fee) -> (TxIn -> TxIn) -> TxIn -> Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> TxIn
Cardano.toShelleyTxIn) (Sem effs TxIn -> Sem effs Fee)
-> (TxOutRef -> Sem effs TxIn) -> TxOutRef -> Sem effs Fee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ToCardanoError TxIn -> Sem effs TxIn
forall e (r :: EffectRow) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither (Either ToCardanoError TxIn -> Sem effs TxIn)
-> (TxOutRef -> Either ToCardanoError TxIn)
-> TxOutRef
-> Sem effs TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> Either ToCardanoError TxIn
Ledger.toCardanoTxIn

-- | Estimates the required fee for a given skeleton with a given initial fee
-- and collaterals
estimateTxSkelFee ::
  (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError, Fail] effs) =>
  TxSkel ->
  Fee ->
  Maybe Collaterals ->
  Sem effs (Fee, Body)
estimateTxSkelFee :: forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
TxSkel -> Fee -> Maybe Collaterals -> Sem effs (Fee, Body)
estimateTxSkelFee TxSkel
skel Fee
fee Maybe Collaterals
mCollaterals = do
  -- We retrieve the necessary data to generate the transaction body
  PParams
params <- Params -> PParams
Emulator.pEmulatorPParams (Params -> PParams) -> Sem effs Params -> Sem effs PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem effs Params
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs Params
getParams
  -- We build the index known to the skeleton
  UTxO ConwayEra
index <- TxSkel -> Maybe Collaterals -> Sem effs (UTxO ConwayEra)
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkel -> Maybe Collaterals -> Sem effs (UTxO ConwayEra)
txSkelToIndex TxSkel
skel Maybe Collaterals
mCollaterals
  -- We build the transaction body
  Body
txBody <- TxSkel -> Fee -> Maybe Collaterals -> Sem effs Body
forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError, Fail]
  effs =>
TxSkel -> Fee -> Maybe Collaterals -> Sem effs Body
txSkelToTxBody TxSkel
skel Fee
fee Maybe Collaterals
mCollaterals
  -- We retrieve the amount of signatories
  let nbOfSignatories :: Word
nbOfSignatories = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ [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
  -- We compute the estimated fee
  let Cardano.Coin Fee
newFee = ShelleyBasedEra ConwayEra
-> PParams (ShelleyLedgerEra ConwayEra)
-> UTxO ConwayEra
-> Body
-> Word
-> Coin
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era)
-> UTxO era
-> TxBody era
-> Word
-> Coin
Cardano.calculateMinTxFee ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway PParams (ShelleyLedgerEra ConwayEra)
PParams
params UTxO ConwayEra
index Body
txBody Word
nbOfSignatories
  -- We return both the new fee and generated body
  (Fee, Body) -> Sem effs (Fee, Body)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fee
newFee, Body
txBody)

-- | 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 ::
  (Members '[MockChainRead, Error MockChainError, Error Ledger.ToCardanoError] effs) =>
  Peer ->
  Utxos ->
  TxSkel ->
  Fee ->
  Sem effs TxSkel
computeBalancedTxSkel :: forall (effs :: EffectRow).
Members
  '[MockChainRead, Error MockChainError, Error ToCardanoError]
  effs =>
User 'IsPubKey 'Allocation
-> [Utxo] -> TxSkel -> Fee -> Sem effs TxSkel
computeBalancedTxSkel User 'IsPubKey 'Allocation
balancingUser [Utxo]
balancingUtxos txSkel :: TxSkel
txSkel@TxSkel {[TxSkelSignatory]
[TxSkelProposal]
[TxSkelCertificate]
[TxSkelOut]
Set TxOutRef
Set TxSkelLabel
Map TxOutRef TxSkelRedeemer
SlotRange
TxSkelOpts
TxSkelWithdrawals
TxSkelMints
txSkelLabels :: 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]
txSkelLabels :: 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 -> Sem effs Value
forall (effs :: EffectRow).
Member MockChainRead effs =>
TxSkel -> Sem effs Value
txSkelInputValue TxSkel
txSkel
  Value
certificatesDepositedValue <- Lovelace -> Value
forall a. ToValue a => a -> Value
Script.toValue (Lovelace -> Value) -> Sem effs Lovelace -> Sem effs Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkel -> Sem effs Lovelace
forall (effs :: EffectRow).
Member MockChainRead effs =>
TxSkel -> Sem effs Lovelace
txSkelDepositedValueInCertificates TxSkel
txSkel
  Value
proposalsDepositedValue <- Lovelace -> Value
forall a. ToValue a => a -> Value
Script.toValue (Lovelace -> Value) -> Sem effs Lovelace -> Sem effs Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkel -> Sem effs Lovelace
forall (effs :: EffectRow).
Member MockChainRead effs =>
TxSkel -> Sem effs 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] -> Value
forall a. Monoid a => [a] -> a
mconcat
            [ Value
outValue,
              Value
burnedValue,
              Value
feeValue,
              Value
proposalsDepositedValue,
              Value
certificatesDepositedValue,
              Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
inValue,
              Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
mintedValue,
              Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
withdrawnValue
            ]
  -- We need to account for the possible corner 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'
  -- We compute the possible existing output that will need to be extended by
  -- the extra surplus created by the balancing. This output is created from
  -- both the extra value on the right, and a possible existing output at the
  -- balancing wallet address when required with @AdjustExistingOutput@.
  let surplusOutputOrUser :: Either TxSkelOut (User 'IsPubKey 'Allocation)
surplusOutputOrUser = case TxSkelOpts -> BalanceOutputPolicy
txSkelOptBalanceOutputPolicy TxSkelOpts
txSkelOpts of
        BalanceOutputPolicy
AdjustExistingOutput
          | Just TxSkelOut
txSkelOut <-
              (TxSkelOut -> Bool) -> [TxSkelOut] -> Maybe TxSkelOut
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((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 ->
              TxSkelOut -> Either TxSkelOut (User 'IsPubKey 'Allocation)
forall a b. a -> Either a b
Left (Optic' A_Lens NoIx TxSkelOut Value
-> (Value -> Value) -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic' A_Lens NoIx TxSkelOut Value
txSkelOutValueL (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingRight) TxSkelOut
txSkelOut)
        BalanceOutputPolicy
_ | Value
missingRight Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty -> User 'IsPubKey 'Allocation
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
forall a b. b -> Either a b
Right User 'IsPubKey 'Allocation
balancingUser
        BalanceOutputPolicy
_ -> TxSkelOut -> Either TxSkelOut (User 'IsPubKey 'Allocation)
forall a b. a -> Either a b
Left (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 call the main actual balancing algorithm to fetch missing pieces, and
  -- retrieve the possible solution
  let maxNbOfBalancingUtxos :: Fee
maxNbOfBalancingUtxos = Fee -> Maybe Fee -> Fee
forall a. a -> Maybe a -> a
fromMaybe (Int -> Fee
forall a. Integral a => a -> Fee
toInteger (Int -> Fee) -> Int -> Fee
forall a b. (a -> b) -> a -> b
$ [Utxo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Utxo]
balancingUtxos) (TxSkelOpts -> Maybe Fee
txSkelOptMaxNbOfBalancingUtxos TxSkelOpts
txSkelOpts)
  Maybe ([TxOutRef], Maybe TxSkelOut)
solution <- [Utxo]
-> Value
-> Fee
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut))
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
[Utxo]
-> Value
-> Fee
-> Either TxSkelOut (User 'IsPubKey 'Allocation)
-> Sem effs (Maybe ([TxOutRef], Maybe TxSkelOut))
reachValue [Utxo]
balancingUtxos Value
missingLeft Fee
maxNbOfBalancingUtxos Either TxSkelOut (User 'IsPubKey 'Allocation)
surplusOutputOrUser
  -- Based on the solution, we compute extra inputs and the new output
  ([TxOutRef]
additionalInsTxOutRefs, [TxSkelOut]
newTxSkelOuts) <- case Maybe ([TxOutRef], Maybe TxSkelOut)
solution of
    -- There is no solution with the provided parameters
    Maybe ([TxOutRef], Maybe TxSkelOut)
Nothing -> do
      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) -> (Utxo -> TxSkelOut) -> Utxo -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utxo -> TxSkelOut
forall a b. (a, b) -> b
snd (Utxo -> Value) -> [Utxo] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Utxo]
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
      MockChainError -> Sem effs ([TxOutRef], [TxSkelOut])
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (MockChainError -> Sem effs ([TxOutRef], [TxSkelOut]))
-> MockChainError -> Sem effs ([TxOutRef], [TxSkelOut])
forall a b. (a -> b) -> a -> b
$
        BalancingError -> MockChainError
MCEBalancingError (BalancingError -> MockChainError)
-> BalancingError -> MockChainError
forall a b. (a -> b) -> a -> b
$
          if Value
difference Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty
            then User 'IsPubKey 'Allocation -> BalancingError
NotEnoughFundForExtraMinAda User 'IsPubKey 'Allocation
balancingUser
            else User 'IsPubKey 'Allocation -> Value -> BalancingError
NotEnoughFund User 'IsPubKey 'Allocation
balancingUser Value
difference
    -- There exists a perfect solution, 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]
newORefs, Maybe TxSkelOut
Nothing) -> ([TxOutRef], [TxSkelOut]) -> Sem effs ([TxOutRef], [TxSkelOut])
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxOutRef]
newORefs, [TxSkelOut]
txSkelOuts)
    -- There in an existing output at the owner's address and the balancing
    -- policy allows us to adjust it with additional value.
    Just ([TxOutRef]
newORefs, Just TxSkelOut
newTxSkelOut)
      | BalanceOutputPolicy
AdjustExistingOutput <- TxSkelOpts -> BalanceOutputPolicy
txSkelOptBalanceOutputPolicy TxSkelOpts
txSkelOpts,
        ([TxSkelOut]
before, 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 ->
          ([TxOutRef], [TxSkelOut]) -> Sem effs ([TxOutRef], [TxSkelOut])
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxOutRef]
newORefs, [TxSkelOut]
before [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ (TxSkelOut
newTxSkelOut 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.
    Just ([TxOutRef]
newORefs, Just TxSkelOut
newTxSkelOut) -> ([TxOutRef], [TxSkelOut]) -> Sem effs ([TxOutRef], [TxSkelOut])
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxOutRef]
newORefs, [TxSkelOut]
txSkelOuts [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ [TxSkelOut
newTxSkelOut])
  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 -> Sem effs TxSkel
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (TxSkel -> Sem effs TxSkel) -> TxSkel -> Sem effs 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

-- | This computes the minimum and maximum possible fee a transaction can cost
-- based on the current protocol parameters and its number of scripts.
-- In the Dijsktra era, this will be modified with new protocol parameters.
-- See https://github.com/IntersectMBO/cardano-ledger/blob/master/docs/adr/2024-08-14_009-refscripts-fee-change.md
-- for more information
getMinAndMaxFee ::
  (Members '[MockChainRead] effs) =>
  Integer ->
  Sem effs (Fee, Fee)
getMinAndMaxFee :: forall (effs :: EffectRow).
Members '[MockChainRead] effs =>
Fee -> Sem effs (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) -> Sem effs Params -> Sem effs PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem effs Params
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs 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 txSizeMaxFee :: Fee
txSizeMaxFee = 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 eStepsMaxFee :: Fee
eStepsMaxFee = (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 eMemMaxFee :: Fee
eMemMaxFee = (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 refScriptsMaxFee :: Fee
refScriptsMaxFee = (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) -> Sem effs (Fee, Fee)
forall a. a -> Sem effs 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
txSizeMaxFee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
nbOfScripts Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
* (Fee
eStepsMaxFee Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
eMemMaxFee) Fee -> Fee -> Fee
forall a. Num a => a -> a -> a
+ Fee
refScriptsMaxFee
    )