{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE TypeFamilies       #-}
-- | Calculating transaction fees in the emulator.
module Cardano.Node.Emulator.Fee(
  estimateTransactionFee,
  estimateCardanoBuildTxFee,
  makeAutoBalancedTransaction,
  makeAutoBalancedTransactionWithUtxoProvider,
  utxoProviderFromWalletOutputs,
  BalancingError(..),
  -- * Internals
  selectCoin
) where

import Cardano.Api.Shelley qualified as C
import Cardano.Api.Shelley qualified as C.Api
import Cardano.Ledger.BaseTypes (Globals (systemStart))
import Cardano.Ledger.Core qualified as C.Ledger (Tx)
import Cardano.Ledger.Shelley.API qualified as C.Ledger hiding (Tx)
import Cardano.Node.Emulator.Params (EmulatorEra, PParams, Params (emulatorPParams, pNetworkId), emulatorEraHistory,
                                     emulatorGlobals, pProtocolParams)
import Cardano.Node.Emulator.Validation (CardanoLedgerError, UTxO (..), makeTransactionBody)
import Control.Lens (over, (&))
import Data.Aeson (FromJSON, ToJSON)
import Data.Bifunctor (bimap, first)
import Data.Foldable (fold, foldl', toList)
import Data.List (sortOn, (\\))
import Data.Map qualified as Map
import Data.Maybe (isNothing, listToMaybe)
import Data.Ord (Down (Down))
import GHC.Generics (Generic)
import Ledger.Ada (lovelaceValueOf)
import Ledger.Ada qualified as Ada
import Ledger.Address (CardanoAddress, PaymentPubKeyHash)
import Ledger.Index (UtxoIndex (UtxoIndex), ValidationError (TxOutRefNotFound), ValidationPhase (Phase1), adjustTxOut,
                     minAdaTxOutEstimated)
import Ledger.Tx (ToCardanoError (TxBodyError), Tx, TxOut, TxOutRef)
import Ledger.Tx qualified as Tx
import Ledger.Tx.CardanoAPI (CardanoBuildTx (..), fromPlutusIndex, getCardanoBuildTx, toCardanoFee,
                             toCardanoReturnCollateral, toCardanoTotalCollateral, toCardanoTxBodyContent)
import Ledger.Tx.CardanoAPI qualified as CardanoAPI
import Ledger.Value (Value)
import Ledger.Value qualified as Value
import PlutusTx.Prelude qualified as PlutusTx

estimateTransactionFee
  :: Params
  -> UTxO EmulatorEra
  -> [PaymentPubKeyHash]
  -> Tx
  -> Either CardanoLedgerError Value
estimateTransactionFee :: Params
-> UTxO EmulatorEra
-> [PaymentPubKeyHash]
-> Tx
-> Either CardanoLedgerError Value
estimateTransactionFee Params
params UTxO EmulatorEra
utxo [PaymentPubKeyHash]
requiredSigners Tx
tx = do
  CardanoBuildTx
txBodyContent <- (ToCardanoError -> CardanoLedgerError)
-> Either ToCardanoError CardanoBuildTx
-> Either CardanoLedgerError CardanoBuildTx
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right (Either ToCardanoError CardanoBuildTx
 -> Either CardanoLedgerError CardanoBuildTx)
-> Either ToCardanoError CardanoBuildTx
-> Either CardanoLedgerError CardanoBuildTx
forall a b. (a -> b) -> a -> b
$ NetworkId
-> PParams EmulatorEra
-> [PaymentPubKeyHash]
-> Tx
-> Either ToCardanoError CardanoBuildTx
toCardanoTxBodyContent (Params -> NetworkId
pNetworkId Params
params) (Params -> PParams EmulatorEra
emulatorPParams Params
params) [PaymentPubKeyHash]
requiredSigners Tx
tx
  Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> Either CardanoLedgerError Value
estimateCardanoBuildTxFee Params
params UTxO EmulatorEra
utxo CardanoBuildTx
txBodyContent

estimateCardanoBuildTxFee
  :: Params
  -> UTxO EmulatorEra
  -> CardanoBuildTx
  -> Either CardanoLedgerError Value
estimateCardanoBuildTxFee :: Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> Either CardanoLedgerError Value
estimateCardanoBuildTxFee Params
params UTxO EmulatorEra
utxo CardanoBuildTx
txBodyContent = do
  let nkeys :: Word
nkeys = TxBodyContent BuildTx BabbageEra -> Word
forall era. TxBodyContent BuildTx era -> Word
C.Api.estimateTransactionKeyWitnessCount (CardanoBuildTx -> TxBodyContent BuildTx BabbageEra
getCardanoBuildTx CardanoBuildTx
txBodyContent)
  TxBody BabbageEra
txBody <- Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> Either CardanoLedgerError (TxBody BabbageEra)
makeTransactionBody Params
params UTxO EmulatorEra
utxo CardanoBuildTx
txBodyContent
  case PParams EmulatorEra -> TxBody BabbageEra -> Word -> Lovelace
evaluateTransactionFee (Params -> PParams EmulatorEra
emulatorPParams Params
params) TxBody BabbageEra
txBody Word
nkeys of
    C.Api.Lovelace Integer
fee -> Value -> Either CardanoLedgerError Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either CardanoLedgerError Value)
-> Value -> Either CardanoLedgerError Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
lovelaceValueOf Integer
fee

-- | Creates a balanced transaction by calculating the execution units, the fees and the change,
-- which is assigned to the given address. Only balances Ada.
makeAutoBalancedTransaction
  :: Params
  -> UTxO EmulatorEra -- ^ Just the transaction inputs, not the entire 'UTxO'.
  -> CardanoBuildTx
  -> CardanoAddress -- ^ Change address
  -> Either CardanoLedgerError (C.Api.Tx C.Api.BabbageEra)
makeAutoBalancedTransaction :: Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> CardanoAddress
-> Either CardanoLedgerError (Tx BabbageEra)
makeAutoBalancedTransaction Params
params UTxO EmulatorEra
utxo (CardanoBuildTx TxBodyContent BuildTx BabbageEra
txBodyContent) CardanoAddress
cChangeAddr = (ToCardanoError -> CardanoLedgerError)
-> Either ToCardanoError (Tx BabbageEra)
-> Either CardanoLedgerError (Tx BabbageEra)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right (Either ToCardanoError (Tx BabbageEra)
 -> Either CardanoLedgerError (Tx BabbageEra))
-> Either ToCardanoError (Tx BabbageEra)
-> Either CardanoLedgerError (Tx BabbageEra)
forall a b. (a -> b) -> a -> b
$ do
  -- Compute the change.
  C.Api.BalancedTxBody TxBody BabbageEra
_ TxOut CtxTx BabbageEra
change Lovelace
_ <- (TxBodyErrorAutoBalance -> ToCardanoError)
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
-> Either ToCardanoError (BalancedTxBody BabbageEra)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> ToCardanoError
TxBodyError (String -> ToCardanoError)
-> (TxBodyErrorAutoBalance -> String)
-> TxBodyErrorAutoBalance
-> ToCardanoError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyErrorAutoBalance -> String
forall e. Error e => e -> String
C.Api.displayError) (Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
 -> Either ToCardanoError (BalancedTxBody BabbageEra))
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
-> Either ToCardanoError (BalancedTxBody BabbageEra)
forall a b. (a -> b) -> a -> b
$ [TxOut CtxTx BabbageEra]
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
balance []
  let
    -- Recompute execution units with full set of UTxOs, including change.
    trial :: Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
trial = [TxOut CtxTx BabbageEra]
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
balance [TxOut CtxTx BabbageEra
change]
    -- Correct for a negative balance in cases where execution units, and hence fees, have increased.
    change' :: TxOut CtxTx BabbageEra
change' =
      case (TxOut CtxTx BabbageEra
change, Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
trial) of
        (C.Api.TxOut CardanoAddress
addr (C.Api.TxOutValue MultiAssetSupportedInEra BabbageEra
vtype Value
value) TxOutDatum CtxTx BabbageEra
datum ReferenceScript BabbageEra
_referenceScript, Left (C.Api.TxBodyErrorAdaBalanceNegative Lovelace
delta)) ->
          CardanoAddress
-> TxOutValue BabbageEra
-> TxOutDatum CtxTx BabbageEra
-> ReferenceScript BabbageEra
-> TxOut CtxTx BabbageEra
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
C.Api.TxOut CardanoAddress
addr (MultiAssetSupportedInEra BabbageEra
-> Value -> TxOutValue BabbageEra
forall era. MultiAssetSupportedInEra era -> Value -> TxOutValue era
C.Api.TxOutValue MultiAssetSupportedInEra BabbageEra
vtype (Value -> TxOutValue BabbageEra) -> Value -> TxOutValue BabbageEra
forall a b. (a -> b) -> a -> b
$ Value
value Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Lovelace -> Value
C.Api.lovelaceToValue Lovelace
delta) TxOutDatum CtxTx BabbageEra
datum ReferenceScript BabbageEra
_referenceScript
        (TxOut CtxTx BabbageEra,
 Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra))
_ -> TxOut CtxTx BabbageEra
change
  -- Construct the body with correct execution units and fees.
  C.Api.BalancedTxBody TxBody BabbageEra
txBody TxOut CtxTx BabbageEra
_ Lovelace
_ <- (TxBodyErrorAutoBalance -> ToCardanoError)
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
-> Either ToCardanoError (BalancedTxBody BabbageEra)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> ToCardanoError
TxBodyError (String -> ToCardanoError)
-> (TxBodyErrorAutoBalance -> String)
-> TxBodyErrorAutoBalance
-> ToCardanoError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyErrorAutoBalance -> String
forall e. Error e => e -> String
C.Api.displayError) (Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
 -> Either ToCardanoError (BalancedTxBody BabbageEra))
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
-> Either ToCardanoError (BalancedTxBody BabbageEra)
forall a b. (a -> b) -> a -> b
$ [TxOut CtxTx BabbageEra]
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
balance [TxOut CtxTx BabbageEra
change']
  Tx BabbageEra -> Either ToCardanoError (Tx BabbageEra)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx BabbageEra -> Either ToCardanoError (Tx BabbageEra))
-> Tx BabbageEra -> Either ToCardanoError (Tx BabbageEra)
forall a b. (a -> b) -> a -> b
$ [KeyWitness BabbageEra] -> TxBody BabbageEra -> Tx BabbageEra
forall era. [KeyWitness era] -> TxBody era -> Tx era
C.Api.makeSignedTransaction [] TxBody BabbageEra
txBody
  where
    eh :: EraHistory CardanoMode
eh = Params -> EraHistory CardanoMode
emulatorEraHistory Params
params
    ss :: SystemStart
ss = Globals -> SystemStart
systemStart (Globals -> SystemStart) -> Globals -> SystemStart
forall a b. (a -> b) -> a -> b
$ Params -> Globals
emulatorGlobals Params
params
    utxo' :: UTxO BabbageEra
utxo' = UTxO EmulatorEra -> UTxO BabbageEra
fromLedgerUTxO UTxO EmulatorEra
utxo
    balance :: [TxOut CtxTx BabbageEra]
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
balance [TxOut CtxTx BabbageEra]
extraOuts = EraInMode BabbageEra CardanoMode
-> SystemStart
-> EraHistory CardanoMode
-> ProtocolParameters
-> Set PoolId
-> UTxO BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> CardanoAddress
-> Maybe Word
-> Either TxBodyErrorAutoBalance (BalancedTxBody BabbageEra)
forall era mode.
IsShelleyBasedEra era =>
EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> Set PoolId
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either TxBodyErrorAutoBalance (BalancedTxBody era)
C.Api.makeTransactionBodyAutoBalance
      EraInMode BabbageEra CardanoMode
C.Api.BabbageEraInCardanoMode
      SystemStart
ss
      EraHistory CardanoMode
eh
      (Params -> ProtocolParameters
pProtocolParams Params
params)
      Set PoolId
forall a. Monoid a => a
mempty
      UTxO BabbageEra
utxo'
      TxBodyContent BuildTx BabbageEra
txBodyContent { txOuts :: [TxOut CtxTx BabbageEra]
C.Api.txOuts = TxBodyContent BuildTx BabbageEra -> [TxOut CtxTx BabbageEra]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
C.Api.txOuts TxBodyContent BuildTx BabbageEra
txBodyContent [TxOut CtxTx BabbageEra]
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
forall a. [a] -> [a] -> [a]
++ [TxOut CtxTx BabbageEra]
extraOuts }
      CardanoAddress
cChangeAddr
      Maybe Word
forall a. Maybe a
Nothing


-- | Creates a balanced transaction by calculating the execution units, the fees and then the balance.
-- If the balance is negative the utxo provider is asked to pick extra inputs to make the balance is positive,
-- which is then assigned to the change address.
-- The collateral is similarly balanced.
-- Unlike `makeAutoBalancedTransaction` this function also balances non-Ada.
makeAutoBalancedTransactionWithUtxoProvider
    :: Monad m
    => Params
    -> UtxoIndex -- ^ Just the transaction inputs, not the entire 'UTxO'.
    -> CardanoAddress -- ^ Change address
    -> (Value -> m ([(TxOutRef, TxOut)], Value))
    -- ^ The utxo provider, it return outputs that cover at least the given value,
    -- and return the change, i.e. how much the outputs overshoot the given value.
    -> (forall a. CardanoLedgerError -> m a) -- ^ How to handle errors
    -> CardanoBuildTx
    -> m (C.Tx C.BabbageEra)
makeAutoBalancedTransactionWithUtxoProvider :: Params
-> UtxoIndex
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> CardanoBuildTx
-> m (Tx BabbageEra)
makeAutoBalancedTransactionWithUtxoProvider Params
params (UtxoIndex Map TxOutRef TxOut
txUtxo) CardanoAddress
cChangeAddr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter (CardanoBuildTx TxBodyContent BuildTx BabbageEra
unbalancedBodyContent) = do

    let initialFeeEstimate :: Value
initialFeeEstimate = Integer -> Value
Ada.lovelaceValueOf Integer
300_000

        calcFee :: Int -> Value -> m Value
calcFee Int
n Value
fee = do

            (TxBodyContent BuildTx BabbageEra
txBodyContent, [(TxOutRef, TxOut)]
extraUtxos) <- Params
-> Map TxOutRef TxOut
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> Value
-> TxBodyContent BuildTx BabbageEra
-> m (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
forall (m :: * -> *).
Monad m =>
Params
-> Map TxOutRef TxOut
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> Value
-> TxBodyContent BuildTx BabbageEra
-> m (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
handleBalanceTx Params
params Map TxOutRef TxOut
txUtxo CardanoAddress
cChangeAddr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter Value
fee TxBodyContent BuildTx BabbageEra
unbalancedBodyContent

            Value
newFee <- (CardanoLedgerError -> m Value)
-> (Value -> m Value) -> Either CardanoLedgerError Value -> m Value
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CardanoLedgerError -> m Value
forall a. CardanoLedgerError -> m a
errorReporter Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CardanoLedgerError Value -> m Value)
-> Either CardanoLedgerError Value -> m Value
forall a b. (a -> b) -> a -> b
$ do
                UTxO EmulatorEra
cUtxo <- UtxoIndex -> Either CardanoLedgerError (UTxO EmulatorEra)
fromPlutusIndex (UtxoIndex -> Either CardanoLedgerError (UTxO EmulatorEra))
-> UtxoIndex -> Either CardanoLedgerError (UTxO EmulatorEra)
forall a b. (a -> b) -> a -> b
$ Map TxOutRef TxOut -> UtxoIndex
UtxoIndex (Map TxOutRef TxOut -> UtxoIndex)
-> Map TxOutRef TxOut -> UtxoIndex
forall a b. (a -> b) -> a -> b
$ Map TxOutRef TxOut
txUtxo Map TxOutRef TxOut -> Map TxOutRef TxOut -> Map TxOutRef TxOut
forall a. Semigroup a => a -> a -> a
<> [(TxOutRef, TxOut)] -> Map TxOutRef TxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxOutRef, TxOut)]
extraUtxos
                Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> Either CardanoLedgerError Value
estimateCardanoBuildTxFee Params
params UTxO EmulatorEra
cUtxo (TxBodyContent BuildTx BabbageEra -> CardanoBuildTx
CardanoBuildTx TxBodyContent BuildTx BabbageEra
txBodyContent)

            if Value
newFee Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
fee
                then if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
0 :: Int)
                    -- If we don't reach a fixed point, pick the larger fee
                    then Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
newFee Value -> Value -> Value
forall a. JoinSemiLattice a => a -> a -> a
PlutusTx.\/ Value
fee)
                    else Int -> Value -> m Value
calcFee (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Value
newFee
                else Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
newFee

    Value
theFee <- Int -> Value -> m Value
calcFee Int
5 Value
initialFeeEstimate

    (TxBodyContent BuildTx BabbageEra
txBodyContent, [(TxOutRef, TxOut)]
extraUtxos) <- Params
-> Map TxOutRef TxOut
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> Value
-> TxBodyContent BuildTx BabbageEra
-> m (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
forall (m :: * -> *).
Monad m =>
Params
-> Map TxOutRef TxOut
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> Value
-> TxBodyContent BuildTx BabbageEra
-> m (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
handleBalanceTx Params
params Map TxOutRef TxOut
txUtxo CardanoAddress
cChangeAddr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter Value
theFee TxBodyContent BuildTx BabbageEra
unbalancedBodyContent

    (CardanoLedgerError -> m (Tx BabbageEra))
-> (Tx BabbageEra -> m (Tx BabbageEra))
-> Either CardanoLedgerError (Tx BabbageEra)
-> m (Tx BabbageEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CardanoLedgerError -> m (Tx BabbageEra)
forall a. CardanoLedgerError -> m a
errorReporter Tx BabbageEra -> m (Tx BabbageEra)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either CardanoLedgerError (Tx BabbageEra) -> m (Tx BabbageEra))
-> Either CardanoLedgerError (Tx BabbageEra) -> m (Tx BabbageEra)
forall a b. (a -> b) -> a -> b
$ do
        UTxO EmulatorEra
cUtxo <- UtxoIndex -> Either CardanoLedgerError (UTxO EmulatorEra)
fromPlutusIndex (UtxoIndex -> Either CardanoLedgerError (UTxO EmulatorEra))
-> UtxoIndex -> Either CardanoLedgerError (UTxO EmulatorEra)
forall a b. (a -> b) -> a -> b
$ Map TxOutRef TxOut -> UtxoIndex
UtxoIndex (Map TxOutRef TxOut -> UtxoIndex)
-> Map TxOutRef TxOut -> UtxoIndex
forall a b. (a -> b) -> a -> b
$ Map TxOutRef TxOut
txUtxo Map TxOutRef TxOut -> Map TxOutRef TxOut -> Map TxOutRef TxOut
forall a. Semigroup a => a -> a -> a
<> [(TxOutRef, TxOut)] -> Map TxOutRef TxOut
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxOutRef, TxOut)]
extraUtxos
        [KeyWitness BabbageEra] -> TxBody BabbageEra -> Tx BabbageEra
forall era. [KeyWitness era] -> TxBody era -> Tx era
C.makeSignedTransaction [] (TxBody BabbageEra -> Tx BabbageEra)
-> Either CardanoLedgerError (TxBody BabbageEra)
-> Either CardanoLedgerError (Tx BabbageEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Params
-> UTxO EmulatorEra
-> CardanoBuildTx
-> Either CardanoLedgerError (TxBody BabbageEra)
makeTransactionBody Params
params UTxO EmulatorEra
cUtxo (TxBodyContent BuildTx BabbageEra -> CardanoBuildTx
CardanoBuildTx TxBodyContent BuildTx BabbageEra
txBodyContent)

-- | Balance an unbalanced transaction by adding missing inputs and outputs
handleBalanceTx
    :: Monad m
    => Params
    -> Map.Map TxOutRef TxOut -- ^ Just the transaction inputs, not the entire 'UTxO'.
    -> C.AddressInEra C.BabbageEra -- ^ Change address
    -> (Value -> m ([(TxOutRef, TxOut)], Value)) -- ^ The utxo provider
    -> (forall a. CardanoLedgerError -> m a) -- ^ How to handle errors
    -> Value -- ^ Estimated fee value to use.
    -> C.TxBodyContent C.BuildTx C.BabbageEra
    -> m (C.TxBodyContent C.BuildTx C.BabbageEra, [(TxOutRef, TxOut)])
handleBalanceTx :: Params
-> Map TxOutRef TxOut
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> Value
-> TxBodyContent BuildTx BabbageEra
-> m (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
handleBalanceTx Params
params Map TxOutRef TxOut
txUtxo CardanoAddress
cChangeAddr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter Value
fees TxBodyContent BuildTx BabbageEra
utx = do

    TxFee BabbageEra
theFee <- (ToCardanoError -> m (TxFee BabbageEra))
-> (TxFee BabbageEra -> m (TxFee BabbageEra))
-> Either ToCardanoError (TxFee BabbageEra)
-> m (TxFee BabbageEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CardanoLedgerError -> m (TxFee BabbageEra)
forall a. CardanoLedgerError -> m a
errorReporter (CardanoLedgerError -> m (TxFee BabbageEra))
-> (ToCardanoError -> CardanoLedgerError)
-> ToCardanoError
-> m (TxFee BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right) TxFee BabbageEra -> m (TxFee BabbageEra)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ToCardanoError (TxFee BabbageEra) -> m (TxFee BabbageEra))
-> Either ToCardanoError (TxFee BabbageEra) -> m (TxFee BabbageEra)
forall a b. (a -> b) -> a -> b
$ Value -> Either ToCardanoError (TxFee BabbageEra)
toCardanoFee Value
fees

    let filteredUnbalancedTxTx :: TxBodyContent BuildTx BabbageEra
filteredUnbalancedTxTx = TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
forall ctx.
TxBodyContent ctx BabbageEra -> TxBodyContent ctx BabbageEra
removeEmptyOutputsBuildTx TxBodyContent BuildTx BabbageEra
utx { txFee :: TxFee BabbageEra
C.txFee = TxFee BabbageEra
theFee }
        txInputs :: [TxIn]
txInputs = TxBodyContent BuildTx BabbageEra -> [TxIn]
forall ctx era. TxBodyContent ctx era -> [TxIn]
Tx.getTxBodyContentInputs TxBodyContent BuildTx BabbageEra
filteredUnbalancedTxTx

        lookupValue :: TxIn -> m Value
lookupValue TxIn
txIn = let txOutRef :: TxOutRef
txOutRef = TxIn -> TxOutRef
Tx.txInRef TxIn
txIn in
          m Value -> (TxOut -> m Value) -> Maybe TxOut -> m Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (CardanoLedgerError -> m Value
forall a. CardanoLedgerError -> m a
errorReporter ((ValidationPhase, ValidationError) -> CardanoLedgerError
forall a b. a -> Either a b
Left (ValidationPhase
Phase1, TxOutRef -> ValidationError
TxOutRefNotFound TxOutRef
txOutRef)))
            (Value -> m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> (TxOut -> Value) -> TxOut -> m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> Value
Tx.txOutValue)
            (TxOutRef -> Map TxOutRef TxOut -> Maybe TxOut
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxOutRef
txOutRef Map TxOutRef TxOut
txUtxo)

    [Value]
inputValues <- (TxIn -> m Value) -> [TxIn] -> m [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TxIn -> m Value
lookupValue [TxIn]
txInputs

    let left :: Value
left = TxBodyContent BuildTx BabbageEra -> Value
forall ctx era. TxBodyContent ctx era -> Value
Tx.getTxBodyContentMint TxBodyContent BuildTx BabbageEra
filteredUnbalancedTxTx Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> [Value] -> Value
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Value]
inputValues
        right :: Value
right = Value
fees Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> (TxOut CtxTx BabbageEra -> Value)
-> [TxOut CtxTx BabbageEra] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TxOut -> Value
Tx.txOutValue (TxOut -> Value)
-> (TxOut CtxTx BabbageEra -> TxOut)
-> TxOut CtxTx BabbageEra
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx BabbageEra -> TxOut
Tx.TxOut) (TxBodyContent BuildTx BabbageEra -> [TxOut CtxTx BabbageEra]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
C.txOuts TxBodyContent BuildTx BabbageEra
filteredUnbalancedTxTx)
        balance :: Value
balance = Value
left Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
PlutusTx.- Value
right

    ((Value
neg, [(TxOutRef, TxOut)]
newInputs), (Value
pos, Maybe TxOut
mNewTxOut)) <- Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
forall (m :: * -> *).
Monad m =>
Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
calculateTxChanges Params
params CardanoAddress
cChangeAddr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter ((Value, Value)
 -> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut)))
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
forall a b. (a -> b) -> a -> b
$ Value -> (Value, Value)
Value.split Value
balance

    [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
newTxIns <- ((TxOutRef, TxOut)
 -> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)))
-> [(TxOutRef, TxOut)]
-> m [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ToCardanoError
 -> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)))
-> (TxIn
    -> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)))
-> Either ToCardanoError TxIn
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CardanoLedgerError
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
forall a. CardanoLedgerError -> m a
errorReporter (CardanoLedgerError
 -> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)))
-> (ToCardanoError -> CardanoLedgerError)
-> ToCardanoError
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right) ((TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
 -> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)))
-> (TxIn
    -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)))
-> TxIn
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, Witness WitCtxTxIn BabbageEra
-> BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)
forall a. a -> BuildTxWith BuildTx a
C.BuildTxWith (Witness WitCtxTxIn BabbageEra
 -> BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
-> Witness WitCtxTxIn BabbageEra
-> BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx WitCtxTxIn -> Witness WitCtxTxIn BabbageEra
forall witctx era. KeyWitnessInCtx witctx -> Witness witctx era
C.KeyWitness KeyWitnessInCtx WitCtxTxIn
C.KeyWitnessForSpending)) (Either ToCardanoError TxIn
 -> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)))
-> ((TxOutRef, TxOut) -> Either ToCardanoError TxIn)
-> (TxOutRef, TxOut)
-> m (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> Either ToCardanoError TxIn
CardanoAPI.toCardanoTxIn (TxOutRef -> Either ToCardanoError TxIn)
-> ((TxOutRef, TxOut) -> TxOutRef)
-> (TxOutRef, TxOut)
-> Either ToCardanoError TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxOut) -> TxOutRef
forall a b. (a, b) -> a
fst) [(TxOutRef, TxOut)]
newInputs

    let txWithOutputsAdded :: TxBodyContent BuildTx BabbageEra
txWithOutputsAdded = if Value -> Bool
Value.isZero Value
pos
        then TxBodyContent BuildTx BabbageEra
filteredUnbalancedTxTx
        else TxBodyContent BuildTx BabbageEra
filteredUnbalancedTxTx TxBodyContent BuildTx BabbageEra
-> (TxBodyContent BuildTx BabbageEra
    -> TxBodyContent BuildTx BabbageEra)
-> TxBodyContent BuildTx BabbageEra
forall a b. a -> (a -> b) -> b
& ASetter
  (TxBodyContent BuildTx BabbageEra)
  (TxBodyContent BuildTx BabbageEra)
  [TxOut]
  [TxOut]
-> ([TxOut] -> [TxOut])
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (TxBodyContent BuildTx BabbageEra)
  (TxBodyContent BuildTx BabbageEra)
  [TxOut]
  [TxOut]
forall ctx. Lens' (TxBodyContent ctx BabbageEra) [TxOut]
Tx.txBodyContentOuts ([TxOut] -> [TxOut] -> [TxOut]
forall a. [a] -> [a] -> [a]
++ Maybe TxOut -> [TxOut]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe TxOut
mNewTxOut)

    let txWithinputsAdded :: TxBodyContent BuildTx BabbageEra
txWithinputsAdded = if Value -> Bool
Value.isZero Value
neg
        then TxBodyContent BuildTx BabbageEra
txWithOutputsAdded
        else TxBodyContent BuildTx BabbageEra
txWithOutputsAdded TxBodyContent BuildTx BabbageEra
-> (TxBodyContent BuildTx BabbageEra
    -> TxBodyContent BuildTx BabbageEra)
-> TxBodyContent BuildTx BabbageEra
forall a b. a -> (a -> b) -> b
& ASetter
  (TxBodyContent BuildTx BabbageEra)
  (TxBodyContent BuildTx BabbageEra)
  [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
  [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
-> ([(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
    -> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))])
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (TxBodyContent BuildTx BabbageEra)
  (TxBodyContent BuildTx BabbageEra)
  [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
  [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
Lens'
  (TxBodyContent BuildTx BabbageEra)
  [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
Tx.txBodyContentIns ([(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
-> [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
forall a. [a] -> [a] -> [a]
++ [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra))]
newTxIns)

    [Value]
collateral <- (TxIn -> m Value) -> [TxIn] -> m [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TxIn -> m Value
lookupValue (TxBodyContent BuildTx BabbageEra -> [TxIn]
forall ctx era. TxBodyContent ctx era -> [TxIn]
Tx.getTxBodyContentCollateralInputs TxBodyContent BuildTx BabbageEra
txWithinputsAdded)
    let returnCollateral :: Maybe TxOut
returnCollateral = TxBodyContent BuildTx BabbageEra -> Maybe TxOut
forall ctx. TxBodyContent ctx BabbageEra -> Maybe TxOut
Tx.getTxBodyContentReturnCollateral TxBodyContent BuildTx BabbageEra
txWithinputsAdded

    if Value -> Bool
Value.isZero ([Value] -> Value
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Value]
collateral)
        Bool -> Bool -> Bool
&& [(ScriptWitnessIndex, AnyScriptWitness BabbageEra)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (TxBodyContent BuildTx BabbageEra
-> [(ScriptWitnessIndex, AnyScriptWitness BabbageEra)]
forall era.
TxBodyContent BuildTx era
-> [(ScriptWitnessIndex, AnyScriptWitness era)]
C.collectTxBodyScriptWitnesses TxBodyContent BuildTx BabbageEra
txWithinputsAdded) -- every script has a redeemer, no redeemers -> no scripts
        Bool -> Bool -> Bool
&& Maybe TxOut -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe TxOut
returnCollateral then
        -- Don't add collateral if there are no plutus scripts that can fail
        -- and there are no collateral inputs or outputs already
        (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
-> m (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBodyContent BuildTx BabbageEra
txWithinputsAdded, [(TxOutRef, TxOut)]
newInputs)
    else do
        let collAddr :: CardanoAddress
collAddr = CardanoAddress
-> (TxOut -> CardanoAddress) -> Maybe TxOut -> CardanoAddress
forall b a. b -> (a -> b) -> Maybe a -> b
maybe CardanoAddress
cChangeAddr (\(Tx.TxOut (C.TxOut CardanoAddress
aie TxOutValue BabbageEra
_tov TxOutDatum CtxTx BabbageEra
_tod ReferenceScript BabbageEra
_rs)) -> CardanoAddress
aie) Maybe TxOut
returnCollateral
            collateralPercent :: Ada
collateralPercent = Ada -> (Natural -> Ada) -> Maybe Natural -> Ada
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ada
100 Natural -> Ada
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ProtocolParameters -> Maybe Natural
C.protocolParamCollateralPercent (Params -> ProtocolParameters
pProtocolParams Params
params))
            collFees :: Value
collFees = Ada -> Value
Ada.toValue (Ada -> Value) -> Ada -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Ada
Ada.fromValue Value
fees Ada -> Ada -> Ada
forall a. Num a => a -> a -> a
* Ada
collateralPercent Ada -> Ada -> Ada
forall a. Num a => a -> a -> a
+ Ada
99 {- make sure to round up -}) Ada -> Ada -> Ada
`Ada.divide` Ada
100
            collBalance :: Value
collBalance = [Value] -> Value
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Value]
collateral Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
PlutusTx.- Value
collFees

        ((Value
negColl, [(TxOutRef, TxOut)]
newColInputs), (Value
_, Maybe TxOut
mNewTxOutColl)) <- Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
forall (m :: * -> *).
Monad m =>
Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
calculateTxChanges Params
params CardanoAddress
collAddr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter ((Value, Value)
 -> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut)))
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
forall a b. (a -> b) -> a -> b
$ Value -> (Value, Value)
Value.split Value
collBalance

        [TxIn]
newTxInsColl <- ((TxOutRef, TxOut) -> m TxIn) -> [(TxOutRef, TxOut)] -> m [TxIn]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((ToCardanoError -> m TxIn)
-> (TxIn -> m TxIn) -> Either ToCardanoError TxIn -> m TxIn
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CardanoLedgerError -> m TxIn
forall a. CardanoLedgerError -> m a
errorReporter (CardanoLedgerError -> m TxIn)
-> (ToCardanoError -> CardanoLedgerError)
-> ToCardanoError
-> m TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right) TxIn -> m TxIn
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ToCardanoError TxIn -> m TxIn)
-> ((TxOutRef, TxOut) -> Either ToCardanoError TxIn)
-> (TxOutRef, TxOut)
-> m TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOutRef -> Either ToCardanoError TxIn
CardanoAPI.toCardanoTxIn (TxOutRef -> Either ToCardanoError TxIn)
-> ((TxOutRef, TxOut) -> TxOutRef)
-> (TxOutRef, TxOut)
-> Either ToCardanoError TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOutRef, TxOut) -> TxOutRef
forall a b. (a, b) -> a
fst) [(TxOutRef, TxOut)]
newColInputs

        let txWithCollateralInputs :: TxBodyContent BuildTx BabbageEra
txWithCollateralInputs = if Value -> Bool
Value.isZero Value
negColl
            then TxBodyContent BuildTx BabbageEra
txWithinputsAdded
            else TxBodyContent BuildTx BabbageEra
txWithinputsAdded TxBodyContent BuildTx BabbageEra
-> (TxBodyContent BuildTx BabbageEra
    -> TxBodyContent BuildTx BabbageEra)
-> TxBodyContent BuildTx BabbageEra
forall a b. a -> (a -> b) -> b
& ASetter
  (TxBodyContent BuildTx BabbageEra)
  (TxBodyContent BuildTx BabbageEra)
  [TxIn]
  [TxIn]
-> ([TxIn] -> [TxIn])
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (TxBodyContent BuildTx BabbageEra)
  (TxBodyContent BuildTx BabbageEra)
  [TxIn]
  [TxIn]
Lens' (TxBodyContent BuildTx BabbageEra) [TxIn]
Tx.txBodyContentCollateralIns ([TxIn] -> [TxIn] -> [TxIn]
forall a. [a] -> [a] -> [a]
++ [TxIn]
newTxInsColl)

        TxTotalCollateral BabbageEra
totalCollateral <- (ToCardanoError -> m (TxTotalCollateral BabbageEra))
-> (TxTotalCollateral BabbageEra
    -> m (TxTotalCollateral BabbageEra))
-> Either ToCardanoError (TxTotalCollateral BabbageEra)
-> m (TxTotalCollateral BabbageEra)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CardanoLedgerError -> m (TxTotalCollateral BabbageEra)
forall a. CardanoLedgerError -> m a
errorReporter (CardanoLedgerError -> m (TxTotalCollateral BabbageEra))
-> (ToCardanoError -> CardanoLedgerError)
-> ToCardanoError
-> m (TxTotalCollateral BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right) TxTotalCollateral BabbageEra -> m (TxTotalCollateral BabbageEra)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ToCardanoError (TxTotalCollateral BabbageEra)
 -> m (TxTotalCollateral BabbageEra))
-> Either ToCardanoError (TxTotalCollateral BabbageEra)
-> m (TxTotalCollateral BabbageEra)
forall a b. (a -> b) -> a -> b
$ Maybe Value -> Either ToCardanoError (TxTotalCollateral BabbageEra)
toCardanoTotalCollateral (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
collFees)

        (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
-> m (TxBodyContent BuildTx BabbageEra, [(TxOutRef, TxOut)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxBodyContent BuildTx BabbageEra
txWithCollateralInputs {
            txTotalCollateral :: TxTotalCollateral BabbageEra
C.txTotalCollateral = TxTotalCollateral BabbageEra
totalCollateral,
            txReturnCollateral :: TxReturnCollateral CtxTx BabbageEra
C.txReturnCollateral = Maybe TxOut -> TxReturnCollateral CtxTx BabbageEra
toCardanoReturnCollateral Maybe TxOut
mNewTxOutColl
        }, [(TxOutRef, TxOut)]
newInputs [(TxOutRef, TxOut)] -> [(TxOutRef, TxOut)] -> [(TxOutRef, TxOut)]
forall a. Semigroup a => a -> a -> a
<> [(TxOutRef, TxOut)]
newColInputs)

removeEmptyOutputsBuildTx :: C.TxBodyContent ctx C.BabbageEra -> C.TxBodyContent ctx C.BabbageEra
removeEmptyOutputsBuildTx :: TxBodyContent ctx BabbageEra -> TxBodyContent ctx BabbageEra
removeEmptyOutputsBuildTx bodyContent :: TxBodyContent ctx BabbageEra
bodyContent@C.TxBodyContent { [TxOut CtxTx BabbageEra]
txOuts :: [TxOut CtxTx BabbageEra]
txOuts :: forall build era. TxBodyContent build era -> [TxOut CtxTx era]
C.txOuts } = TxBodyContent ctx BabbageEra
bodyContent { txOuts :: [TxOut CtxTx BabbageEra]
C.txOuts = [TxOut CtxTx BabbageEra]
txOuts' }
    where
        txOuts' :: [TxOut CtxTx BabbageEra]
txOuts' = (TxOut CtxTx BabbageEra -> Bool)
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (TxOut CtxTx BabbageEra -> Bool)
-> TxOut CtxTx BabbageEra
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> Bool
isEmpty' (TxOut -> Bool)
-> (TxOut CtxTx BabbageEra -> TxOut)
-> TxOut CtxTx BabbageEra
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx BabbageEra -> TxOut
Tx.TxOut) [TxOut CtxTx BabbageEra]
txOuts
        isEmpty' :: TxOut -> Bool
isEmpty' TxOut
txOut =
            [(CurrencySymbol, TokenName, Integer)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Value -> [(CurrencySymbol, TokenName, Integer)]
Value.flattenValue (TxOut -> Value
Tx.txOutValue TxOut
txOut)) Bool -> Bool -> Bool
&& Maybe DatumHash -> Bool
forall a. Maybe a -> Bool
isNothing (TxOut -> Maybe DatumHash
Tx.txOutDatumHash TxOut
txOut)

calculateTxChanges
    :: Monad m
    => Params
    -> C.AddressInEra C.BabbageEra -- ^ The address for the change output
    -> (Value -> m ([(TxOutRef, TxOut)], Value)) -- ^ The utxo provider
    -> (forall a. CardanoLedgerError -> m a) -- ^ How to handle errors
    -> (Value, Value) -- ^ The unbalanced tx's negative and positive balance.
    -> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
calculateTxChanges :: Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
calculateTxChanges Params
params CardanoAddress
addr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter (Value
neg, Value
pos) = do
    -- Calculate the change output with minimal ada
    (Value
newNeg, Value
newPos, Maybe TxOut
mExtraTxOut) <- (ToCardanoError -> m (Value, Value, Maybe TxOut))
-> ((Value, Value, Maybe TxOut) -> m (Value, Value, Maybe TxOut))
-> Either ToCardanoError (Value, Value, Maybe TxOut)
-> m (Value, Value, Maybe TxOut)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CardanoLedgerError -> m (Value, Value, Maybe TxOut)
forall a. CardanoLedgerError -> m a
errorReporter (CardanoLedgerError -> m (Value, Value, Maybe TxOut))
-> (ToCardanoError -> CardanoLedgerError)
-> ToCardanoError
-> m (Value, Value, Maybe TxOut)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ToCardanoError -> CardanoLedgerError
forall a b. b -> Either a b
Right) (Value, Value, Maybe TxOut) -> m (Value, Value, Maybe TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ToCardanoError (Value, Value, Maybe TxOut)
 -> m (Value, Value, Maybe TxOut))
-> Either ToCardanoError (Value, Value, Maybe TxOut)
-> m (Value, Value, Maybe TxOut)
forall a b. (a -> b) -> a -> b
$ if Value -> Bool
Value.isZero Value
pos
        then (Value, Value, Maybe TxOut)
-> Either ToCardanoError (Value, Value, Maybe TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
neg, Value
pos, Maybe TxOut
forall a. Maybe a
Nothing)
        else do
            Value
txov <- Value -> Either ToCardanoError Value
CardanoAPI.toCardanoValue Value
pos
            let txOut :: TxOut CtxTx BabbageEra
txOut = CardanoAddress
-> TxOutValue BabbageEra
-> TxOutDatum CtxTx BabbageEra
-> ReferenceScript BabbageEra
-> TxOut CtxTx BabbageEra
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
C.TxOut CardanoAddress
addr (MultiAssetSupportedInEra BabbageEra
-> Value -> TxOutValue BabbageEra
forall era. MultiAssetSupportedInEra era -> Value -> TxOutValue era
C.TxOutValue MultiAssetSupportedInEra BabbageEra
C.MultiAssetInBabbageEra Value
txov) TxOutDatum CtxTx BabbageEra
forall ctx era. TxOutDatum ctx era
C.TxOutDatumNone ReferenceScript BabbageEra
forall era. ReferenceScript era
C.Api.ReferenceScriptNone
            ([Ada]
missing, TxOut
extraTxOut) <- PParams EmulatorEra
-> TxOut -> Either ToCardanoError ([Ada], TxOut)
adjustTxOut (Params -> PParams EmulatorEra
emulatorPParams Params
params) (TxOut CtxTx BabbageEra -> TxOut
Tx.TxOut TxOut CtxTx BabbageEra
txOut)
            let missingValue :: Value
missingValue = Ada -> Value
Ada.toValue ([Ada] -> Ada
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Ada]
missing)
            -- Add the missing ada to both sides to keep the balance.
            (Value, Value, Maybe TxOut)
-> Either ToCardanoError (Value, Value, Maybe TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
neg Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingValue, Value
pos Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
missingValue, TxOut -> Maybe TxOut
forall a. a -> Maybe a
Just TxOut
extraTxOut)

    -- Calculate the extra inputs needed
    ([(TxOutRef, TxOut)]
spend, Value
change) <- if Value -> Bool
Value.isZero Value
newNeg
        then ([(TxOutRef, TxOut)], Value) -> m ([(TxOutRef, TxOut)], Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Value
forall a. Monoid a => a
mempty)
        else Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider Value
newNeg

    if Value -> Bool
Value.isZero Value
change
        then do
            -- No change, so the new inputs and outputs have balanced the transaction
            ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value
newNeg, [(TxOutRef, TxOut)]
spend), (Value
newPos, Maybe TxOut
mExtraTxOut))
        else if Maybe TxOut -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe TxOut
mExtraTxOut
            -- We have change so we need an extra output, if we didn't have that yet,
            -- first make one with an estimated minimal amount of ada
            -- which then will calculate a more exact set of inputs
            then Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
forall (m :: * -> *).
Monad m =>
Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
calculateTxChanges Params
params CardanoAddress
addr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter (Value
neg Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Ada -> Value
Ada.toValue Ada
minAdaTxOutEstimated, Ada -> Value
Ada.toValue Ada
minAdaTxOutEstimated)
            -- Else recalculate with the change added to both sides
            -- Ideally this creates the same inputs and outputs and then the change will be zero
            -- But possibly the minimal Ada increases and then we also want to compute a new set of inputs
            else Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
forall (m :: * -> *).
Monad m =>
Params
-> CardanoAddress
-> (Value -> m ([(TxOutRef, TxOut)], Value))
-> (forall a. CardanoLedgerError -> m a)
-> (Value, Value)
-> m ((Value, [(TxOutRef, TxOut)]), (Value, Maybe TxOut))
calculateTxChanges Params
params CardanoAddress
addr Value -> m ([(TxOutRef, TxOut)], Value)
utxoProvider forall a. CardanoLedgerError -> m a
errorReporter (Value
newNeg Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
change, Value
newPos Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
change)


data BalancingError
    = InsufficientFunds { BalancingError -> Value
total :: Value, BalancingError -> Value
expected :: Value }
    -- ^ Not enough extra inputs available to balance a transaction.
    | CardanoLedgerError CardanoLedgerError
    deriving stock (Int -> BalancingError -> ShowS
[BalancingError] -> ShowS
BalancingError -> String
(Int -> BalancingError -> ShowS)
-> (BalancingError -> String)
-> ([BalancingError] -> ShowS)
-> Show BalancingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BalancingError] -> ShowS
$cshowList :: [BalancingError] -> ShowS
show :: BalancingError -> String
$cshow :: BalancingError -> String
showsPrec :: Int -> BalancingError -> ShowS
$cshowsPrec :: Int -> BalancingError -> ShowS
Show, BalancingError -> BalancingError -> Bool
(BalancingError -> BalancingError -> Bool)
-> (BalancingError -> BalancingError -> Bool) -> Eq BalancingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BalancingError -> BalancingError -> Bool
$c/= :: BalancingError -> BalancingError -> Bool
== :: BalancingError -> BalancingError -> Bool
$c== :: BalancingError -> BalancingError -> Bool
Eq, (forall x. BalancingError -> Rep BalancingError x)
-> (forall x. Rep BalancingError x -> BalancingError)
-> Generic BalancingError
forall x. Rep BalancingError x -> BalancingError
forall x. BalancingError -> Rep BalancingError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BalancingError x -> BalancingError
$cfrom :: forall x. BalancingError -> Rep BalancingError x
Generic)
    deriving anyclass ([BalancingError] -> Encoding
[BalancingError] -> Value
BalancingError -> Encoding
BalancingError -> Value
(BalancingError -> Value)
-> (BalancingError -> Encoding)
-> ([BalancingError] -> Value)
-> ([BalancingError] -> Encoding)
-> ToJSON BalancingError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BalancingError] -> Encoding
$ctoEncodingList :: [BalancingError] -> Encoding
toJSONList :: [BalancingError] -> Value
$ctoJSONList :: [BalancingError] -> Value
toEncoding :: BalancingError -> Encoding
$ctoEncoding :: BalancingError -> Encoding
toJSON :: BalancingError -> Value
$ctoJSON :: BalancingError -> Value
ToJSON, Value -> Parser [BalancingError]
Value -> Parser BalancingError
(Value -> Parser BalancingError)
-> (Value -> Parser [BalancingError]) -> FromJSON BalancingError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BalancingError]
$cparseJSONList :: Value -> Parser [BalancingError]
parseJSON :: Value -> Parser BalancingError
$cparseJSON :: Value -> Parser BalancingError
FromJSON)

-- Build a utxo provider from a set of unspent transaction outputs.
utxoProviderFromWalletOutputs
    :: Map.Map TxOutRef TxOut
    -- ^ The unspent transaction outputs.
    -- Make sure that this doesn't contain any inputs from the transaction being balanced.
    -> Value
    -> Either BalancingError ([(TxOutRef, TxOut)], Value)
utxoProviderFromWalletOutputs :: Map TxOutRef TxOut
-> Value -> Either BalancingError ([(TxOutRef, TxOut)], Value)
utxoProviderFromWalletOutputs Map TxOutRef TxOut
walletUtxos Value
value =
    let outRefsWithValue :: [((TxOutRef, TxOut), Value)]
outRefsWithValue = (\(TxOutRef, TxOut)
p -> ((TxOutRef, TxOut)
p, TxOut -> Value
Tx.txOutValue ((TxOutRef, TxOut) -> TxOut
forall a b. (a, b) -> b
snd (TxOutRef, TxOut)
p))) ((TxOutRef, TxOut) -> ((TxOutRef, TxOut), Value))
-> [(TxOutRef, TxOut)] -> [((TxOutRef, TxOut), Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxOutRef TxOut -> [(TxOutRef, TxOut)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxOutRef TxOut
walletUtxos
    in [((TxOutRef, TxOut), Value)]
-> Value -> Either BalancingError ([(TxOutRef, TxOut)], Value)
forall a.
Eq a =>
[(a, Value)] -> Value -> Either BalancingError ([a], Value)
selectCoin [((TxOutRef, TxOut), Value)]
outRefsWithValue Value
value

-- | Given a set of @a@s with coin values, and a target value, select a number
-- of @a@ such that their total value is greater than or equal to the target.
selectCoin ::
    Eq a
    => [(a, Value)] -- ^ Possible inputs to choose from
    -> Value -- ^ The target value
    -> Either BalancingError ([a], Value) -- ^ The chosen inputs and the change
selectCoin :: [(a, Value)] -> Value -> Either BalancingError ([a], Value)
selectCoin [(a, Value)]
fnds Value
vl =
    let
        total :: Value
total = ((a, Value) -> Value) -> [(a, Value)] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (a, Value) -> Value
forall a b. (a, b) -> b
snd [(a, Value)]
fnds
        err :: Either BalancingError ([a], Value)
err   = BalancingError -> Either BalancingError ([a], Value)
forall a b. a -> Either a b
Left (BalancingError -> Either BalancingError ([a], Value))
-> BalancingError -> Either BalancingError ([a], Value)
forall a b. (a -> b) -> a -> b
$ Value -> Value -> BalancingError
InsufficientFunds Value
total Value
vl
    -- Values are in a partial order: what we want to check is that the
    -- total available funds are bigger than (or equal to) the required value.
    -- It is *not* correct to replace this condition with 'total `Value.lt` vl' -
    -- consider what happens if the amounts are incomparable.
    in  if Bool -> Bool
not (Value
total Value -> Value -> Bool
`Value.geq` Value
vl)
        then Either BalancingError ([a], Value)
err
        else
            -- Select inputs per asset class, sorting so we do Ada last.
            -- We want to do the non-Ada asset classes first, because utxo's often contain
            -- extra Ada because of fees or minAda constraints. So when we are done with the
            -- non-Ada asset classes we probably already have picked some Ada too.
            let ([(a, Value)]
usedFinal, Value
remainderFinal) = (([(a, Value)], Value)
 -> (CurrencySymbol, TokenName, Integer) -> ([(a, Value)], Value))
-> ([(a, Value)], Value)
-> [(CurrencySymbol, TokenName, Integer)]
-> ([(a, Value)], Value)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(a, Value)], Value)
-> (CurrencySymbol, TokenName, Integer) -> ([(a, Value)], Value)
step ([], Value
vl) (((CurrencySymbol, TokenName, Integer)
 -> Down (CurrencySymbol, TokenName, Integer))
-> [(CurrencySymbol, TokenName, Integer)]
-> [(CurrencySymbol, TokenName, Integer)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (CurrencySymbol, TokenName, Integer)
-> Down (CurrencySymbol, TokenName, Integer)
forall a. a -> Down a
Down ([(CurrencySymbol, TokenName, Integer)]
 -> [(CurrencySymbol, TokenName, Integer)])
-> [(CurrencySymbol, TokenName, Integer)]
-> [(CurrencySymbol, TokenName, Integer)]
forall a b. (a -> b) -> a -> b
$ Value -> [(CurrencySymbol, TokenName, Integer)]
Value.flattenValue Value
vl)
                step :: ([(a, Value)], Value)
-> (CurrencySymbol, TokenName, Integer) -> ([(a, Value)], Value)
step ([(a, Value)]
used, Value
remainder) (CurrencySymbol
cur, TokenName
tok, Integer
_) =
                    let ([(a, Value)]
used', Value
remainder') = CurrencySymbol
-> TokenName -> [(a, Value)] -> Value -> ([(a, Value)], Value)
forall a.
CurrencySymbol
-> TokenName -> [(a, Value)] -> Value -> ([(a, Value)], Value)
selectCoinSingle CurrencySymbol
cur TokenName
tok ([(a, Value)]
fnds [(a, Value)] -> [(a, Value)] -> [(a, Value)]
forall a. Eq a => [a] -> [a] -> [a]
\\ [(a, Value)]
used) Value
remainder
                    in ([(a, Value)]
used [(a, Value)] -> [(a, Value)] -> [(a, Value)]
forall a. Semigroup a => a -> a -> a
<> [(a, Value)]
used', Value
remainder')
            in ([a], Value) -> Either BalancingError ([a], Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((a, Value) -> a) -> [(a, Value)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Value) -> a
forall a b. (a, b) -> a
fst [(a, Value)]
usedFinal, Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
remainderFinal)

selectCoinSingle
    :: Value.CurrencySymbol
    -> Value.TokenName
    -> [(a, Value)] -- ^ Possible inputs to choose from
    -> Value -- ^ The target value
    -> ([(a, Value)], Value) -- ^ The chosen inputs and the remainder
selectCoinSingle :: CurrencySymbol
-> TokenName -> [(a, Value)] -> Value -> ([(a, Value)], Value)
selectCoinSingle CurrencySymbol
cur TokenName
tok [(a, Value)]
fnds' Value
vl =
    let
        -- We only want the values that contain the given asset class,
        -- and want the single currency values first,
        -- so that we're picking inputs that contain *only* the given asset class when possible.
        fnds :: [(a, Value)]
fnds = ((a, Value) -> Int) -> [(a, Value)] -> [(a, Value)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ([CurrencySymbol] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([CurrencySymbol] -> Int)
-> ((a, Value) -> [CurrencySymbol]) -> (a, Value) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [CurrencySymbol]
Value.symbols (Value -> [CurrencySymbol])
-> ((a, Value) -> Value) -> (a, Value) -> [CurrencySymbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Value) -> Value
forall a b. (a, b) -> b
snd) ([(a, Value)] -> [(a, Value)]) -> [(a, Value)] -> [(a, Value)]
forall a b. (a -> b) -> a -> b
$ ((a, Value) -> Bool) -> [(a, Value)] -> [(a, Value)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
_, Value
v) -> Value -> CurrencySymbol -> TokenName -> Integer
Value.valueOf Value
v CurrencySymbol
cur TokenName
tok Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) [(a, Value)]
fnds'
        -- Given the funds of a wallet, we take enough just enough from
        -- the target value such that the asset class value of the remainder is <= 0.
        fundsWithRemainder :: [((a, Value), Value)]
fundsWithRemainder = [(a, Value)] -> [Value] -> [((a, Value), Value)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(a, Value)]
fnds (Int -> [Value] -> [Value]
forall a. Int -> [a] -> [a]
drop Int
1 ([Value] -> [Value]) -> [Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Value -> [Value] -> [Value]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
(PlutusTx.-) Value
vl ([Value] -> [Value]) -> [Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ ((a, Value) -> Value) -> [(a, Value)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Value) -> Value
forall a b. (a, b) -> b
snd [(a, Value)]
fnds)
        fundsToSpend :: [((a, Value), Value)]
fundsToSpend       = (((a, Value), Value) -> Bool)
-> [((a, Value), Value)] -> [((a, Value), Value)]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil (\((a, Value)
_, Value
v) -> Value -> CurrencySymbol -> TokenName -> Integer
Value.valueOf Value
v CurrencySymbol
cur TokenName
tok Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0) [((a, Value), Value)]
fundsWithRemainder
        remainder :: Value
remainder          = Value
-> (((a, Value), Value) -> Value)
-> Maybe ((a, Value), Value)
-> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
vl ((a, Value), Value) -> Value
forall a b. (a, b) -> b
snd (Maybe ((a, Value), Value) -> Value)
-> Maybe ((a, Value), Value) -> Value
forall a b. (a -> b) -> a -> b
$ [((a, Value), Value)] -> Maybe ((a, Value), Value)
forall a. [a] -> Maybe a
listToMaybe ([((a, Value), Value)] -> Maybe ((a, Value), Value))
-> [((a, Value), Value)] -> Maybe ((a, Value), Value)
forall a b. (a -> b) -> a -> b
$ [((a, Value), Value)] -> [((a, Value), Value)]
forall a. [a] -> [a]
reverse [((a, Value), Value)]
fundsToSpend
    in (((a, Value), Value) -> (a, Value)
forall a b. (a, b) -> a
fst (((a, Value), Value) -> (a, Value))
-> [((a, Value), Value)] -> [(a, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((a, Value), Value)]
fundsToSpend, Value
remainder)

-- | Take elements from a list until the predicate is satisfied.
-- 'takeUntil' @p@ includes the first element for wich @p@ is true
-- (unlike @takeWhile (not . p)@).
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
_ []       = []
takeUntil a -> Bool
p (a
x:[a]
xs)
    | a -> Bool
p a
x            = [a
x]
    | Bool
otherwise      = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
p [a]
xs


fromLedgerUTxO :: UTxO EmulatorEra
               -> C.Api.UTxO C.Api.BabbageEra
fromLedgerUTxO :: UTxO EmulatorEra -> UTxO BabbageEra
fromLedgerUTxO (UTxO Map (TxIn (Crypto EmulatorEra)) (TxOut EmulatorEra)
utxo) =
    Map TxIn (TxOut CtxUTxO BabbageEra) -> UTxO BabbageEra
forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
C.Api.UTxO
  (Map TxIn (TxOut CtxUTxO BabbageEra) -> UTxO BabbageEra)
-> (Map (TxIn StandardCrypto) (TxOut EmulatorEra)
    -> Map TxIn (TxOut CtxUTxO BabbageEra))
-> Map (TxIn StandardCrypto) (TxOut EmulatorEra)
-> UTxO BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO BabbageEra)]
-> Map TxIn (TxOut CtxUTxO BabbageEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  ([(TxIn, TxOut CtxUTxO BabbageEra)]
 -> Map TxIn (TxOut CtxUTxO BabbageEra))
-> (Map (TxIn StandardCrypto) (TxOut EmulatorEra)
    -> [(TxIn, TxOut CtxUTxO BabbageEra)])
-> Map (TxIn StandardCrypto) (TxOut EmulatorEra)
-> Map TxIn (TxOut CtxUTxO BabbageEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn StandardCrypto, TxOut EmulatorEra)
 -> (TxIn, TxOut CtxUTxO BabbageEra))
-> [(TxIn StandardCrypto, TxOut EmulatorEra)]
-> [(TxIn, TxOut CtxUTxO BabbageEra)]
forall a b. (a -> b) -> [a] -> [b]
map ((TxIn StandardCrypto -> TxIn)
-> (TxOut EmulatorEra -> TxOut CtxUTxO BabbageEra)
-> (TxIn StandardCrypto, TxOut EmulatorEra)
-> (TxIn, TxOut CtxUTxO BabbageEra)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxIn StandardCrypto -> TxIn
C.Api.fromShelleyTxIn (ShelleyBasedEra BabbageEra
-> TxOut EmulatorEra -> TxOut CtxUTxO BabbageEra
forall era ledgerera ctx.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut ledgerera -> TxOut ctx era
C.Api.fromShelleyTxOut ShelleyBasedEra BabbageEra
C.Api.ShelleyBasedEraBabbage))
  ([(TxIn StandardCrypto, TxOut EmulatorEra)]
 -> [(TxIn, TxOut CtxUTxO BabbageEra)])
-> (Map (TxIn StandardCrypto) (TxOut EmulatorEra)
    -> [(TxIn StandardCrypto, TxOut EmulatorEra)])
-> Map (TxIn StandardCrypto) (TxOut EmulatorEra)
-> [(TxIn, TxOut CtxUTxO BabbageEra)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (TxIn StandardCrypto) (TxOut EmulatorEra)
-> [(TxIn StandardCrypto, TxOut EmulatorEra)]
forall k a. Map k a -> [(k, a)]
Map.toList
  (Map (TxIn StandardCrypto) (TxOut EmulatorEra) -> UTxO BabbageEra)
-> Map (TxIn StandardCrypto) (TxOut EmulatorEra) -> UTxO BabbageEra
forall a b. (a -> b) -> a -> b
$ Map (TxIn StandardCrypto) (TxOut EmulatorEra)
Map (TxIn (Crypto EmulatorEra)) (TxOut EmulatorEra)
utxo

-- Adapted from cardano-api Cardano.API.Fee to avoid PParams conversion
evaluateTransactionFee :: PParams -> C.Api.TxBody C.Api.BabbageEra -> Word -> C.Api.Lovelace
evaluateTransactionFee :: PParams EmulatorEra -> TxBody BabbageEra -> Word -> Lovelace
evaluateTransactionFee PParams EmulatorEra
pparams TxBody BabbageEra
txbody Word
keywitcount = case [KeyWitness BabbageEra] -> TxBody BabbageEra -> Tx BabbageEra
forall era. [KeyWitness era] -> TxBody era -> Tx era
C.Api.makeSignedTransaction [] TxBody BabbageEra
txbody of
      C.Api.ShelleyTx ShelleyBasedEra BabbageEra
_  Tx (ShelleyLedgerEra BabbageEra)
tx -> Tx (ShelleyLedgerEra BabbageEra) -> Lovelace
evalShelleyBasedEra Tx (ShelleyLedgerEra BabbageEra)
tx
  where
    evalShelleyBasedEra :: C.Ledger.Tx (C.Api.ShelleyLedgerEra C.Api.BabbageEra) -> C.Api.Lovelace
    evalShelleyBasedEra :: Tx (ShelleyLedgerEra BabbageEra) -> Lovelace
evalShelleyBasedEra Tx (ShelleyLedgerEra BabbageEra)
tx = Coin -> Lovelace
C.Api.fromShelleyLovelace (Coin -> Lovelace) -> Coin -> Lovelace
forall a b. (a -> b) -> a -> b
$ PParams EmulatorEra -> Tx EmulatorEra -> Word -> Coin
forall era. CLI era => PParams era -> Tx era -> Word -> Coin
C.Ledger.evaluateTransactionFee PParams EmulatorEra
PParams EmulatorEra
pparams Tx (ShelleyLedgerEra BabbageEra)
Tx EmulatorEra
tx Word
keywitcount