{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TupleSections      #-}
{-# LANGUAGE ViewPatterns       #-}
{-| Building cardano transactions from tx bodies
-}
module Convex.CoinSelection(
  -- * Data types
  CoinSelectionError(..),
  bodyError,
  CSInputs(..),
  ERA,
  utxo,
  txBody,
  changeOutput,
  numWitnesses,
  -- * Balancing
  BalancingError(..),
  balanceTransactionBody,
  balanceForWallet,
  balanceForWalletReturn,
  balanceTx,
  signForWallet,
  -- * Balance changes
  balanceChanges,
  requiredTxIns,
  spentTxIns,
  -- * Etc.
  prepCSInputs
  ) where

import           Cardano.Api.Shelley   (BabbageEra, BuildTx, CardanoMode,
                                        EraHistory, PoolId, TxBodyContent,
                                        TxOut, UTxO (..))
import qualified Cardano.Api.Shelley   as C
import           Cardano.Ledger.Crypto (StandardCrypto)
import qualified Cardano.Ledger.Keys   as Keys
import           Cardano.Slotting.Time (SystemStart)
import           Control.Lens          (_1, _2, at, makeLensesFor, over,
                                        preview, set, to, traversed, view, (&),
                                        (.~), (<>~), (?~), (^.), (^..), (|>))
import           Control.Monad         (when)
import           Convex.BuildTx        (addCollateral, execBuildTx,
                                        setMinAdaDeposit, spendPublicKeyOutput)
import           Convex.Class          (MonadBlockchain (..))
import qualified Convex.Lenses         as L
import           Convex.Utxos          (BalanceChanges (..), UtxoSet (..))
import qualified Convex.Utxos          as Utxos
import           Convex.Wallet         (Wallet)
import qualified Convex.Wallet         as Wallet
import           Data.Aeson            (FromJSON, ToJSON)
import           Data.Bifunctor        (Bifunctor (..))
import           Data.Function         (on)
import qualified Data.List             as List
import           Data.Map              (Map)
import qualified Data.Map              as Map
import           Data.Maybe            (isNothing, listToMaybe, mapMaybe,
                                        maybeToList)
import           Data.Ord              (Down (..))
import           Data.Set              (Set)
import qualified Data.Set              as Set
import           Data.Text             (Text)
import qualified Data.Text             as Text
import           GHC.Generics          (Generic)

type ERA = BabbageEra

{- Note [Change Output]

The balancing functions take a "change output" parameter. This is a @TxOut@ value that will
receive any Ada change that's leftover after balancing.

If the change output has a non-zero value (of any currency) then it will be included in the
final transaction regardless of the final balance of the transaction.

-}

{-| Inputs needed for coin selection
-}
data CSInputs =
  CSInputs
    { CSInputs -> UTxO BabbageEra
csiUtxo         :: UTxO ERA -- ^ UTXOs that we need to know about
    , CSInputs -> TxBodyContent BuildTx BabbageEra
csiTxBody       :: TxBodyContent BuildTx ERA -- ^ Tx body to balance
    , CSInputs -> TxOut CtxTx BabbageEra
csiChangeOutput :: C.TxOut C.CtxTx C.BabbageEra -- ^ Change output -- see Note [Change Output]
    , CSInputs -> Word
csiNumWitnesses :: Word -- ^ How many shelley key witnesses there will be
    }

makeLensesFor
  [ ("csiUtxo", "utxo")
  , ("csiTxBody", "txBody")
  , ("csiChangeOutput", "changeOutput")
  , ("csiNumWitnesses", "numWitnesses")
  ] ''CSInputs

data CoinSelectionError =
  UnsupportedBalance (C.TxOutValue ERA)
  | BodyError Text
  | NotEnoughAdaOnlyOutputsFor C.Lovelace
  | NotEnoughMixedOutputsFor{ CoinSelectionError -> [(PolicyId, AssetName, Quantity)]
valuesNeeded :: [(C.PolicyId, C.AssetName, C.Quantity)], CoinSelectionError -> Value
valueProvided :: C.Value, CoinSelectionError -> Value
txBalance :: C.Value }
  deriving stock (Int -> CoinSelectionError -> ShowS
[CoinSelectionError] -> ShowS
CoinSelectionError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CoinSelectionError] -> ShowS
$cshowList :: [CoinSelectionError] -> ShowS
show :: CoinSelectionError -> String
$cshow :: CoinSelectionError -> String
showsPrec :: Int -> CoinSelectionError -> ShowS
$cshowsPrec :: Int -> CoinSelectionError -> ShowS
Show, forall x. Rep CoinSelectionError x -> CoinSelectionError
forall x. CoinSelectionError -> Rep CoinSelectionError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CoinSelectionError x -> CoinSelectionError
$cfrom :: forall x. CoinSelectionError -> Rep CoinSelectionError x
Generic)
  deriving anyclass ([CoinSelectionError] -> Encoding
[CoinSelectionError] -> Value
CoinSelectionError -> Encoding
CoinSelectionError -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CoinSelectionError] -> Encoding
$ctoEncodingList :: [CoinSelectionError] -> Encoding
toJSONList :: [CoinSelectionError] -> Value
$ctoJSONList :: [CoinSelectionError] -> Value
toEncoding :: CoinSelectionError -> Encoding
$ctoEncoding :: CoinSelectionError -> Encoding
toJSON :: CoinSelectionError -> Value
$ctoJSON :: CoinSelectionError -> Value
ToJSON, Value -> Parser [CoinSelectionError]
Value -> Parser CoinSelectionError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CoinSelectionError]
$cparseJSONList :: Value -> Parser [CoinSelectionError]
parseJSON :: Value -> Parser CoinSelectionError
$cparseJSON :: Value -> Parser CoinSelectionError
FromJSON)

bodyError :: C.TxBodyError -> CoinSelectionError
bodyError :: TxBodyError -> CoinSelectionError
bodyError = Text -> CoinSelectionError
BodyError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> String
C.displayError

data BalancingError =
  BalancingError Text
  | CheckMinUtxoValueError (C.TxOut C.CtxTx BabbageEra) C.Lovelace
  | BalanceCheckError BalancingError
  | ComputeBalanceChangeError
  deriving stock (Int -> BalancingError -> ShowS
[BalancingError] -> ShowS
BalancingError -> String
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, 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
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
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)

balancingError :: C.TxBodyErrorAutoBalance -> BalancingError
balancingError :: TxBodyErrorAutoBalance -> BalancingError
balancingError = Text -> BalancingError
BalancingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Error e => e -> String
C.displayError

{-| Perform transaction balancing
-}
balanceTransactionBody :: SystemStart -> EraHistory CardanoMode -> C.BundledProtocolParameters C.BabbageEra -> Set PoolId -> CSInputs -> Either BalancingError (C.BalancedTxBody ERA, BalanceChanges)
balanceTransactionBody :: SystemStart
-> EraHistory CardanoMode
-> BundledProtocolParameters BabbageEra
-> Set PoolId
-> CSInputs
-> Either
     BalancingError (BalancedTxBody BabbageEra, BalanceChanges)
balanceTransactionBody SystemStart
systemStart EraHistory CardanoMode
eraHistory BundledProtocolParameters BabbageEra
protocolParams Set PoolId
stakePools CSInputs{UTxO BabbageEra
csiUtxo :: UTxO BabbageEra
csiUtxo :: CSInputs -> UTxO BabbageEra
csiUtxo, TxBodyContent BuildTx BabbageEra
csiTxBody :: TxBodyContent BuildTx BabbageEra
csiTxBody :: CSInputs -> TxBodyContent BuildTx BabbageEra
csiTxBody, TxOut CtxTx BabbageEra
csiChangeOutput :: TxOut CtxTx BabbageEra
csiChangeOutput :: CSInputs -> TxOut CtxTx BabbageEra
csiChangeOutput, Word
csiNumWitnesses :: Word
csiNumWitnesses :: CSInputs -> Word
csiNumWitnesses} = do
  let mkChangeOutputFor :: IxValue (Map AssetId Quantity) -> TxOut CtxTx BabbageEra
mkChangeOutputFor IxValue (Map AssetId Quantity)
i = TxOut CtxTx BabbageEra
csiChangeOutput forall a b. a -> (a -> b) -> b
& forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' Value (Map AssetId Quantity)
L._Value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at AssetId
C.AdaAssetId forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ IxValue (Map AssetId Quantity)
i
      changeOutputSmall :: TxOut CtxTx BabbageEra
changeOutputSmall = IxValue (Map AssetId Quantity) -> TxOut CtxTx BabbageEra
mkChangeOutputFor IxValue (Map AssetId Quantity)
1
      changeOutputLarge :: TxOut CtxTx BabbageEra
changeOutputLarge = IxValue (Map AssetId Quantity) -> TxOut CtxTx BabbageEra
mkChangeOutputFor ((IxValue (Map AssetId Quantity)
2forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
64 :: Integer)) forall a. Num a => a -> a -> a
- IxValue (Map AssetId Quantity)
1)
  -- append output instead of prepending
  TxBody BabbageEra
txbody0 <-
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TxBodyErrorAutoBalance -> BalancingError
balancingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> TxBodyErrorAutoBalance
C.TxBodyError) forall a b. (a -> b) -> a -> b
$ forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
C.createAndValidateTransactionBody forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx BabbageEra
csiTxBody forall a b. a -> (a -> b) -> b
& TxOut CtxTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
appendTxOut TxOut CtxTx BabbageEra
changeOutputSmall

  Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
exUnitsMap <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TxBodyErrorAutoBalance -> BalancingError
balancingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionValidityError -> TxBodyErrorAutoBalance
C.TxBodyErrorValidityInterval) forall a b. (a -> b) -> a -> b
$
                forall era.
SystemStart
-> LedgerEpochInfo
-> BundledProtocolParameters era
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
C.evaluateTransactionExecutionUnits
                SystemStart
systemStart (forall mode. EraHistory mode -> LedgerEpochInfo
C.toLedgerEpochInfo EraHistory CardanoMode
eraHistory)
                BundledProtocolParameters BabbageEra
protocolParams
                UTxO BabbageEra
csiUtxo
                TxBody BabbageEra
txbody0

  Map ScriptWitnessIndex ExecutionUnits
exUnitsMap' <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TxBodyErrorAutoBalance -> BalancingError
balancingError forall a b. (a -> b) -> a -> b
$
    case forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither forall a. a -> a
id Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
exUnitsMap of
      (Map ScriptWitnessIndex ScriptExecutionError
failures, Map ScriptWitnessIndex ExecutionUnits
exUnitsMap') ->
        ScriptValidity
-> Map ScriptWitnessIndex ScriptExecutionError
-> Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
handleExUnitsErrors ScriptValidity
C.ScriptValid Map ScriptWitnessIndex ScriptExecutionError
failures Map ScriptWitnessIndex ExecutionUnits
exUnitsMap' -- TODO: should this take the script validity from csiTxBody?

  let txbodycontent1 :: TxBodyContent BuildTx BabbageEra
txbodycontent1 = Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
substituteExecutionUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap' TxBodyContent BuildTx BabbageEra
csiTxBody

  -- append output instead of prepending
  TxBody BabbageEra
txbody1 <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TxBodyErrorAutoBalance -> BalancingError
balancingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> TxBodyErrorAutoBalance
C.TxBodyError)
              forall a b. (a -> b) -> a -> b
$ forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
C.createAndValidateTransactionBody
              forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx BabbageEra
txbodycontent1
                  forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set forall v. Lens' (TxBodyContent v BabbageEra) Lovelace
L.txFee (Integer -> Lovelace
C.Lovelace (Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
32 :: Integer) forall a. Num a => a -> a -> a
- Integer
1))
                  forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall v.
Lens' (TxBodyContent v BabbageEra) [TxOut CtxTx BabbageEra]
L.txOuts (forall s a. Snoc s s a a => s -> a -> s
|> TxOut CtxTx BabbageEra
changeOutputLarge)

  let !t_fee :: Lovelace
t_fee = forall era.
IsShelleyBasedEra era =>
BundledProtocolParameters era
-> TxBody era -> Word -> Word -> Lovelace
C.evaluateTransactionFee BundledProtocolParameters BabbageEra
protocolParams TxBody BabbageEra
txbody1 Word
csiNumWitnesses Word
0

  TxBody BabbageEra
txbody2 <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TxBodyErrorAutoBalance -> BalancingError
balancingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> TxBodyErrorAutoBalance
C.TxBodyError)
              forall a b. (a -> b) -> a -> b
$ forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
C.createAndValidateTransactionBody
              forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx BabbageEra
txbodycontent1 forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set forall v. Lens' (TxBodyContent v BabbageEra) Lovelace
L.txFee Lovelace
t_fee forall a b. a -> (a -> b) -> b
& TxOut CtxTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
appendTxOut TxOut CtxTx BabbageEra
csiChangeOutput

  -- TODO: If there are any stake pool unregistration certificates in the transaction
  -- then we need to provide a @Map StakeCredential Lovelace@ here.
  -- See https://github.com/input-output-hk/cardano-api/commit/d23f964d311282b1950b2fd840bcc57ae40a0998
  let unregPoolStakeBalance :: Map StakeCredential Lovelace
unregPoolStakeBalance = forall a. Monoid a => a
mempty

  let !balance :: TxOutValue BabbageEra
balance = forall era.
IsShelleyBasedEra era =>
BundledProtocolParameters era
-> Set PoolId
-> Map StakeCredential Lovelace
-> UTxO era
-> TxBody era
-> TxOutValue era
C.evaluateTransactionBalance BundledProtocolParameters BabbageEra
protocolParams Set PoolId
stakePools Map StakeCredential Lovelace
unregPoolStakeBalance UTxO BabbageEra
csiUtxo TxBody BabbageEra
txbody2

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TxOut CtxTx BabbageEra
-> BundledProtocolParameters BabbageEra -> Either BalancingError ()
`checkMinUTxOValue` BundledProtocolParameters BabbageEra
protocolParams) forall a b. (a -> b) -> a -> b
$ forall build era. TxBodyContent build era -> [TxOut CtxTx era]
C.txOuts TxBodyContent BuildTx BabbageEra
txbodycontent1

  TxOut CtxTx BabbageEra
changeOutputBalance <- case TxOutValue BabbageEra
balance of
    C.TxOutAdaOnly OnlyAdaSupportedInEra BabbageEra
_ Lovelace
b -> do
      let op :: TxOut CtxTx BabbageEra
op = TxOut CtxTx BabbageEra
csiChangeOutput forall a b. a -> (a -> b) -> b
& forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' Value (Map AssetId Quantity)
L._Value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at AssetId
C.AdaAssetId forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Lovelace -> Quantity
C.lovelaceToQuantity Lovelace
b)
      BundledProtocolParameters BabbageEra
-> TxOut CtxTx BabbageEra -> Either BalancingError ()
balanceCheck BundledProtocolParameters BabbageEra
protocolParams TxOut CtxTx BabbageEra
op
      forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut CtxTx BabbageEra
op
    C.TxOutValue MultiAssetSupportedInEra BabbageEra
_ Value
v -> do
      case Value -> Maybe Lovelace
C.valueToLovelace Value
v of
        -- FIXME: Support non Ada assets
        Maybe Lovelace
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ TxBodyErrorAutoBalance -> BalancingError
balancingError forall a b. (a -> b) -> a -> b
$ Value -> TxBodyErrorAutoBalance
C.TxBodyErrorNonAdaAssetsUnbalanced Value
v
        Just Lovelace
lvl  ->  do
          let op :: TxOut CtxTx BabbageEra
op = TxOut CtxTx BabbageEra
csiChangeOutput forall a b. a -> (a -> b) -> b
& forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' Value (Map AssetId Quantity)
L._Value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at AssetId
C.AdaAssetId forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Lovelace -> Quantity
C.lovelaceToQuantity Lovelace
lvl)
          BundledProtocolParameters BabbageEra
-> TxOut CtxTx BabbageEra -> Either BalancingError ()
balanceCheck BundledProtocolParameters BabbageEra
protocolParams TxOut CtxTx BabbageEra
op
          forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut CtxTx BabbageEra
op

  let finalBodyContent :: TxBodyContent BuildTx BabbageEra
finalBodyContent =
        TxBodyContent BuildTx BabbageEra
txbodycontent1
          forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set forall v. Lens' (TxBodyContent v BabbageEra) Lovelace
L.txFee Lovelace
t_fee
          forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall v.
Lens' (TxBodyContent v BabbageEra) [TxOut CtxTx BabbageEra]
L.txOuts (TxOut CtxTx BabbageEra
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
accountForNoChange TxOut CtxTx BabbageEra
changeOutputBalance)

  TxBody BabbageEra
txbody3 <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TxBodyErrorAutoBalance -> BalancingError
balancingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyError -> TxBodyErrorAutoBalance
C.TxBodyError) forall a b. (a -> b) -> a -> b
$ forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
C.createAndValidateTransactionBody TxBodyContent BuildTx BabbageEra
finalBodyContent

  BalanceChanges
balances <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left BalancingError
ComputeBalanceChangeError) forall a b. b -> Either a b
Right (UTxO BabbageEra
-> TxBodyContent BuildTx BabbageEra -> Maybe BalanceChanges
balanceChanges UTxO BabbageEra
csiUtxo TxBodyContent BuildTx BabbageEra
finalBodyContent)

  let mkBalancedBody :: TxBody BabbageEra -> BalancedTxBody BabbageEra
mkBalancedBody TxBody BabbageEra
b = forall era.
TxBodyContent BuildTx era
-> TxBody era -> TxOut CtxTx era -> Lovelace -> BalancedTxBody era
C.BalancedTxBody TxBodyContent BuildTx BabbageEra
finalBodyContent TxBody BabbageEra
b TxOut CtxTx BabbageEra
changeOutputBalance Lovelace
t_fee
  forall (m :: * -> *) a. Monad m => a -> m a
return (TxBody BabbageEra -> BalancedTxBody BabbageEra
mkBalancedBody TxBody BabbageEra
txbody3, BalanceChanges
balances)

checkMinUTxOValue
  :: C.TxOut C.CtxTx C.BabbageEra
  -> C.BundledProtocolParameters C.BabbageEra
  -> Either BalancingError ()
checkMinUTxOValue :: TxOut CtxTx BabbageEra
-> BundledProtocolParameters BabbageEra -> Either BalancingError ()
checkMinUTxOValue txout :: TxOut CtxTx BabbageEra
txout@(C.TxOut AddressInEra BabbageEra
_ TxOutValue BabbageEra
v TxOutDatum CtxTx BabbageEra
_ ReferenceScript BabbageEra
_) BundledProtocolParameters BabbageEra
pparams' = do
  let minUTxO :: Lovelace
minUTxO  = forall era.
ShelleyBasedEra era
-> TxOut CtxTx era -> BundledProtocolParameters era -> Lovelace
C.calculateMinimumUTxO ShelleyBasedEra BabbageEra
C.ShelleyBasedEraBabbage TxOut CtxTx BabbageEra
txout BundledProtocolParameters BabbageEra
pparams'
  if forall era. TxOutValue era -> Lovelace
C.txOutValueToLovelace TxOutValue BabbageEra
v forall a. Ord a => a -> a -> Bool
>= Lovelace
minUTxO
  then forall a b. b -> Either a b
Right ()
  else forall a b. a -> Either a b
Left (TxOut CtxTx BabbageEra -> Lovelace -> BalancingError
CheckMinUtxoValueError TxOut CtxTx BabbageEra
txout Lovelace
minUTxO)

appendTxOut :: C.TxOut C.CtxTx C.BabbageEra -> C.TxBodyContent C.BuildTx ERA -> C.TxBodyContent C.BuildTx ERA
appendTxOut :: TxOut CtxTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
appendTxOut TxOut CtxTx BabbageEra
out = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall v.
Lens' (TxBodyContent v BabbageEra) [TxOut CtxTx BabbageEra]
L.txOuts (forall s a. Snoc s s a a => s -> a -> s
|> TxOut CtxTx BabbageEra
out)

accountForNoChange :: C.TxOut C.CtxTx C.BabbageEra -> [C.TxOut C.CtxTx C.BabbageEra] -> [C.TxOut C.CtxTx C.BabbageEra]
accountForNoChange :: TxOut CtxTx BabbageEra
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
accountForNoChange change :: TxOut CtxTx BabbageEra
change@(C.TxOut AddressInEra BabbageEra
_ TxOutValue BabbageEra
balance TxOutDatum CtxTx BabbageEra
_ ReferenceScript BabbageEra
_) [TxOut CtxTx BabbageEra]
rest =
  case forall era. TxOutValue era -> Lovelace
C.txOutValueToLovelace TxOutValue BabbageEra
balance of
    C.Lovelace Integer
0 -> [TxOut CtxTx BabbageEra]
rest
    Lovelace
_ ->
      -- checks if there already exists a txout with same address
      -- that contains only ada tokens and no datum hash. If it exists then add change
      -- instead of creating a new txout, i.e., rest ++ [change]
      TxOut CtxTx BabbageEra
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
updateRestWithChange TxOut CtxTx BabbageEra
change [TxOut CtxTx BabbageEra]
rest

{-| Check that the output has a positive Ada balance greater than or equal to the minimum
UTxO requirement
-}
balanceCheck :: C.BundledProtocolParameters C.BabbageEra -> C.TxOut C.CtxTx C.BabbageEra-> Either BalancingError ()
balanceCheck :: BundledProtocolParameters BabbageEra
-> TxOut CtxTx BabbageEra -> Either BalancingError ()
balanceCheck BundledProtocolParameters BabbageEra
pparams TxOut CtxTx BabbageEra
output =
  let balance :: TxOutValue BabbageEra
balance = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) TxOut CtxTx BabbageEra
output in
    if forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Iso' (TxOutValue BabbageEra) Value
L._TxOutValue TxOutValue BabbageEra
balance forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty
      then forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall era. TxOutValue era -> Lovelace
C.txOutValueToLovelace TxOutValue BabbageEra
balance forall a. Ord a => a -> a -> Bool
< Lovelace
0) (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyErrorAutoBalance -> BalancingError
balancingError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lovelace -> TxBodyErrorAutoBalance
C.TxBodyErrorAdaBalanceNegative forall a b. (a -> b) -> a -> b
$ forall era. TxOutValue era -> Lovelace
C.txOutValueToLovelace TxOutValue BabbageEra
balance)
        forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap BalancingError -> BalancingError
BalanceCheckError (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ TxOut CtxTx BabbageEra
-> BundledProtocolParameters BabbageEra -> Either BalancingError ()
checkMinUTxOValue TxOut CtxTx BabbageEra
output BundledProtocolParameters BabbageEra
pparams

updateRestWithChange :: C.TxOut C.CtxTx C.BabbageEra -> [C.TxOut C.CtxTx C.BabbageEra] -> [C.TxOut C.CtxTx C.BabbageEra]
updateRestWithChange :: TxOut CtxTx BabbageEra
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
updateRestWithChange TxOut CtxTx BabbageEra
change [] = [TxOut CtxTx BabbageEra
change]
updateRestWithChange change :: TxOut CtxTx BabbageEra
change@(C.TxOut AddressInEra BabbageEra
caddr TxOutValue BabbageEra
cv TxOutDatum CtxTx BabbageEra
_ ReferenceScript BabbageEra
_) (txout :: TxOut CtxTx BabbageEra
txout@(C.TxOut AddressInEra BabbageEra
addr (C.TxOutAdaOnly OnlyAdaSupportedInEra BabbageEra
e Lovelace
v) TxOutDatum CtxTx BabbageEra
C.TxOutDatumNone ReferenceScript BabbageEra
_) : [TxOut CtxTx BabbageEra]
tl)
  | AddressInEra BabbageEra
addr forall a. Eq a => a -> a -> Bool
== AddressInEra BabbageEra
caddr =
      (forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
C.TxOut AddressInEra BabbageEra
addr (forall era. OnlyAdaSupportedInEra era -> Lovelace -> TxOutValue era
C.TxOutAdaOnly OnlyAdaSupportedInEra BabbageEra
e ((forall era. TxOutValue era -> Lovelace
C.txOutValueToLovelace TxOutValue BabbageEra
cv) forall a. Semigroup a => a -> a -> a
<> Lovelace
v)) forall ctx era. TxOutDatum ctx era
C.TxOutDatumNone forall era. ReferenceScript era
C.ReferenceScriptNone) forall a. a -> [a] -> [a]
: [TxOut CtxTx BabbageEra]
tl
  | Bool
otherwise = TxOut CtxTx BabbageEra
txout forall a. a -> [a] -> [a]
: (TxOut CtxTx BabbageEra
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
updateRestWithChange TxOut CtxTx BabbageEra
change [TxOut CtxTx BabbageEra]
tl)

updateRestWithChange change :: TxOut CtxTx BabbageEra
change@(C.TxOut AddressInEra BabbageEra
caddr TxOutValue BabbageEra
cv TxOutDatum CtxTx BabbageEra
_ ReferenceScript BabbageEra
_) (txout :: TxOut CtxTx BabbageEra
txout@(C.TxOut AddressInEra BabbageEra
addr (C.TxOutValue MultiAssetSupportedInEra BabbageEra
e Value
v) TxOutDatum CtxTx BabbageEra
C.TxOutDatumNone ReferenceScript BabbageEra
_) : [TxOut CtxTx BabbageEra]
tl)
  | AddressInEra BabbageEra
addr forall a. Eq a => a -> a -> Bool
== AddressInEra BabbageEra
caddr =
    case Value -> Maybe Lovelace
C.valueToLovelace Value
v of
      Maybe Lovelace
Nothing -> TxOut CtxTx BabbageEra
txout forall a. a -> [a] -> [a]
: (TxOut CtxTx BabbageEra
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
updateRestWithChange TxOut CtxTx BabbageEra
change [TxOut CtxTx BabbageEra]
tl)
      Just Lovelace
l ->
        (forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
C.TxOut AddressInEra BabbageEra
addr (forall era. MultiAssetSupportedInEra era -> Value -> TxOutValue era
C.TxOutValue MultiAssetSupportedInEra BabbageEra
e (Lovelace -> Value
C.lovelaceToValue forall a b. (a -> b) -> a -> b
$ (forall era. TxOutValue era -> Lovelace
C.txOutValueToLovelace TxOutValue BabbageEra
cv) forall a. Semigroup a => a -> a -> a
<> Lovelace
l)) forall ctx era. TxOutDatum ctx era
C.TxOutDatumNone forall era. ReferenceScript era
C.ReferenceScriptNone) forall a. a -> [a] -> [a]
: [TxOut CtxTx BabbageEra]
tl

updateRestWithChange TxOut CtxTx BabbageEra
change (TxOut CtxTx BabbageEra
txout : [TxOut CtxTx BabbageEra]
tl) = TxOut CtxTx BabbageEra
txout forall a. a -> [a] -> [a]
: (TxOut CtxTx BabbageEra
-> [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra]
updateRestWithChange TxOut CtxTx BabbageEra
change [TxOut CtxTx BabbageEra]
tl)

handleExUnitsErrors ::
     C.ScriptValidity -- ^ Mark script as expected to pass or fail validation
  -> Map C.ScriptWitnessIndex C.ScriptExecutionError
  -> Map C.ScriptWitnessIndex C.ExecutionUnits
  -> Either C.TxBodyErrorAutoBalance (Map C.ScriptWitnessIndex C.ExecutionUnits)
handleExUnitsErrors :: ScriptValidity
-> Map ScriptWitnessIndex ScriptExecutionError
-> Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
handleExUnitsErrors ScriptValidity
C.ScriptValid Map ScriptWitnessIndex ScriptExecutionError
failuresMap Map ScriptWitnessIndex ExecutionUnits
exUnitsMap =
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ScriptWitnessIndex, ScriptExecutionError)]
failures
      then forall a b. b -> Either a b
Right Map ScriptWitnessIndex ExecutionUnits
exUnitsMap
      else forall a b. a -> Either a b
Left ([(ScriptWitnessIndex, ScriptExecutionError)]
-> TxBodyErrorAutoBalance
C.TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]
failures)
  where failures :: [(C.ScriptWitnessIndex, C.ScriptExecutionError)]
        failures :: [(ScriptWitnessIndex, ScriptExecutionError)]
failures = forall k a. Map k a -> [(k, a)]
Map.toList Map ScriptWitnessIndex ScriptExecutionError
failuresMap
handleExUnitsErrors ScriptValidity
C.ScriptInvalid Map ScriptWitnessIndex ScriptExecutionError
failuresMap Map ScriptWitnessIndex ExecutionUnits
exUnitsMap
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ScriptWitnessIndex, ScriptExecutionError)]
scriptFailures = forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
C.TxBodyScriptBadScriptValidity
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ScriptWitnessIndex, ScriptExecutionError)]
nonScriptFailures = forall a b. b -> Either a b
Right Map ScriptWitnessIndex ExecutionUnits
exUnitsMap
  | Bool
otherwise = forall a b. a -> Either a b
Left ([(ScriptWitnessIndex, ScriptExecutionError)]
-> TxBodyErrorAutoBalance
C.TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]
nonScriptFailures)
  where nonScriptFailures :: [(C.ScriptWitnessIndex, C.ScriptExecutionError)]
        nonScriptFailures :: [(ScriptWitnessIndex, ScriptExecutionError)]
nonScriptFailures = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptWitnessIndex, ScriptExecutionError) -> Bool
isScriptErrorEvaluationFailed) (forall k a. Map k a -> [(k, a)]
Map.toList Map ScriptWitnessIndex ScriptExecutionError
failuresMap)
        scriptFailures :: [(C.ScriptWitnessIndex, C.ScriptExecutionError)]
        scriptFailures :: [(ScriptWitnessIndex, ScriptExecutionError)]
scriptFailures = forall a. (a -> Bool) -> [a] -> [a]
filter (ScriptWitnessIndex, ScriptExecutionError) -> Bool
isScriptErrorEvaluationFailed (forall k a. Map k a -> [(k, a)]
Map.toList Map ScriptWitnessIndex ScriptExecutionError
failuresMap)
        isScriptErrorEvaluationFailed :: (C.ScriptWitnessIndex, C.ScriptExecutionError) -> Bool
        isScriptErrorEvaluationFailed :: (ScriptWitnessIndex, ScriptExecutionError) -> Bool
isScriptErrorEvaluationFailed (ScriptWitnessIndex
_, ScriptExecutionError
e) = case ScriptExecutionError
e of
            C.ScriptErrorEvaluationFailed EvaluationError
_ [Text]
_ -> Bool
True
            ScriptExecutionError
_                                 -> Bool
True

substituteExecutionUnits :: Map C.ScriptWitnessIndex C.ExecutionUnits
                         -> C.TxBodyContent C.BuildTx C.BabbageEra
                         -> C.TxBodyContent C.BuildTx C.BabbageEra
substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
substituteExecutionUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap =
    (forall witctx.
 ScriptWitnessIndex
 -> ScriptWitness witctx BabbageEra
 -> ScriptWitness witctx BabbageEra)
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
mapTxScriptWitnesses forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx BabbageEra
-> ScriptWitness witctx BabbageEra
f
  where
    f :: C.ScriptWitnessIndex
      -> C.ScriptWitness witctx C.BabbageEra
      -> C.ScriptWitness witctx C.BabbageEra
    f :: forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx BabbageEra
-> ScriptWitness witctx BabbageEra
f ScriptWitnessIndex
_   wit :: ScriptWitness witctx BabbageEra
wit@C.SimpleScriptWitness{} = ScriptWitness witctx BabbageEra
wit
    f ScriptWitnessIndex
idx wit :: ScriptWitness witctx BabbageEra
wit@(C.PlutusScriptWitness ScriptLanguageInEra lang BabbageEra
langInEra PlutusScriptVersion lang
version PlutusScriptOrReferenceInput lang
script ScriptDatum witctx
datum ScriptRedeemer
redeemer ExecutionUnits
_) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptWitnessIndex
idx Map ScriptWitnessIndex ExecutionUnits
exUnitsMap of
        Maybe ExecutionUnits
Nothing      -> ScriptWitness witctx BabbageEra
wit
        Just ExecutionUnits
exunits ->
          forall lang era witctx.
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> ScriptRedeemer
-> ExecutionUnits
-> ScriptWitness witctx era
C.PlutusScriptWitness ScriptLanguageInEra lang BabbageEra
langInEra PlutusScriptVersion lang
version PlutusScriptOrReferenceInput lang
script ScriptDatum witctx
datum ScriptRedeemer
redeemer ExecutionUnits
exunits

-- | same behaviour as in Cardano.Api.TxBody. However, we do not consider withwdrawals,
-- certificates as not required for the time being.
mapTxScriptWitnesses :: (forall witctx. C.ScriptWitnessIndex
                                     -> C.ScriptWitness witctx C.BabbageEra
                                     -> C.ScriptWitness witctx C.BabbageEra)
                     -> C.TxBodyContent C.BuildTx C.BabbageEra
                     -> C.TxBodyContent C.BuildTx C.BabbageEra
mapTxScriptWitnesses :: (forall witctx.
 ScriptWitnessIndex
 -> ScriptWitness witctx BabbageEra
 -> ScriptWitness witctx BabbageEra)
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
mapTxScriptWitnesses forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx BabbageEra
-> ScriptWitness witctx BabbageEra
f txbodycontent :: TxBodyContent BuildTx BabbageEra
txbodycontent@C.TxBodyContent {
                         [TxIn BuildTx]
txIns :: forall build era. TxBodyContent build era -> TxIns build era
txIns :: [TxIn BuildTx]
C.txIns,
                         TxMintValue BuildTx BabbageEra
txMintValue :: forall build era. TxBodyContent build era -> TxMintValue build era
txMintValue :: TxMintValue BuildTx BabbageEra
C.txMintValue
                       } =
    TxBodyContent BuildTx BabbageEra
txbodycontent {
      txIns :: [TxIn BuildTx]
C.txIns          = [TxIn BuildTx] -> [TxIn BuildTx]
mapScriptWitnessesTxIns [TxIn BuildTx]
txIns
    , txMintValue :: TxMintValue BuildTx BabbageEra
C.txMintValue    = TxMintValue BuildTx BabbageEra -> TxMintValue BuildTx BabbageEra
mapScriptWitnessesMinting TxMintValue BuildTx BabbageEra
txMintValue
    }
  where
    mapScriptWitnessesTxIns
      :: [(C.TxIn, C.BuildTxWith C.BuildTx (C.Witness C.WitCtxTxIn C.BabbageEra))]
      -> [(C.TxIn, C.BuildTxWith C.BuildTx (C.Witness C.WitCtxTxIn C.BabbageEra))]
    mapScriptWitnessesTxIns :: [TxIn BuildTx] -> [TxIn BuildTx]
mapScriptWitnessesTxIns [TxIn BuildTx]
txins =
        [ (TxIn
txin, forall a. a -> BuildTxWith BuildTx a
C.BuildTxWith Witness WitCtxTxIn BabbageEra
wit')
          -- keep txins order
        | (Word
ix, (TxIn
txin, C.BuildTxWith Witness WitCtxTxIn BabbageEra
wit)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0..] forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) [TxIn BuildTx]
txins
        , let wit' :: Witness WitCtxTxIn BabbageEra
wit' = case Witness WitCtxTxIn BabbageEra
wit of
                       C.KeyWitness{}              -> Witness WitCtxTxIn BabbageEra
wit
                       C.ScriptWitness ScriptWitnessInCtx WitCtxTxIn
ctx ScriptWitness WitCtxTxIn BabbageEra
witness -> forall witctx era.
ScriptWitnessInCtx witctx
-> ScriptWitness witctx era -> Witness witctx era
C.ScriptWitness ScriptWitnessInCtx WitCtxTxIn
ctx ScriptWitness WitCtxTxIn BabbageEra
witness'
                         where
                           witness' :: ScriptWitness WitCtxTxIn BabbageEra
witness' = forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx BabbageEra
-> ScriptWitness witctx BabbageEra
f (Word -> ScriptWitnessIndex
C.ScriptWitnessIndexTxIn Word
ix) ScriptWitness WitCtxTxIn BabbageEra
witness
        ]

    mapScriptWitnessesMinting
      :: C.TxMintValue C.BuildTx C.BabbageEra
      -> C.TxMintValue C.BuildTx C.BabbageEra
    mapScriptWitnessesMinting :: TxMintValue BuildTx BabbageEra -> TxMintValue BuildTx BabbageEra
mapScriptWitnessesMinting  TxMintValue BuildTx BabbageEra
C.TxMintNone = forall build era. TxMintValue build era
C.TxMintNone
    mapScriptWitnessesMinting (C.TxMintValue MultiAssetSupportedInEra BabbageEra
supported Value
v
                                           (C.BuildTxWith Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
witnesses)) =
      forall era build.
MultiAssetSupportedInEra era
-> Value
-> BuildTxWith build (Map PolicyId (ScriptWitness WitCtxMint era))
-> TxMintValue build era
C.TxMintValue MultiAssetSupportedInEra BabbageEra
supported Value
v forall a b. (a -> b) -> a -> b
$ forall a. a -> BuildTxWith BuildTx a
C.BuildTxWith forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (PolicyId
policyid, ScriptWitness WitCtxMint BabbageEra
witness')
          -- The minting policies are indexed in policy id order in the value
        | let C.ValueNestedRep [ValueNestedBundle]
bundle = Value -> ValueNestedRep
C.valueToNestedRep Value
v
        , (Word
ix, C.ValueNestedBundle PolicyId
policyid Map AssetName Quantity
_) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0..] [ValueNestedBundle]
bundle
        , ScriptWitness WitCtxMint BabbageEra
witness <- forall a. Maybe a -> [a]
maybeToList (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PolicyId
policyid Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
witnesses)
        , let witness' :: ScriptWitness WitCtxMint BabbageEra
witness' = forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx BabbageEra
-> ScriptWitness witctx BabbageEra
f (Word -> ScriptWitnessIndex
C.ScriptWitnessIndexMint Word
ix) ScriptWitness WitCtxMint BabbageEra
witness
        ]

{-| Get the 'BalanceChanges' for a tx body. Returns 'Nothing' if
a UTXO couldnt be found
-}
balanceChanges :: UTxO ERA -> TxBodyContent BuildTx ERA -> Maybe BalanceChanges
balanceChanges :: UTxO BabbageEra
-> TxBodyContent BuildTx BabbageEra -> Maybe BalanceChanges
balanceChanges (C.UTxO Map TxIn (TxOut CtxUTxO BabbageEra)
lookups) TxBodyContent BuildTx BabbageEra
body = do
  let outputs :: BalanceChanges
outputs = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall ctx. TxOut ctx BabbageEra -> BalanceChanges
txOutChange (TxBodyContent BuildTx BabbageEra
body forall s a. s -> Getting a s a -> a
^. forall v.
Lens' (TxBodyContent v BabbageEra) [TxOut CtxTx BabbageEra]
L.txOuts)
  BalanceChanges
inputs <- BalanceChanges -> BalanceChanges
Utxos.invBalanceChange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall ctx. TxOut ctx BabbageEra -> BalanceChanges
txOutChange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> a
id) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(TxIn
txi, BuildTxWith BuildTx (Witness WitCtxTxIn BabbageEra)
_) -> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txi Map TxIn (TxOut CtxUTxO BabbageEra)
lookups) (TxBodyContent BuildTx BabbageEra
body forall s a. s -> Getting a s a -> a
^. forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (BalanceChanges
outputs forall a. Semigroup a => a -> a -> a
<> BalanceChanges
inputs)

txOutChange :: TxOut ctx C.BabbageEra -> BalanceChanges
txOutChange :: forall ctx. TxOut ctx BabbageEra -> BalanceChanges
txOutChange (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut -> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PaymentCredential StandardCrypto -> PaymentCredential
C.fromShelleyPaymentCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Prism' (AddressInEra BabbageEra) (Address ShelleyAddr)
L._AddressInEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso'
  (Address ShelleyAddr)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._Address forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) -> Just PaymentCredential
addr, forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Iso' (TxOutValue BabbageEra) Value
L._TxOutValue -> Value
value, TxOutDatum ctx BabbageEra
_, ReferenceScript BabbageEra
_)) =
  Map PaymentCredential Value -> BalanceChanges
BalanceChanges (forall k a. k -> a -> Map k a
Map.singleton PaymentCredential
addr Value
value)
txOutChange TxOut ctx BabbageEra
_ = forall a. Monoid a => a
mempty

{-| Balance the transaction using the given UTXOs and return address. This
calls 'balanceTransactionBody' after preparing all the required inputs.
-}
balanceTx ::
  (MonadBlockchain m, MonadFail m) =>

  -- | Return output used for leftover funds. This output will be used for
  --   balancing, and it will be added to the transaction
  --   IF the funds locked in it (after balancing) are non zero.
  C.TxOut C.CtxTx C.BabbageEra ->

  -- | Set of UTxOs that can be used to supply missing funds
  UtxoSet C.CtxUTxO a ->

  -- | The unbalanced transaction body
  TxBodyContent BuildTx ERA ->

  -- | The balanced transaction body and the balance changes (per address)
  m (C.BalancedTxBody ERA, BalanceChanges)
balanceTx :: forall (m :: * -> *) a.
(MonadBlockchain m, MonadFail m) =>
TxOut CtxTx BabbageEra
-> UtxoSet CtxUTxO a
-> TxBodyContent BuildTx BabbageEra
-> m (BalancedTxBody BabbageEra, BalanceChanges)
balanceTx TxOut CtxTx BabbageEra
returnUTxO0 UtxoSet CtxUTxO a
walletUtxo TxBodyContent BuildTx BabbageEra
txb = do
  BundledProtocolParameters BabbageEra
params <- forall (m :: * -> *).
MonadBlockchain m =>
m (BundledProtocolParameters BabbageEra)
queryProtocolParameters
  Set PoolId
pools <- forall (m :: * -> *). MonadBlockchain m => m (Set PoolId)
queryStakePools
  let txb0 :: TxBodyContent BuildTx BabbageEra
txb0 = TxBodyContent BuildTx BabbageEra
txb forall a b. a -> (a -> b) -> b
& forall v e.
Lens'
  (TxBodyContent v e) (BuildTxWith v (Maybe ProtocolParameters))
L.txProtocolParams forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> BuildTxWith BuildTx a
C.BuildTxWith (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall era. BundledProtocolParameters era -> ProtocolParameters
C.unbundleProtocolParams BundledProtocolParameters BabbageEra
params)
  -- TODO: Better error handling (better than 'fail')
  UTxO BabbageEra
otherInputs <- forall (m :: * -> *).
MonadBlockchain m =>
Set TxIn -> m (UTxO BabbageEra)
lookupTxIns (forall v. TxBodyContent v BabbageEra -> Set TxIn
requiredTxIns TxBodyContent BuildTx BabbageEra
txb)
  let combinedTxIns :: UTxO BabbageEra
combinedTxIns =
        let UtxoSet Map TxIn (TxOut CtxUTxO BabbageEra, a)
w = UtxoSet CtxUTxO a
walletUtxo
            UTxO Map TxIn (TxOut CtxUTxO BabbageEra)
o = UTxO BabbageEra
otherInputs
        in forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
UTxO (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Map TxIn (TxOut CtxUTxO BabbageEra, a)
w) Map TxIn (TxOut CtxUTxO BabbageEra)
o)
  (TxBodyContent BuildTx BabbageEra
finalBody, TxOut CtxTx BabbageEra
returnUTxO1) <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall ctx a.
Set PoolId
-> BundledProtocolParameters BabbageEra
-> UTxO BabbageEra
-> TxOut CtxTx BabbageEra
-> UtxoSet ctx a
-> TxBodyContent BuildTx BabbageEra
-> Either
     CoinSelectionError
     (TxBodyContent BuildTx BabbageEra, TxOut CtxTx BabbageEra)
addMissingInputs Set PoolId
pools BundledProtocolParameters BabbageEra
params UTxO BabbageEra
combinedTxIns TxOut CtxTx BabbageEra
returnUTxO0 UtxoSet CtxUTxO a
walletUtxo (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ctx a.
TxBodyContent BuildTx BabbageEra
-> UtxoSet ctx a -> TxBodyContent BuildTx BabbageEra
setCollateral UtxoSet CtxUTxO a
walletUtxo forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ctx a.
TxBodyContent BuildTx BabbageEra
-> UtxoSet ctx a -> TxBodyContent BuildTx BabbageEra
addOwnInput UtxoSet CtxUTxO a
walletUtxo TxBodyContent BuildTx BabbageEra
txb0))
  CSInputs
csi <- forall (m :: * -> *).
MonadBlockchain m =>
TxOut CtxTx BabbageEra
-> UTxO BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> m CSInputs
prepCSInputs TxOut CtxTx BabbageEra
returnUTxO1 UTxO BabbageEra
combinedTxIns TxBodyContent BuildTx BabbageEra
finalBody
  SystemStart
start <- forall (m :: * -> *). MonadBlockchain m => m SystemStart
querySystemStart
  EraHistory CardanoMode
hist <- forall (m :: * -> *).
MonadBlockchain m =>
m (EraHistory CardanoMode)
queryEraHistory
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure (SystemStart
-> EraHistory CardanoMode
-> BundledProtocolParameters BabbageEra
-> Set PoolId
-> CSInputs
-> Either
     BalancingError (BalancedTxBody BabbageEra, BalanceChanges)
balanceTransactionBody SystemStart
start EraHistory CardanoMode
hist BundledProtocolParameters BabbageEra
params Set PoolId
pools CSInputs
csi)

{-| Balance the transaction using the wallet's funds, then sign it.
-}
balanceForWallet :: (MonadBlockchain m, MonadFail m) => Wallet -> UtxoSet C.CtxUTxO a -> TxBodyContent BuildTx ERA -> m (C.Tx ERA, BalanceChanges)
balanceForWallet :: forall (m :: * -> *) a.
(MonadBlockchain m, MonadFail m) =>
Wallet
-> UtxoSet CtxUTxO a
-> TxBodyContent BuildTx BabbageEra
-> m (Tx BabbageEra, BalanceChanges)
balanceForWallet Wallet
wallet UtxoSet CtxUTxO a
walletUtxo TxBodyContent BuildTx BabbageEra
txb = do
  NetworkId
n <- forall (m :: * -> *). MonadBlockchain m => m NetworkId
networkId
  let walletAddress :: AddressInEra BabbageEra
walletAddress = forall era.
IsShelleyBasedEra era =>
NetworkId -> Wallet -> AddressInEra era
Wallet.addressInEra NetworkId
n Wallet
wallet
      txOut :: TxOut CtxTx BabbageEra
txOut = AddressInEra BabbageEra -> TxOut CtxTx BabbageEra
L.emptyTxOut AddressInEra BabbageEra
walletAddress
  forall (m :: * -> *) a.
(MonadBlockchain m, MonadFail m) =>
Wallet
-> UtxoSet CtxUTxO a
-> TxOut CtxTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> m (Tx BabbageEra, BalanceChanges)
balanceForWalletReturn Wallet
wallet UtxoSet CtxUTxO a
walletUtxo TxOut CtxTx BabbageEra
txOut TxBodyContent BuildTx BabbageEra
txb

{-| Balance the transaction using the wallet's funds and the provided return output, then sign it.
-}
balanceForWalletReturn :: (MonadBlockchain m, MonadFail m) => Wallet -> UtxoSet C.CtxUTxO a -> C.TxOut C.CtxTx C.BabbageEra -> TxBodyContent BuildTx ERA -> m (C.Tx ERA, BalanceChanges)
balanceForWalletReturn :: forall (m :: * -> *) a.
(MonadBlockchain m, MonadFail m) =>
Wallet
-> UtxoSet CtxUTxO a
-> TxOut CtxTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> m (Tx BabbageEra, BalanceChanges)
balanceForWalletReturn Wallet
wallet UtxoSet CtxUTxO a
walletUtxo TxOut CtxTx BabbageEra
returnOutput TxBodyContent BuildTx BabbageEra
txb = do
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Wallet -> BalancedTxBody BabbageEra -> Tx BabbageEra
signForWallet Wallet
wallet) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadBlockchain m, MonadFail m) =>
TxOut CtxTx BabbageEra
-> UtxoSet CtxUTxO a
-> TxBodyContent BuildTx BabbageEra
-> m (BalancedTxBody BabbageEra, BalanceChanges)
balanceTx TxOut CtxTx BabbageEra
returnOutput UtxoSet CtxUTxO a
walletUtxo TxBodyContent BuildTx BabbageEra
txb

{-| Sign a transaction with the wallet's key
-}
signForWallet :: Wallet -> C.BalancedTxBody ERA -> C.Tx ERA
signForWallet :: Wallet -> BalancedTxBody BabbageEra -> Tx BabbageEra
signForWallet Wallet
wallet (C.BalancedTxBody TxBodyContent BuildTx BabbageEra
_ TxBody BabbageEra
txbody TxOut CtxTx BabbageEra
_changeOutput Lovelace
_fee) =
  let wit :: [KeyWitness BabbageEra]
wit = [forall era.
IsShelleyBasedEra era =>
TxBody era -> ShelleyWitnessSigningKey -> KeyWitness era
C.makeShelleyKeyWitness TxBody BabbageEra
txbody forall a b. (a -> b) -> a -> b
$ SigningKey PaymentKey -> ShelleyWitnessSigningKey
C.WitnessPaymentKey  (Wallet -> SigningKey PaymentKey
Wallet.getWallet Wallet
wallet)]
  in forall era. [KeyWitness era] -> TxBody era -> Tx era
C.makeSignedTransaction [KeyWitness BabbageEra]
wit TxBody BabbageEra
txbody

addOwnInput :: TxBodyContent BuildTx ERA -> UtxoSet ctx a -> TxBodyContent BuildTx ERA
addOwnInput :: forall ctx a.
TxBodyContent BuildTx BabbageEra
-> UtxoSet ctx a -> TxBodyContent BuildTx BabbageEra
addOwnInput TxBodyContent BuildTx BabbageEra
body (forall ctx a. UtxoSet ctx a -> UtxoSet ctx a
Utxos.onlyAda forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ctx a. Set TxIn -> UtxoSet ctx a -> UtxoSet ctx a
Utxos.removeUtxos (forall v. TxBodyContent v BabbageEra -> Set TxIn
spentTxIns TxBodyContent BuildTx BabbageEra
body) -> UtxoSet{Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: Map TxIn (TxOut ctx BabbageEra, a)
_utxos})
  | forall k a. Map k a -> Bool
Map.null Map TxIn (TxOut ctx BabbageEra, a)
_utxos = TxBodyContent BuildTx BabbageEra
body
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
List.null forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns TxBodyContent BuildTx BabbageEra
body) = TxBodyContent BuildTx BabbageEra
body
  | Bool
otherwise = forall a.
BuildTxT Identity a
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
execBuildTx (forall (m :: * -> *). MonadBuildTx m => TxIn -> m ()
spendPublicKeyOutput (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut ctx BabbageEra, a)
_utxos)) TxBodyContent BuildTx BabbageEra
body

setCollateral :: TxBodyContent BuildTx ERA -> UtxoSet ctx a -> TxBodyContent BuildTx ERA
setCollateral :: forall ctx a.
TxBodyContent BuildTx BabbageEra
-> UtxoSet ctx a -> TxBodyContent BuildTx BabbageEra
setCollateral TxBodyContent BuildTx BabbageEra
body (forall ctx a. UtxoSet ctx a -> UtxoSet ctx a
Utxos.onlyAda -> UtxoSet{Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: Map TxIn (TxOut ctx BabbageEra, a)
_utxos :: forall ctx a. UtxoSet ctx a -> Map TxIn (TxOut ctx BabbageEra, a)
_utxos}) =
  if Bool -> Bool
not (TxBodyContent BuildTx BabbageEra -> Bool
runsScripts TxBodyContent BuildTx BabbageEra
body)
    then TxBodyContent BuildTx BabbageEra
body -- no script witnesses in inputs.
    else
      -- select the output with the largest amount of Ada
      case forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Lovelace
C.selectLovelace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut ctx BabbageEra, a)
_utxos of
        Maybe (TxIn, (TxOut ctx BabbageEra, a))
Nothing     -> TxBodyContent BuildTx BabbageEra
body -- TODO: Throw error
        Just (TxIn
k, (TxOut ctx BabbageEra, a)
_) -> forall a.
BuildTxT Identity a
-> TxBodyContent BuildTx BabbageEra
-> TxBodyContent BuildTx BabbageEra
execBuildTx (forall (m :: * -> *). MonadBuildTx m => TxIn -> m ()
addCollateral TxIn
k) TxBodyContent BuildTx BabbageEra
body

{-| Whether the transaction runs any plutus scripts
-}
runsScripts :: TxBodyContent BuildTx ERA -> Bool
runsScripts :: TxBodyContent BuildTx BabbageEra -> Bool
runsScripts TxBodyContent BuildTx BabbageEra
body =
  let scriptIns :: [(ScriptWitnessInCtx WitCtxTxIn,
  ScriptWitness WitCtxTxIn BabbageEra)]
scriptIns = TxBodyContent BuildTx BabbageEra
body forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Iso' (BuildTxWith BuildTx a) a
L._BuildTxWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall witctx era.
Prism'
  (Witness witctx era)
  (ScriptWitnessInCtx witctx, ScriptWitness witctx era)
L._ScriptWitness)
      minting :: Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
minting   = TxBodyContent BuildTx BabbageEra
body forall s a. s -> Getting a s a -> a
^. (forall v.
Lens' (TxBodyContent v BabbageEra) (TxMintValue v BabbageEra)
L.txMintValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso'
  (TxMintValue BuildTx BabbageEra)
  (Value, Map PolicyId (ScriptWitness WitCtxMint BabbageEra))
L._TxMintValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2)
  in Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ScriptWitnessInCtx WitCtxTxIn,
  ScriptWitness WitCtxTxIn BabbageEra)]
scriptIns Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map PolicyId (ScriptWitness WitCtxMint BabbageEra)
minting)

{-| Add inputs to ensure that the balance is strictly positive
-}
addMissingInputs :: Set PoolId -> C.BundledProtocolParameters BabbageEra -> C.UTxO ERA -> C.TxOut C.CtxTx C.BabbageEra -> UtxoSet ctx a -> TxBodyContent BuildTx ERA -> Either CoinSelectionError (TxBodyContent BuildTx ERA, C.TxOut C.CtxTx C.BabbageEra)
addMissingInputs :: forall ctx a.
Set PoolId
-> BundledProtocolParameters BabbageEra
-> UTxO BabbageEra
-> TxOut CtxTx BabbageEra
-> UtxoSet ctx a
-> TxBodyContent BuildTx BabbageEra
-> Either
     CoinSelectionError
     (TxBodyContent BuildTx BabbageEra, TxOut CtxTx BabbageEra)
addMissingInputs Set PoolId
poolIds BundledProtocolParameters BabbageEra
ledgerPPs UTxO BabbageEra
utxo_ TxOut CtxTx BabbageEra
returnUTxO0 UtxoSet ctx a
walletUtxo TxBodyContent BuildTx BabbageEra
txBodyContent0 = do
  TxBody BabbageEra
txb <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TxBodyError -> CoinSelectionError
bodyError (forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
C.createAndValidateTransactionBody TxBodyContent BuildTx BabbageEra
txBodyContent0)
  let bal :: Value
bal = forall era.
IsShelleyBasedEra era =>
BundledProtocolParameters era
-> Set PoolId
-> Map StakeCredential Lovelace
-> UTxO era
-> TxBody era
-> TxOutValue era
C.evaluateTransactionBalance BundledProtocolParameters BabbageEra
ledgerPPs Set PoolId
poolIds forall a. Monoid a => a
mempty UTxO BabbageEra
utxo_ TxBody BabbageEra
txb forall a b. a -> (a -> b) -> b
& forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Iso' (TxOutValue BabbageEra) Value
L._TxOutValue
      available :: UtxoSet ctx a
available = forall ctx a. Set TxIn -> UtxoSet ctx a -> UtxoSet ctx a
Utxos.removeUtxos (forall v. TxBodyContent v BabbageEra -> Set TxIn
spentTxIns TxBodyContent BuildTx BabbageEra
txBodyContent0) UtxoSet ctx a
walletUtxo

  (TxBodyContent BuildTx BabbageEra
txBodyContent1, Value
additionalBalance) <- forall ctx a.
Value
-> UtxoSet ctx a
-> TxBodyContent BuildTx BabbageEra
-> Either
     CoinSelectionError (TxBodyContent BuildTx BabbageEra, Value)
addInputsForNonAdaAssets Value
bal UtxoSet ctx a
walletUtxo TxBodyContent BuildTx BabbageEra
txBodyContent0

  let bal0 :: Value
bal0 = Value
bal forall a. Semigroup a => a -> a -> a
<> Value
additionalBalance
  let (TxOut CtxTx BabbageEra
returnUTxO1, C.Lovelace Integer
deposit) = BundledProtocolParameters BabbageEra
-> TxOut CtxTx BabbageEra
-> Value
-> (TxOut CtxTx BabbageEra, Lovelace)
addOutputForNonAdaAssets BundledProtocolParameters BabbageEra
ledgerPPs TxOut CtxTx BabbageEra
returnUTxO0 Value
bal0

      -- minimum positive balance (in lovelace) that must be available to cover
      -- * minimum deposit on the ada-only change output, if required, and
      -- * transaction fee, incl. script fee if required
      -- we set it to rather large value to ensure that we can build a valid transaction.
  let threshold :: Integer
threshold =
        if TxBodyContent BuildTx BabbageEra -> Bool
runsScripts TxBodyContent BuildTx BabbageEra
txBodyContent1
          then Integer
8_000_000
          else Integer
2_500_000
      C.Lovelace Integer
l = Value -> Lovelace
C.selectLovelace Value
bal0
      missingLovelace :: Lovelace
missingLovelace = Integer -> Lovelace
C.Lovelace (Integer
deposit forall a. Num a => a -> a -> a
+ Integer
threshold forall a. Num a => a -> a -> a
- Integer
l)

  (,TxOut CtxTx BabbageEra
returnUTxO1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ctx a.
Lovelace
-> UtxoSet ctx a
-> TxBodyContent BuildTx BabbageEra
-> Either CoinSelectionError (TxBodyContent BuildTx BabbageEra)
addAdaOnlyInputsFor Lovelace
missingLovelace UtxoSet ctx a
available TxBodyContent BuildTx BabbageEra
txBodyContent1

{-| Select inputs from the wallet's UTXO set to cover the given amount of lovelace.
Will only consider inputs that have no other assets besides Ada.
-}
addAdaOnlyInputsFor :: C.Lovelace -> UtxoSet ctx a -> TxBodyContent BuildTx ERA -> Either CoinSelectionError (TxBodyContent BuildTx ERA)
addAdaOnlyInputsFor :: forall ctx a.
Lovelace
-> UtxoSet ctx a
-> TxBodyContent BuildTx BabbageEra
-> Either CoinSelectionError (TxBodyContent BuildTx BabbageEra)
addAdaOnlyInputsFor Lovelace
l UtxoSet ctx a
availableUtxo TxBodyContent BuildTx BabbageEra
txBodyContent =
  case forall ctx a. UtxoSet ctx a -> Lovelace -> Maybe (Lovelace, [TxIn])
Wallet.selectAdaInputsCovering UtxoSet ctx a
availableUtxo Lovelace
l of
    Maybe (Lovelace, [TxIn])
Nothing -> forall a b. a -> Either a b
Left (Lovelace -> CoinSelectionError
NotEnoughAdaOnlyOutputsFor Lovelace
l)
    Just (Lovelace
_, [TxIn]
ins) -> forall a b. b -> Either a b
Right (TxBodyContent BuildTx BabbageEra
txBodyContent forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns (forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxIn -> TxIn BuildTx
spendPubKeyTxIn [TxIn]
ins))

{-| Examine the negative part of the transaction balance and select inputs from
the wallet's UTXO set to cover the non-Ada assets required by it. If there are no
non-Ada asset then no inputs will be added.
-}
addInputsForNonAdaAssets ::
  C.Value ->
  UtxoSet ctx a ->
  TxBodyContent BuildTx ERA ->
  Either CoinSelectionError (TxBodyContent BuildTx ERA, C.Value)
addInputsForNonAdaAssets :: forall ctx a.
Value
-> UtxoSet ctx a
-> TxBodyContent BuildTx BabbageEra
-> Either
     CoinSelectionError (TxBodyContent BuildTx BabbageEra, Value)
addInputsForNonAdaAssets Value
txBal UtxoSet ctx a
availableUtxo TxBodyContent BuildTx BabbageEra
txBodyContent
  | forall a. Maybe a -> Bool
isNothing (Value -> Maybe Lovelace
C.valueToLovelace forall a b. (a -> b) -> a -> b
$ [(AssetId, Quantity)] -> Value
C.valueFromList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Value -> ([(AssetId, Quantity)], [(AssetId, Quantity)])
splitValue Value
txBal) = do
      let nativeAsset :: (AssetId, Quantity) -> Maybe (PolicyId, AssetName, Quantity)
nativeAsset (AssetId
C.AdaAssetId, Quantity
_) = forall a. Maybe a
Nothing
          nativeAsset (C.AssetId PolicyId
p AssetName
n, C.Quantity Integer
q) = forall a. a -> Maybe a
Just (PolicyId
p, AssetName
n, Integer -> Quantity
C.Quantity (forall a. Num a => a -> a
abs Integer
q))
          missingNativeAssets :: [(PolicyId, AssetName, Quantity)]
missingNativeAssets = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (AssetId, Quantity) -> Maybe (PolicyId, AssetName, Quantity)
nativeAsset (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Value -> ([(AssetId, Quantity)], [(AssetId, Quantity)])
splitValue Value
txBal)
      case forall ctx a.
UtxoSet ctx a
-> [(PolicyId, AssetName, Quantity)] -> Maybe (Value, [TxIn])
Wallet.selectMixedInputsCovering UtxoSet ctx a
availableUtxo [(PolicyId, AssetName, Quantity)]
missingNativeAssets of
        Maybe (Value, [TxIn])
Nothing -> forall a b. a -> Either a b
Left ([(PolicyId, AssetName, Quantity)]
-> Value -> Value -> CoinSelectionError
NotEnoughMixedOutputsFor [(PolicyId, AssetName, Quantity)]
missingNativeAssets (forall ctx a. UtxoSet ctx a -> Value
Utxos.totalBalance UtxoSet ctx a
availableUtxo) Value
txBal)
        Just (Value
total, [TxIn]
ins) -> forall a b. b -> Either a b
Right (TxBodyContent BuildTx BabbageEra
txBodyContent forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns (forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxIn -> TxIn BuildTx
spendPubKeyTxIn [TxIn]
ins), Value
total)
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (TxBodyContent BuildTx BabbageEra
txBodyContent, forall a. Monoid a => a
mempty)

{-| Examine the positive part of the transaction balance and add an output for
any non-Ada asset it contains. If the positive part only contains Ada then no
output is added.
-}
addOutputForNonAdaAssets ::
  C.BundledProtocolParameters BabbageEra -> -- ^ Protocol parameters (for computing the minimum lovelace amount in the output)
  C.TxOut C.CtxTx C.BabbageEra -> -- ^ Address of the newly created output
  C.Value -> -- ^ The balance of the transaction
  (C.TxOut C.CtxTx C.BabbageEra, C.Lovelace) -- ^ The modified transaction body and the lovelace portion of the change output's value. If no output was added then the amount will be 0.
addOutputForNonAdaAssets :: BundledProtocolParameters BabbageEra
-> TxOut CtxTx BabbageEra
-> Value
-> (TxOut CtxTx BabbageEra, Lovelace)
addOutputForNonAdaAssets BundledProtocolParameters BabbageEra
pparams TxOut CtxTx BabbageEra
returnUTxO ([(AssetId, Quantity)] -> Value
C.valueFromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ([(AssetId, Quantity)], [(AssetId, Quantity)])
splitValue -> Value
positives)
  | forall a. Maybe a -> Bool
isNothing (Value -> Maybe Lovelace
C.valueToLovelace Value
positives) =
      let vlWithoutAda :: Value
vlWithoutAda = Value
positives forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set (Iso' Value (Map AssetId Quantity)
L._Value forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at AssetId
C.AdaAssetId) forall a. Maybe a
Nothing
          output :: TxOut CtxTx BabbageEra
output =
            BundledProtocolParameters BabbageEra
-> TxOut CtxTx BabbageEra -> TxOut CtxTx BabbageEra
setMinAdaDeposit BundledProtocolParameters BabbageEra
pparams
            forall a b. (a -> b) -> a -> b
$ TxOut CtxTx BabbageEra
returnUTxO forall a b. a -> (a -> b) -> b
& forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ Value
vlWithoutAda
      in  (TxOut CtxTx BabbageEra
output, TxOut CtxTx BabbageEra
output forall s a. s -> Getting a s a -> a
^. forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxOutValue BabbageEra) Value
L._TxOutValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Value -> Lovelace
C.selectLovelace)
  | Bool
otherwise = (TxOut CtxTx BabbageEra
returnUTxO, Integer -> Lovelace
C.Lovelace Integer
0)

splitValue :: C.Value -> ([(C.AssetId, C.Quantity)], [(C.AssetId, C.Quantity)])
splitValue :: Value -> ([(AssetId, Quantity)], [(AssetId, Quantity)])
splitValue =
  let p :: (a, a) -> Bool
p (a
_, a
q) = a
q forall a. Ord a => a -> a -> Bool
< a
0
      f :: (a, a) -> Bool
f (a
_, a
q) = a
q forall a. Eq a => a -> a -> Bool
/= a
0
  in forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition forall {a} {a}. (Ord a, Num a) => (a, a) -> Bool
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
List.filter forall {a} {a}. (Eq a, Num a) => (a, a) -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [(AssetId, Quantity)]
C.valueToList

{-| Take the tx body and produce a 'CSInputs' value for coin selection,
using the @MonadBlockchain@ effect to query any missing UTxO information.
-}
prepCSInputs ::
 MonadBlockchain m
  => C.TxOut C.CtxTx C.BabbageEra -- ^ Change address
  -> C.UTxO ERA -- ^ UTxOs that may be used for balancing
  -> C.TxBodyContent C.BuildTx C.BabbageEra -- ^ Unbalanced transaction body
  -> m CSInputs -- ^ Inputs for coin balancing
prepCSInputs :: forall (m :: * -> *).
MonadBlockchain m =>
TxOut CtxTx BabbageEra
-> UTxO BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> m CSInputs
prepCSInputs TxOut CtxTx BabbageEra
csiChangeAddress UTxO BabbageEra
csiUtxo TxBodyContent BuildTx BabbageEra
csiTxBody =
  UTxO BabbageEra
-> TxBodyContent BuildTx BabbageEra
-> TxOut CtxTx BabbageEra
-> Word
-> CSInputs
CSInputs
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure UTxO BabbageEra
csiUtxo
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure TxBodyContent BuildTx BabbageEra
csiTxBody
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOut CtxTx BabbageEra
csiChangeAddress
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Enum a => a -> a
succ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
Set.size) (forall (m :: * -> *).
MonadBlockchain m =>
TxBodyContent BuildTx BabbageEra
-> m (Set (KeyHash 'Payment StandardCrypto))
keyWitnesses TxBodyContent BuildTx BabbageEra
csiTxBody)

spentTxIns :: C.TxBodyContent v C.BabbageEra -> Set C.TxIn
spentTxIns :: forall v. TxBodyContent v BabbageEra -> Set TxIn
spentTxIns (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns -> [TxIn v]
inputs) =
  -- TODO: Include collateral etc. fields
  forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn v]
inputs)

requiredTxIns :: C.TxBodyContent v C.BabbageEra -> Set C.TxIn
requiredTxIns :: forall v. TxBodyContent v BabbageEra -> Set TxIn
requiredTxIns TxBodyContent v BabbageEra
body =
  forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns TxBodyContent v BabbageEra
body)
  forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall v.
Lens' (TxBodyContent v BabbageEra) (TxInsReference v BabbageEra)
L.txInsReference forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall build. Iso' (TxInsReference build BabbageEra) [TxIn]
L._TxInsReference) TxBodyContent v BabbageEra
body)
  forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall v.
Lens' (TxBodyContent v BabbageEra) (TxInsCollateral BabbageEra)
L.txInsCollateral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' (TxInsCollateral BabbageEra) [TxIn]
L._TxInsCollateral) TxBodyContent v BabbageEra
body)

lookupTxIns :: MonadBlockchain m => Set C.TxIn -> m (C.UTxO ERA)
lookupTxIns :: forall (m :: * -> *).
MonadBlockchain m =>
Set TxIn -> m (UTxO BabbageEra)
lookupTxIns = forall (m :: * -> *).
MonadBlockchain m =>
Set TxIn -> m (UTxO BabbageEra)
utxoByTxIn

keyWitnesses :: MonadBlockchain m => C.TxBodyContent C.BuildTx C.BabbageEra -> m (Set (Keys.KeyHash 'Keys.Payment StandardCrypto))
keyWitnesses :: forall (m :: * -> *).
MonadBlockchain m =>
TxBodyContent BuildTx BabbageEra
-> m (Set (KeyHash 'Payment StandardCrypto))
keyWitnesses (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall v. Lens' (TxBodyContent v BabbageEra) [TxIn v]
L.txIns -> [TxIn BuildTx]
inputs) = do
  C.UTxO Map TxIn (TxOut CtxUTxO BabbageEra)
utxos <- forall (m :: * -> *).
MonadBlockchain m =>
Set TxIn -> m (UTxO BabbageEra)
utxoByTxIn (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxIn BuildTx]
inputs)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TxOut CtxUTxO BabbageEra -> Maybe (KeyHash 'Payment StandardCrypto)
publicKeyCredential forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO BabbageEra)
utxos

publicKeyCredential :: C.TxOut C.CtxUTxO C.BabbageEra -> Maybe (Keys.KeyHash 'Keys.Payment StandardCrypto)
publicKeyCredential :: TxOut CtxUTxO BabbageEra -> Maybe (KeyHash 'Payment StandardCrypto)
publicKeyCredential = forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism'
  (AddressInEra BabbageEra)
  (Network, PaymentCredential StandardCrypto,
   StakeReference StandardCrypto)
L._ShelleyAddressInBabbageEra forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism'
  (PaymentCredential StandardCrypto)
  (KeyHash 'Payment StandardCrypto)
L._ShelleyPaymentCredentialByKey)

spendPubKeyTxIn :: C.TxIn -> (C.TxIn, C.BuildTxWith C.BuildTx (C.Witness C.WitCtxTxIn C.BabbageEra))
-- TODO: consolidate with Convex.BuildTx.spendPublicKeyOutput
spendPubKeyTxIn :: TxIn -> TxIn BuildTx
spendPubKeyTxIn TxIn
txIn = (TxIn
txIn, forall a. a -> BuildTxWith BuildTx a
C.BuildTxWith (forall witctx era. KeyWitnessInCtx witctx -> Witness witctx era
C.KeyWitness KeyWitnessInCtx WitCtxTxIn
C.KeyWitnessForSpending))