{-# LANGUAGE DuplicateRecordFields #-}

-- | Companion tiny-wallet for the direct chain component. This module provide
-- some useful utilities to tracking the wallet's UTXO, and accessing it
module Hydra.Chain.Direct.Wallet where

import Hydra.Prelude

import Cardano.Api.UTxO (UTxO)
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Crypto.Hash.Class
import Cardano.Ledger.Address qualified as Ledger
import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
import Cardano.Ledger.Alonzo.Scripts (
  AlonzoEraScript (..),
  AlonzoPlutusPurpose (AlonzoSpending),
  AsIndex (..),
  ExUnits (ExUnits),
  plutusScriptLanguage,
  unAsIndex,
 )
import Cardano.Ledger.Alonzo.TxWits (
  AlonzoTxWits (..),
  Redeemers (..),
  txdats,
  txscripts,
 )
import Cardano.Ledger.Api (
  TransactionScriptFailure,
  bodyTxL,
  collateralInputsTxBodyL,
  ensureMinCoinTxOut,
  estimateMinFeeTx,
  evalTxExUnits,
  feeTxBodyL,
  inputsTxBodyL,
  outputsTxBodyL,
  ppMaxTxExUnitsL,
  rdmrsTxWitsL,
  referenceInputsTxBodyL,
  scriptIntegrityHashTxBodyL,
  witsTxL,
 )
import Cardano.Ledger.Babbage.Tx (body, getLanguageView, hashScriptIntegrity, wits)
import Cardano.Ledger.Babbage.Tx qualified as Babbage
import Cardano.Ledger.Babbage.TxBody qualified as Babbage
import Cardano.Ledger.Babbage.UTxO (getReferenceScripts)
import Cardano.Ledger.BaseTypes qualified as Ledger
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core (isNativeScript)
import Cardano.Ledger.Core qualified as Core
import Cardano.Ledger.Core qualified as Ledger
import Cardano.Ledger.Crypto (HASH, StandardCrypto)
import Cardano.Ledger.Hashes (EraIndependentTxBody)
import Cardano.Ledger.SafeHash qualified as SafeHash
import Cardano.Ledger.Shelley.API (unUTxO)
import Cardano.Ledger.Shelley.API qualified as Ledger
import Cardano.Ledger.Val (Val (..), invert)
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart (..))
import Control.Arrow (left)
import Control.Concurrent.Class.MonadSTM (check, newTVarIO, readTVarIO, writeTVar)
import Control.Lens (view, (%~), (.~), (^.))
import Data.List qualified as List
import Data.Map.Strict ((!))
import Data.Map.Strict qualified as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Ratio ((%))
import Data.Sequence.Strict ((|>))
import Data.Set qualified as Set
import Hydra.Cardano.Api (
  BlockHeader,
  ChainPoint,
  LedgerEra,
  NetworkId,
  PaymentCredential (PaymentCredentialByKey),
  PaymentKey,
  ShelleyAddr,
  SigningKey,
  StakeAddressReference (NoStakeAddress),
  VerificationKey,
  fromLedgerTx,
  fromLedgerTxIn,
  fromLedgerTxOut,
  fromLedgerUTxO,
  getChainPoint,
  makeShelleyAddress,
  selectLovelace,
  shelleyAddressInEra,
  toLedgerAddr,
  toLedgerTx,
  toLedgerTxIn,
  toLedgerTxOut,
  toLedgerUTxO,
  verificationKeyHash,
 )
import Hydra.Cardano.Api qualified as Api
import Hydra.Chain.CardanoClient (QueryPoint (..))
import Hydra.Ledger.Cardano ()
import Hydra.Logging (Tracer, traceWith)

type Address = Ledger.Addr StandardCrypto
type TxIn = Ledger.TxIn StandardCrypto
type TxOut = Ledger.TxOut LedgerEra

-- | A 'TinyWallet' is a small abstraction of a wallet with basic UTXO
-- management. The wallet is assumed to have only one address, and only one UTXO
-- at that address. It can sign transactions and keeps track of its UTXO behind
-- the scene.
--
-- The wallet is connecting to the node initially and when asked to 'reset'.
-- Otherwise it can be fed blocks via 'update' as the chain rolls forward.
data TinyWallet m = TinyWallet
  { forall (m :: * -> *). TinyWallet m -> STM m (Map TxIn TxOut)
getUTxO :: STM m (Map TxIn TxOut)
  -- ^ Return all known UTxO addressed to this wallet.
  , forall (m :: * -> *). TinyWallet m -> STM m (Maybe TxIn)
getSeedInput :: STM m (Maybe Api.TxIn)
  -- ^ Returns the /seed input/
  -- This is the special input needed by `Direct` chain component to initialise
  -- a head
  , forall (m :: * -> *). TinyWallet m -> Tx -> Tx
sign :: Api.Tx -> Api.Tx
  , forall (m :: * -> *).
TinyWallet m -> UTxO -> Tx -> m (Either ErrCoverFee Tx)
coverFee ::
      UTxO ->
      Api.Tx ->
      m (Either ErrCoverFee Api.Tx)
  , forall (m :: * -> *). TinyWallet m -> m ()
reset :: m ()
  -- ^ Re-initializ wallet against the latest tip of the node and start to
  -- ignore 'update' calls until reaching that tip.
  , forall (m :: * -> *). TinyWallet m -> BlockHeader -> [Tx] -> m ()
update :: BlockHeader -> [Api.Tx] -> m ()
  -- ^ Update the wallet state given a block and list of txs. May be ignored if
  -- wallet is still initializing.
  }

data WalletInfoOnChain = WalletInfoOnChain
  { WalletInfoOnChain -> Map TxIn TxOut
walletUTxO :: Map TxIn TxOut
  , WalletInfoOnChain -> PParams LedgerEra
pparams :: Core.PParams LedgerEra
  , WalletInfoOnChain -> SystemStart
systemStart :: SystemStart
  , WalletInfoOnChain -> EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
  , WalletInfoOnChain -> ChainPoint
tip :: ChainPoint
  -- ^ Latest point on chain the wallet knows of.
  }

type ChainQuery m = QueryPoint -> Api.Address ShelleyAddr -> m WalletInfoOnChain

watchUTxOUntil :: (Map TxIn TxOut -> Bool) -> TinyWallet IO -> IO (Map TxIn TxOut)
watchUTxOUntil :: (Map TxIn TxOut -> Bool) -> TinyWallet IO -> IO (Map TxIn TxOut)
watchUTxOUntil Map TxIn TxOut -> Bool
predicate TinyWallet{STM IO (Map TxIn TxOut)
$sel:getUTxO:TinyWallet :: forall (m :: * -> *). TinyWallet m -> STM m (Map TxIn TxOut)
getUTxO :: STM IO (Map TxIn TxOut)
getUTxO} = STM IO (Map TxIn TxOut) -> IO (Map TxIn TxOut)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Map TxIn TxOut) -> IO (Map TxIn TxOut))
-> STM IO (Map TxIn TxOut) -> IO (Map TxIn TxOut)
forall a b. (a -> b) -> a -> b
$ do
  Map TxIn (BabbageTxOut StandardBabbage)
u <- STM (Map TxIn (BabbageTxOut StandardBabbage))
STM IO (Map TxIn TxOut)
getUTxO
  Map TxIn (BabbageTxOut StandardBabbage)
u Map TxIn (BabbageTxOut StandardBabbage)
-> STM () -> STM (Map TxIn (BabbageTxOut StandardBabbage))
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> STM IO ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Map TxIn TxOut -> Bool
predicate Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
u)

-- | Create a new tiny wallet handle.
newTinyWallet ::
  -- | A tracer for logging
  Tracer IO TinyWalletLog ->
  -- | Network identifier to generate our address.
  NetworkId ->
  -- | Credentials of the wallet.
  (VerificationKey PaymentKey, SigningKey PaymentKey) ->
  -- | A function to query UTxO, pparams, system start and epoch info from the
  -- node. Initially and on demand later.
  ChainQuery IO ->
  IO (EpochInfo (Either Text)) ->
  IO (TinyWallet IO)
newTinyWallet :: Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (TinyWallet IO)
newTinyWallet Tracer IO TinyWalletLog
tracer NetworkId
networkId (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) ChainQuery IO
queryWalletInfo IO (EpochInfo (Either Text))
queryEpochInfo = do
  TVar WalletInfoOnChain
walletInfoVar <- WalletInfoOnChain -> IO (TVar WalletInfoOnChain)
WalletInfoOnChain -> IO (TVar IO WalletInfoOnChain)
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (WalletInfoOnChain -> IO (TVar WalletInfoOnChain))
-> IO WalletInfoOnChain -> IO (TVar WalletInfoOnChain)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO WalletInfoOnChain
initialize
  let getUTxO :: STM IO (Map TxIn (BabbageTxOut StandardBabbage))
getUTxO = TVar IO WalletInfoOnChain -> STM IO WalletInfoOnChain
forall a. TVar IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar WalletInfoOnChain
TVar IO WalletInfoOnChain
walletInfoVar STM IO WalletInfoOnChain
-> (WalletInfoOnChain -> Map TxIn (BabbageTxOut StandardBabbage))
-> STM IO (Map TxIn (BabbageTxOut StandardBabbage))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> WalletInfoOnChain -> Map TxIn TxOut
WalletInfoOnChain -> Map TxIn (BabbageTxOut StandardBabbage)
walletUTxO
  TinyWallet IO -> IO (TinyWallet IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TinyWallet
      { STM IO (Map TxIn TxOut)
STM IO (Map TxIn (BabbageTxOut StandardBabbage))
$sel:getUTxO:TinyWallet :: STM IO (Map TxIn TxOut)
getUTxO :: STM IO (Map TxIn (BabbageTxOut StandardBabbage))
getUTxO
      , $sel:getSeedInput:TinyWallet :: STM IO (Maybe TxIn)
getSeedInput = ((TxIn, BabbageTxOut StandardBabbage) -> TxIn)
-> Maybe (TxIn, BabbageTxOut StandardBabbage) -> Maybe TxIn
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TxIn -> TxIn
fromLedgerTxIn (TxIn -> TxIn)
-> ((TxIn, BabbageTxOut StandardBabbage) -> TxIn)
-> (TxIn, BabbageTxOut StandardBabbage)
-> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BabbageTxOut StandardBabbage) -> TxIn
forall a b. (a, b) -> a
fst) (Maybe (TxIn, BabbageTxOut StandardBabbage) -> Maybe TxIn)
-> (Map TxIn (BabbageTxOut StandardBabbage)
    -> Maybe (TxIn, BabbageTxOut StandardBabbage))
-> Map TxIn (BabbageTxOut StandardBabbage)
-> Maybe TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn TxOut -> Maybe (TxIn, TxOut)
Map TxIn (BabbageTxOut StandardBabbage)
-> Maybe (TxIn, BabbageTxOut StandardBabbage)
findLargestUTxO (Map TxIn (BabbageTxOut StandardBabbage) -> Maybe TxIn)
-> STM IO (Map TxIn (BabbageTxOut StandardBabbage))
-> STM IO (Maybe TxIn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM IO (Map TxIn (BabbageTxOut StandardBabbage))
getUTxO
      , $sel:sign:TinyWallet :: Tx -> Tx
sign = SigningKey PaymentKey -> Tx -> Tx
forall era.
IsShelleyBasedEra era =>
SigningKey PaymentKey -> Tx era -> Tx era
Api.signTx SigningKey PaymentKey
sk
      , $sel:coverFee:TinyWallet :: UTxO -> Tx -> IO (Either ErrCoverFee Tx)
coverFee = \UTxO
lookupUTxO Tx
partialTx -> do
          -- XXX: We should query pparams here. If not, we likely will have
          -- wrong fee estimation should they change in between.
          EpochInfo (Either Text)
epochInfo <- IO (EpochInfo (Either Text))
queryEpochInfo
          WalletInfoOnChain{Map TxIn TxOut
$sel:walletUTxO:WalletInfoOnChain :: WalletInfoOnChain -> Map TxIn TxOut
walletUTxO :: Map TxIn TxOut
walletUTxO, PParams LedgerEra
$sel:pparams:WalletInfoOnChain :: WalletInfoOnChain -> PParams LedgerEra
pparams :: PParams LedgerEra
pparams, SystemStart
$sel:systemStart:WalletInfoOnChain :: WalletInfoOnChain -> SystemStart
systemStart :: SystemStart
systemStart} <- TVar IO WalletInfoOnChain -> IO WalletInfoOnChain
forall a. TVar IO a -> IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar WalletInfoOnChain
TVar IO WalletInfoOnChain
walletInfoVar
          Either ErrCoverFee Tx -> IO (Either ErrCoverFee Tx)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrCoverFee Tx -> IO (Either ErrCoverFee Tx))
-> Either ErrCoverFee Tx -> IO (Either ErrCoverFee Tx)
forall a b. (a -> b) -> a -> b
$
            Tx LedgerEra -> Tx
AlonzoTx StandardBabbage -> Tx
fromLedgerTx
              (AlonzoTx StandardBabbage -> Tx)
-> Either ErrCoverFee (AlonzoTx StandardBabbage)
-> Either ErrCoverFee Tx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PParams LedgerEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn TxOut
-> Map TxIn TxOut
-> AlonzoTx LedgerEra
-> Either ErrCoverFee (AlonzoTx LedgerEra)
coverFee_ PParams LedgerEra
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo (UTxO LedgerEra -> Map (TxIn (EraCrypto LedgerEra)) TxOut
forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO (UTxO LedgerEra -> Map (TxIn (EraCrypto LedgerEra)) TxOut)
-> UTxO LedgerEra -> Map (TxIn (EraCrypto LedgerEra)) TxOut
forall a b. (a -> b) -> a -> b
$ UTxO -> UTxO LedgerEra
toLedgerUTxO UTxO
lookupUTxO) Map TxIn TxOut
walletUTxO (Tx -> Tx LedgerEra
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
 AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
partialTx)
      , reset :: IO ()
reset = IO WalletInfoOnChain
initialize IO WalletInfoOnChain -> (WalletInfoOnChain -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STM () -> IO ()
STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM () -> IO ())
-> (WalletInfoOnChain -> STM ()) -> WalletInfoOnChain -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar IO WalletInfoOnChain -> WalletInfoOnChain -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar WalletInfoOnChain
TVar IO WalletInfoOnChain
walletInfoVar
      , update :: BlockHeader -> [Tx] -> IO ()
update = \BlockHeader
header [Tx]
txs -> do
          let point :: ChainPoint
point = BlockHeader -> ChainPoint
getChainPoint BlockHeader
header
          ChainPoint
walletTip <- STM IO ChainPoint -> IO ChainPoint
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO ChainPoint -> IO ChainPoint)
-> STM IO ChainPoint -> IO ChainPoint
forall a b. (a -> b) -> a -> b
$ TVar IO WalletInfoOnChain -> STM IO WalletInfoOnChain
forall a. TVar IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar WalletInfoOnChain
TVar IO WalletInfoOnChain
walletInfoVar STM WalletInfoOnChain
-> (WalletInfoOnChain -> ChainPoint) -> STM ChainPoint
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \WalletInfoOnChain{ChainPoint
$sel:tip:WalletInfoOnChain :: WalletInfoOnChain -> ChainPoint
tip :: ChainPoint
tip} -> ChainPoint
tip
          if ChainPoint
point ChainPoint -> ChainPoint -> Bool
forall a. Ord a => a -> a -> Bool
< ChainPoint
walletTip
            then Tracer IO TinyWalletLog -> TinyWalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TinyWalletLog
tracer (TinyWalletLog -> IO ()) -> TinyWalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ SkipUpdate{ChainPoint
point :: ChainPoint
$sel:point:BeginInitialize :: ChainPoint
point}
            else do
              Tracer IO TinyWalletLog -> TinyWalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TinyWalletLog
tracer (TinyWalletLog -> IO ()) -> TinyWalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ BeginUpdate{ChainPoint
point :: ChainPoint
$sel:point:BeginInitialize :: ChainPoint
point}
              Map TxIn (BabbageTxOut StandardBabbage)
utxo' <- STM IO (Map TxIn (BabbageTxOut StandardBabbage))
-> IO (Map TxIn (BabbageTxOut StandardBabbage))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Map TxIn (BabbageTxOut StandardBabbage))
 -> IO (Map TxIn (BabbageTxOut StandardBabbage)))
-> STM IO (Map TxIn (BabbageTxOut StandardBabbage))
-> IO (Map TxIn (BabbageTxOut StandardBabbage))
forall a b. (a -> b) -> a -> b
$ do
                walletInfo :: WalletInfoOnChain
walletInfo@WalletInfoOnChain{Map TxIn TxOut
$sel:walletUTxO:WalletInfoOnChain :: WalletInfoOnChain -> Map TxIn TxOut
walletUTxO :: Map TxIn TxOut
walletUTxO} <- TVar IO WalletInfoOnChain -> STM IO WalletInfoOnChain
forall a. TVar IO a -> STM IO a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar WalletInfoOnChain
TVar IO WalletInfoOnChain
walletInfoVar
                let utxo' :: Map TxIn TxOut
utxo' = [Tx]
-> (Addr StandardCrypto -> Bool)
-> Map TxIn TxOut
-> Map TxIn TxOut
applyTxs [Tx]
txs (Addr StandardCrypto -> Addr StandardCrypto -> Bool
forall a. Eq a => a -> a -> Bool
== Addr StandardCrypto
ledgerAddress) Map TxIn TxOut
walletUTxO
                TVar IO WalletInfoOnChain -> WalletInfoOnChain -> STM IO ()
forall a. TVar IO a -> a -> STM IO ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar WalletInfoOnChain
TVar IO WalletInfoOnChain
walletInfoVar (WalletInfoOnChain -> STM IO ()) -> WalletInfoOnChain -> STM IO ()
forall a b. (a -> b) -> a -> b
$ WalletInfoOnChain
walletInfo{walletUTxO = utxo', tip = point}
                Map TxIn (BabbageTxOut StandardBabbage)
-> STM (Map TxIn (BabbageTxOut StandardBabbage))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
utxo'
              Tracer IO TinyWalletLog -> TinyWalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TinyWalletLog
tracer (TinyWalletLog -> IO ()) -> TinyWalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ UTxO -> TinyWalletLog
EndUpdate (UTxO LedgerEra -> UTxO
fromLedgerUTxO (Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
-> UTxO StandardBabbage
forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn (BabbageTxOut StandardBabbage)
Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
utxo'))
      }
 where
  initialize :: IO WalletInfoOnChain
initialize = do
    Tracer IO TinyWalletLog -> TinyWalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TinyWalletLog
tracer TinyWalletLog
BeginInitialize
    walletInfo :: WalletInfoOnChain
walletInfo@WalletInfoOnChain{Map TxIn TxOut
$sel:walletUTxO:WalletInfoOnChain :: WalletInfoOnChain -> Map TxIn TxOut
walletUTxO :: Map TxIn TxOut
walletUTxO, ChainPoint
$sel:tip:WalletInfoOnChain :: WalletInfoOnChain -> ChainPoint
tip :: ChainPoint
tip} <- ChainQuery IO
queryWalletInfo QueryPoint
QueryTip Address ShelleyAddr
address
    Tracer IO TinyWalletLog -> TinyWalletLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO TinyWalletLog
tracer (TinyWalletLog -> IO ()) -> TinyWalletLog -> IO ()
forall a b. (a -> b) -> a -> b
$ EndInitialize{$sel:initialUTxO:BeginInitialize :: UTxO
initialUTxO = UTxO LedgerEra -> UTxO
fromLedgerUTxO (Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
-> UTxO StandardBabbage
forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn TxOut
Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
walletUTxO), ChainPoint
tip :: ChainPoint
$sel:tip:BeginInitialize :: ChainPoint
tip}
    WalletInfoOnChain -> IO WalletInfoOnChain
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WalletInfoOnChain
walletInfo

  address :: Address ShelleyAddr
address =
    NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
makeShelleyAddress NetworkId
networkId (Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey (Hash PaymentKey -> PaymentCredential)
-> Hash PaymentKey -> PaymentCredential
forall a b. (a -> b) -> a -> b
$ VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk) StakeAddressReference
NoStakeAddress

  ledgerAddress :: Addr StandardCrypto
ledgerAddress = AddressInEra Era -> Addr StandardCrypto
forall era. AddressInEra era -> Addr StandardCrypto
toLedgerAddr (AddressInEra Era -> Addr StandardCrypto)
-> AddressInEra Era -> Addr StandardCrypto
forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyBasedEra era -> Address ShelleyAddr -> AddressInEra era
shelleyAddressInEra @Api.Era ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
Api.shelleyBasedEra Address ShelleyAddr
address

-- | Apply a block to our wallet. Does nothing if the transaction does not
-- modify the UTXO set, or else, remove consumed utxos and add produced ones.
--
-- To determine whether a produced output is ours, we apply the given function
-- checking the output's address.
applyTxs :: [Api.Tx] -> (Address -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs :: [Tx]
-> (Addr StandardCrypto -> Bool)
-> Map TxIn TxOut
-> Map TxIn TxOut
applyTxs [Tx]
txs Addr StandardCrypto -> Bool
isOurs Map TxIn TxOut
utxo =
  (State (Map TxIn (BabbageTxOut StandardBabbage)) ()
 -> Map TxIn (BabbageTxOut StandardBabbage) -> Map TxIn TxOut)
-> Map TxIn (BabbageTxOut StandardBabbage)
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
-> Map TxIn TxOut
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map TxIn (BabbageTxOut StandardBabbage)) ()
-> Map TxIn (BabbageTxOut StandardBabbage) -> Map TxIn TxOut
State (Map TxIn (BabbageTxOut StandardBabbage)) ()
-> Map TxIn (BabbageTxOut StandardBabbage)
-> Map TxIn (BabbageTxOut StandardBabbage)
forall s a. State s a -> s -> s
execState Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
utxo (State (Map TxIn (BabbageTxOut StandardBabbage)) ()
 -> Map TxIn TxOut)
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
-> Map TxIn TxOut
forall a b. (a -> b) -> a -> b
$ do
    [Tx]
-> (Tx -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Tx]
txs ((Tx -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
 -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
-> (Tx -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall a b. (a -> b) -> a -> b
$ \Tx
apiTx -> do
      -- XXX: Use cardano-api types instead here
      let tx :: Tx LedgerEra
tx = Tx -> Tx LedgerEra
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
 AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
apiTx
      let txId :: TxId StandardCrypto
txId = AlonzoTx StandardBabbage -> TxId StandardCrypto
forall crypto (era :: * -> *).
(HashAlgorithm (HASH crypto),
 HashAnnotated (TxBody (era crypto)) EraIndependentTxBody crypto) =>
AlonzoTx (era crypto) -> TxId crypto
getTxId Tx LedgerEra
AlonzoTx StandardBabbage
tx
      (Map
   (TxIn (EraCrypto StandardBabbage)) (BabbageTxOut StandardBabbage)
 -> Map
      (TxIn (EraCrypto StandardBabbage)) (BabbageTxOut StandardBabbage))
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Map
  (TxIn (EraCrypto StandardBabbage)) (BabbageTxOut StandardBabbage)
-> Set (TxIn (EraCrypto StandardBabbage))
-> Map
     (TxIn (EraCrypto StandardBabbage)) (BabbageTxOut StandardBabbage)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Getting
  (Set (TxIn (EraCrypto StandardBabbage)))
  (TxBody StandardBabbage)
  (Set (TxIn (EraCrypto StandardBabbage)))
-> TxBody StandardBabbage -> Set (TxIn (EraCrypto StandardBabbage))
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Set (TxIn (EraCrypto StandardBabbage)))
  (TxBody StandardBabbage)
  (Set (TxIn (EraCrypto StandardBabbage)))
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL (AlonzoTx StandardBabbage -> TxBody StandardBabbage
forall era. AlonzoTx era -> TxBody era
body Tx LedgerEra
AlonzoTx StandardBabbage
tx))
      let indexedOutputs :: [(TxIx, BabbageTxOut StandardBabbage)]
indexedOutputs =
            let outs :: [BabbageTxOut StandardBabbage]
outs = StrictSeq (BabbageTxOut StandardBabbage)
-> [BabbageTxOut StandardBabbage]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (BabbageTxOut StandardBabbage)
 -> [BabbageTxOut StandardBabbage])
-> StrictSeq (BabbageTxOut StandardBabbage)
-> [BabbageTxOut StandardBabbage]
forall a b. (a -> b) -> a -> b
$ AlonzoTx StandardBabbage -> TxBody StandardBabbage
forall era. AlonzoTx era -> TxBody era
body Tx LedgerEra
AlonzoTx StandardBabbage
tx TxBody StandardBabbage
-> Getting
     (StrictSeq (BabbageTxOut StandardBabbage))
     (TxBody StandardBabbage)
     (StrictSeq (BabbageTxOut StandardBabbage))
-> StrictSeq (BabbageTxOut StandardBabbage)
forall s a. s -> Getting a s a -> a
^. (StrictSeq (TxOut StandardBabbage)
 -> Const
      (StrictSeq (BabbageTxOut StandardBabbage))
      (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage
-> Const
     (StrictSeq (BabbageTxOut StandardBabbage)) (TxBody StandardBabbage)
Getting
  (StrictSeq (BabbageTxOut StandardBabbage))
  (TxBody StandardBabbage)
  (StrictSeq (BabbageTxOut StandardBabbage))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL
                maxIx :: Word64
maxIx = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ [BabbageTxOut StandardBabbage] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BabbageTxOut StandardBabbage]
outs
             in [TxIx]
-> [BabbageTxOut StandardBabbage]
-> [(TxIx, BabbageTxOut StandardBabbage)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word64 -> TxIx
Ledger.TxIx Word64
ix | Word64
ix <- [Word64
0 .. Word64
maxIx]] [BabbageTxOut StandardBabbage]
outs
      [(TxIx, BabbageTxOut StandardBabbage)]
-> ((TxIx, BabbageTxOut StandardBabbage)
    -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TxIx, BabbageTxOut StandardBabbage)]
indexedOutputs (((TxIx, BabbageTxOut StandardBabbage)
  -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
 -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
-> ((TxIx, BabbageTxOut StandardBabbage)
    -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall a b. (a -> b) -> a -> b
$ \(TxIx
ix, out :: BabbageTxOut StandardBabbage
out@(Babbage.BabbageTxOut Addr (EraCrypto StandardBabbage)
addr Value StandardBabbage
_ Datum StandardBabbage
_ StrictMaybe (Script StandardBabbage)
_)) ->
        Bool
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Addr StandardCrypto -> Bool
isOurs Addr StandardCrypto
Addr (EraCrypto StandardBabbage)
addr) (State (Map TxIn (BabbageTxOut StandardBabbage)) ()
 -> State (Map TxIn (BabbageTxOut StandardBabbage)) ())
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall a b. (a -> b) -> a -> b
$ (Map TxIn (BabbageTxOut StandardBabbage)
 -> Map TxIn (BabbageTxOut StandardBabbage))
-> State (Map TxIn (BabbageTxOut StandardBabbage)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (TxIn
-> BabbageTxOut StandardBabbage
-> Map TxIn (BabbageTxOut StandardBabbage)
-> Map TxIn (BabbageTxOut StandardBabbage)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TxId StandardCrypto -> TxIx -> TxIn
forall c. TxId c -> TxIx -> TxIn c
Ledger.TxIn TxId StandardCrypto
txId TxIx
ix) BabbageTxOut StandardBabbage
out)

getTxId ::
  ( HashAlgorithm (HASH crypto)
  , SafeHash.HashAnnotated
      (Ledger.TxBody (era crypto))
      EraIndependentTxBody
      crypto
  ) =>
  Babbage.AlonzoTx (era crypto) ->
  Ledger.TxId crypto
getTxId :: forall crypto (era :: * -> *).
(HashAlgorithm (HASH crypto),
 HashAnnotated (TxBody (era crypto)) EraIndependentTxBody crypto) =>
AlonzoTx (era crypto) -> TxId crypto
getTxId AlonzoTx (era crypto)
tx = SafeHash crypto EraIndependentTxBody -> TxId crypto
forall c. SafeHash c EraIndependentTxBody -> TxId c
Ledger.TxId (SafeHash crypto EraIndependentTxBody -> TxId crypto)
-> SafeHash crypto EraIndependentTxBody -> TxId crypto
forall a b. (a -> b) -> a -> b
$ TxBody (era crypto) -> SafeHash crypto EraIndependentTxBody
forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
SafeHash.hashAnnotated (AlonzoTx (era crypto) -> TxBody (era crypto)
forall era. AlonzoTx era -> TxBody era
body AlonzoTx (era crypto)
tx)

-- | This are all the error that can happen during coverFee.
data ErrCoverFee
  = ErrNotEnoughFunds ChangeError
  | ErrNoFuelUTxOFound
  | ErrUnknownInput {ErrCoverFee -> TxIn
input :: TxIn}
  | ErrScriptExecutionFailed {ErrCoverFee
-> (PlutusPurpose AsIndex LedgerEra,
    TransactionScriptFailure LedgerEra)
scriptFailure :: (PlutusPurpose AsIndex LedgerEra, TransactionScriptFailure LedgerEra)}
  | ErrTranslationError (ContextError LedgerEra)
  deriving stock (Int -> ErrCoverFee -> ShowS
[ErrCoverFee] -> ShowS
ErrCoverFee -> String
(Int -> ErrCoverFee -> ShowS)
-> (ErrCoverFee -> String)
-> ([ErrCoverFee] -> ShowS)
-> Show ErrCoverFee
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrCoverFee -> ShowS
showsPrec :: Int -> ErrCoverFee -> ShowS
$cshow :: ErrCoverFee -> String
show :: ErrCoverFee -> String
$cshowList :: [ErrCoverFee] -> ShowS
showList :: [ErrCoverFee] -> ShowS
Show)

data ChangeError = ChangeError {ChangeError -> Coin
inputBalance :: Coin, ChangeError -> Coin
outputBalance :: Coin}
  deriving stock (Int -> ChangeError -> ShowS
[ChangeError] -> ShowS
ChangeError -> String
(Int -> ChangeError -> ShowS)
-> (ChangeError -> String)
-> ([ChangeError] -> ShowS)
-> Show ChangeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChangeError -> ShowS
showsPrec :: Int -> ChangeError -> ShowS
$cshow :: ChangeError -> String
show :: ChangeError -> String
$cshowList :: [ChangeError] -> ShowS
showList :: [ChangeError] -> ShowS
Show)

-- | Cover fee for a transaction body using the given UTXO set. This calculate
-- necessary fees and augments inputs / outputs / collateral accordingly to
-- cover for the transaction cost and get the change back.
--
-- XXX: All call sites of this function use cardano-api types
coverFee_ ::
  Core.PParams LedgerEra ->
  SystemStart ->
  EpochInfo (Either Text) ->
  Map TxIn TxOut ->
  Map TxIn TxOut ->
  Babbage.AlonzoTx LedgerEra ->
  Either ErrCoverFee (Babbage.AlonzoTx LedgerEra)
coverFee_ :: PParams LedgerEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn TxOut
-> Map TxIn TxOut
-> AlonzoTx LedgerEra
-> Either ErrCoverFee (AlonzoTx LedgerEra)
coverFee_ PParams LedgerEra
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo Map TxIn TxOut
lookupUTxO Map TxIn TxOut
walletUTxO partialTx :: AlonzoTx LedgerEra
partialTx@Babbage.AlonzoTx{TxBody LedgerEra
body :: forall era. AlonzoTx era -> TxBody era
body :: TxBody LedgerEra
body, TxWits LedgerEra
wits :: forall era. AlonzoTx era -> TxWits era
wits :: TxWits LedgerEra
wits} = do
  (TxIn
feeTxIn, BabbageTxOut StandardBabbage
feeTxOut) <- Map TxIn (BabbageTxOut StandardBabbage)
-> Either ErrCoverFee (TxIn, BabbageTxOut StandardBabbage)
findUTxOToPayFees Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
walletUTxO

  let newInputs :: Set TxIn
newInputs = Getting (Set TxIn) (TxBody StandardBabbage) (Set TxIn)
-> BabbageTxBody StandardBabbage -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody StandardBabbage) (Set TxIn)
(Set (TxIn (EraCrypto StandardBabbage))
 -> Const (Set TxIn) (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage
-> Const (Set TxIn) (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
body Set TxIn -> Set TxIn -> Set TxIn
forall a. Semigroup a => a -> a -> a
<> TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
feeTxIn
  [BabbageTxOut StandardBabbage]
resolvedInputs <- (TxIn -> Either ErrCoverFee (BabbageTxOut StandardBabbage))
-> [TxIn] -> Either ErrCoverFee [BabbageTxOut StandardBabbage]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TxIn -> Either ErrCoverFee TxOut
TxIn -> Either ErrCoverFee (BabbageTxOut StandardBabbage)
resolveInput (Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set TxIn
newInputs)

  -- Ensure we have at least the minimum amount of ada. NOTE: setMinCoinTxOut
  -- would invalidate most Hydra protocol transactions.
  let txOuts :: StrictSeq (BabbageTxOut StandardBabbage)
txOuts = TxBody LedgerEra
BabbageTxBody StandardBabbage
body BabbageTxBody StandardBabbage
-> Getting
     (StrictSeq (TxOut StandardBabbage))
     (BabbageTxBody StandardBabbage)
     (StrictSeq (TxOut StandardBabbage))
-> StrictSeq (TxOut StandardBabbage)
forall s a. s -> Getting a s a -> a
^. (StrictSeq (TxOut StandardBabbage)
 -> Const
      (StrictSeq (TxOut StandardBabbage))
      (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage
-> Const
     (StrictSeq (TxOut StandardBabbage)) (TxBody StandardBabbage)
Getting
  (StrictSeq (TxOut StandardBabbage))
  (BabbageTxBody StandardBabbage)
  (StrictSeq (TxOut StandardBabbage))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL StrictSeq (TxOut StandardBabbage)
-> (TxOut StandardBabbage -> BabbageTxOut StandardBabbage)
-> StrictSeq (BabbageTxOut StandardBabbage)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> PParams StandardBabbage
-> TxOut StandardBabbage -> TxOut StandardBabbage
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams LedgerEra
PParams StandardBabbage
pparams

  -- Compute costs of redeemers
  let utxo :: Map TxIn (BabbageTxOut StandardBabbage)
utxo = Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
lookupUTxO Map TxIn (BabbageTxOut StandardBabbage)
-> Map TxIn (BabbageTxOut StandardBabbage)
-> Map TxIn (BabbageTxOut StandardBabbage)
forall a. Semigroup a => a -> a -> a
<> Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
walletUTxO
  Map (AlonzoPlutusPurpose AsIndex StandardBabbage) ExUnits
estimatedScriptCosts <- PParams LedgerEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn TxOut
-> AlonzoTx LedgerEra
-> Either
     ErrCoverFee (Map (PlutusPurpose AsIndex LedgerEra) ExUnits)
estimateScriptsCost PParams LedgerEra
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
utxo AlonzoTx LedgerEra
partialTx
  let adjustedRedeemers :: Redeemers LedgerEra
adjustedRedeemers =
        Set TxIn
-> Set TxIn
-> Map (PlutusPurpose AsIndex LedgerEra) ExUnits
-> Redeemers LedgerEra
-> Redeemers LedgerEra
adjustRedeemers
          (Getting (Set TxIn) (TxBody StandardBabbage) (Set TxIn)
-> BabbageTxBody StandardBabbage -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody StandardBabbage) (Set TxIn)
(Set (TxIn (EraCrypto StandardBabbage))
 -> Const (Set TxIn) (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage
-> Const (Set TxIn) (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
body)
          Set TxIn
newInputs
          Map (PlutusPurpose AsIndex LedgerEra) ExUnits
Map (AlonzoPlutusPurpose AsIndex StandardBabbage) ExUnits
estimatedScriptCosts
          (AlonzoTxWits StandardBabbage -> Redeemers StandardBabbage
forall era.
AlonzoEraScript era =>
AlonzoTxWits era -> Redeemers era
txrdmrs TxWits LedgerEra
AlonzoTxWits StandardBabbage
wits)

  -- Compute script integrity hash from adjusted redeemers
  let referenceScripts :: Map (ScriptHash (EraCrypto LedgerEra)) (Script LedgerEra)
referenceScripts = forall era.
BabbageEraTxOut era =>
UTxO era
-> Set (TxIn (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era)
getReferenceScripts @LedgerEra (Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
-> UTxO StandardBabbage
forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn (BabbageTxOut StandardBabbage)
Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
utxo) (Getting (Set TxIn) (TxBody StandardBabbage) (Set TxIn)
-> BabbageTxBody StandardBabbage -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody StandardBabbage) (Set TxIn)
(Set (TxIn (EraCrypto StandardBabbage))
 -> Const (Set TxIn) (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage
-> Const (Set TxIn) (TxBody StandardBabbage)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
referenceInputsTxBodyL TxBody LedgerEra
BabbageTxBody StandardBabbage
body)
      langs :: [LangDepView]
langs =
        [ PParams StandardBabbage -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams LedgerEra
PParams StandardBabbage
pparams Language
l
        | (ScriptHash (EraCrypto StandardBabbage)
_hash, Script StandardBabbage
script) <- Map
  (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
-> [(ScriptHash (EraCrypto StandardBabbage),
     Script StandardBabbage)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map
   (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
 -> [(ScriptHash (EraCrypto StandardBabbage),
      Script StandardBabbage)])
-> Map
     (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
-> [(ScriptHash (EraCrypto StandardBabbage),
     Script StandardBabbage)]
forall a b. (a -> b) -> a -> b
$ Map
  (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
-> Map
     (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
-> Map
     (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (AlonzoTxWits StandardBabbage
-> Map
     (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
forall era.
AlonzoEraScript era =>
AlonzoTxWits era -> Map (ScriptHash (EraCrypto era)) (Script era)
txscripts TxWits LedgerEra
AlonzoTxWits StandardBabbage
wits) Map (ScriptHash (EraCrypto LedgerEra)) (Script LedgerEra)
Map
  (ScriptHash (EraCrypto StandardBabbage)) (Script StandardBabbage)
referenceScripts
        , (Bool -> Bool
not (Bool -> Bool)
-> (Script StandardBabbage -> Bool)
-> Script StandardBabbage
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> Bool
isNativeScript @LedgerEra) Script StandardBabbage
script
        , Language
l <- Maybe Language -> [Language]
forall a. Maybe a -> [a]
maybeToList (Maybe Language -> [Language]) -> Maybe Language -> [Language]
forall a b. (a -> b) -> a -> b
$ PlutusScript StandardBabbage -> Language
forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage (PlutusScript StandardBabbage -> Language)
-> Maybe (PlutusScript StandardBabbage) -> Maybe Language
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script StandardBabbage -> Maybe (PlutusScript StandardBabbage)
forall era.
AlonzoEraScript era =>
Script era -> Maybe (PlutusScript era)
toPlutusScript Script StandardBabbage
script
        ]
      scriptIntegrityHash :: StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))
scriptIntegrityHash =
        Set LangDepView
-> Redeemers StandardBabbage
-> TxDats StandardBabbage
-> StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))
forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era
-> TxDats era
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
hashScriptIntegrity
          ([LangDepView] -> Set LangDepView
forall a. Ord a => [a] -> Set a
Set.fromList [LangDepView]
langs)
          Redeemers LedgerEra
Redeemers StandardBabbage
adjustedRedeemers
          (AlonzoTxWits StandardBabbage -> TxDats StandardBabbage
forall era. AlonzoEraScript era => AlonzoTxWits era -> TxDats era
txdats TxWits LedgerEra
AlonzoTxWits StandardBabbage
wits)

  let
    unbalancedBody :: BabbageTxBody StandardBabbage
unbalancedBody =
      TxBody LedgerEra
BabbageTxBody StandardBabbage
body
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (Set (TxIn (EraCrypto StandardBabbage)) -> Identity (Set TxIn))
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
(Set (TxIn (EraCrypto StandardBabbage))
 -> Identity (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
inputsTxBodyL ((Set (TxIn (EraCrypto StandardBabbage)) -> Identity (Set TxIn))
 -> BabbageTxBody StandardBabbage
 -> Identity (BabbageTxBody StandardBabbage))
-> Set TxIn
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
newInputs
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut StandardBabbage)
 -> Identity (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
(StrictSeq (TxOut StandardBabbage)
 -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL ((StrictSeq (TxOut StandardBabbage)
  -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
 -> BabbageTxBody StandardBabbage
 -> Identity (BabbageTxBody StandardBabbage))
-> StrictSeq (BabbageTxOut StandardBabbage)
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (BabbageTxOut StandardBabbage)
txOuts
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (Set (TxIn (EraCrypto StandardBabbage)) -> Identity (Set TxIn))
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
(Set (TxIn (EraCrypto StandardBabbage))
 -> Identity (Set (TxIn (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
Lens'
  (TxBody StandardBabbage) (Set (TxIn (EraCrypto StandardBabbage)))
collateralInputsTxBodyL ((Set (TxIn (EraCrypto StandardBabbage)) -> Identity (Set TxIn))
 -> BabbageTxBody StandardBabbage
 -> Identity (BabbageTxBody StandardBabbage))
-> Set TxIn
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
feeTxIn
        BabbageTxBody StandardBabbage
-> (BabbageTxBody StandardBabbage -> BabbageTxBody StandardBabbage)
-> BabbageTxBody StandardBabbage
forall a b. a -> (a -> b) -> b
& (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))
 -> Identity
      (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
(StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))
 -> Identity
      (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))))
-> BabbageTxBody StandardBabbage
-> Identity (BabbageTxBody StandardBabbage)
forall era.
AlonzoEraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era)))
Lens'
  (TxBody StandardBabbage)
  (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage)))
scriptIntegrityHashTxBodyL ((StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))
  -> Identity
       (StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))))
 -> BabbageTxBody StandardBabbage
 -> Identity (BabbageTxBody StandardBabbage))
-> StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))
-> BabbageTxBody StandardBabbage
-> BabbageTxBody StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (ScriptIntegrityHash (EraCrypto StandardBabbage))
scriptIntegrityHash
    unbalancedTx :: AlonzoTx StandardBabbage
unbalancedTx =
      AlonzoTx LedgerEra
AlonzoTx StandardBabbage
partialTx
        AlonzoTx StandardBabbage
-> (AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage)
-> AlonzoTx StandardBabbage
forall a b. a -> (a -> b) -> b
& (TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> Tx StandardBabbage -> Identity (Tx StandardBabbage)
(TxBody StandardBabbage
 -> Identity (BabbageTxBody StandardBabbage))
-> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardBabbage) (TxBody StandardBabbage)
bodyTxL ((TxBody StandardBabbage
  -> Identity (BabbageTxBody StandardBabbage))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> BabbageTxBody StandardBabbage
-> AlonzoTx StandardBabbage
-> AlonzoTx StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ BabbageTxBody StandardBabbage
unbalancedBody
        AlonzoTx StandardBabbage
-> (AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage)
-> AlonzoTx StandardBabbage
forall a b. a -> (a -> b) -> b
& (TxWits StandardBabbage -> Identity (TxWits StandardBabbage))
-> Tx StandardBabbage -> Identity (Tx StandardBabbage)
(TxWits StandardBabbage -> Identity (TxWits StandardBabbage))
-> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx StandardBabbage) (TxWits StandardBabbage)
witsTxL ((TxWits StandardBabbage -> Identity (TxWits StandardBabbage))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> ((Redeemers StandardBabbage
     -> Identity (Redeemers StandardBabbage))
    -> TxWits StandardBabbage -> Identity (TxWits StandardBabbage))
-> (Redeemers StandardBabbage
    -> Identity (Redeemers StandardBabbage))
-> AlonzoTx StandardBabbage
-> Identity (AlonzoTx StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers StandardBabbage -> Identity (Redeemers StandardBabbage))
-> TxWits StandardBabbage -> Identity (TxWits StandardBabbage)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits StandardBabbage) (Redeemers StandardBabbage)
rdmrsTxWitsL ((Redeemers StandardBabbage
  -> Identity (Redeemers StandardBabbage))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> Redeemers StandardBabbage
-> AlonzoTx StandardBabbage
-> AlonzoTx StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers LedgerEra
Redeemers StandardBabbage
adjustedRedeemers

  -- Compute fee using a body with selected txOut to pay fees (= full change)
  -- and an aditional witness (we will sign this tx later)
  let fee :: Coin
fee = PParams StandardBabbage -> Tx StandardBabbage -> Int -> Int -> Coin
forall era.
EraTx era =>
PParams era -> Tx era -> Int -> Int -> Coin
estimateMinFeeTx PParams LedgerEra
PParams StandardBabbage
pparams Tx StandardBabbage
AlonzoTx StandardBabbage
costingTx Int
additionalWitnesses Int
0
      costingTx :: AlonzoTx StandardBabbage
costingTx =
        AlonzoTx StandardBabbage
unbalancedTx
          AlonzoTx StandardBabbage
-> (AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage)
-> AlonzoTx StandardBabbage
forall a b. a -> (a -> b) -> b
& (TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> Tx StandardBabbage -> Identity (Tx StandardBabbage)
(TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardBabbage) (TxBody StandardBabbage)
bodyTxL ((TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> ((StrictSeq (BabbageTxOut StandardBabbage)
     -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
    -> TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> (StrictSeq (BabbageTxOut StandardBabbage)
    -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> AlonzoTx StandardBabbage
-> Identity (AlonzoTx StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut StandardBabbage)
 -> Identity (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
(StrictSeq (BabbageTxOut StandardBabbage)
 -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL ((StrictSeq (BabbageTxOut StandardBabbage)
  -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> (StrictSeq (BabbageTxOut StandardBabbage)
    -> StrictSeq (BabbageTxOut StandardBabbage))
-> AlonzoTx StandardBabbage
-> AlonzoTx StandardBabbage
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (BabbageTxOut StandardBabbage)
-> BabbageTxOut StandardBabbage
-> StrictSeq (BabbageTxOut StandardBabbage)
forall a. StrictSeq a -> a -> StrictSeq a
|> BabbageTxOut StandardBabbage
feeTxOut)
          AlonzoTx StandardBabbage
-> (AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage)
-> AlonzoTx StandardBabbage
forall a b. a -> (a -> b) -> b
& (TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> Tx StandardBabbage -> Identity (Tx StandardBabbage)
(TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardBabbage) (TxBody StandardBabbage)
bodyTxL ((TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> ((Coin -> Identity Coin)
    -> TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> (Coin -> Identity Coin)
-> AlonzoTx StandardBabbage
-> Identity (AlonzoTx StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody StandardBabbage) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> Coin -> AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
10_000_000
      -- XXX: Not hard-code but parameterize to make this flexible enough for
      -- later signing and commit transactions with more than one sig
      additionalWitnesses :: Int
additionalWitnesses = Int
2

  -- Balance tx with a change output and computed fee
  BabbageTxOut StandardBabbage
change <-
    (ChangeError -> ErrCoverFee)
-> Either ChangeError TxOut -> Either ErrCoverFee TxOut
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ChangeError -> ErrCoverFee
ErrNotEnoughFunds (Either ChangeError TxOut -> Either ErrCoverFee TxOut)
-> Either ChangeError TxOut -> Either ErrCoverFee TxOut
forall a b. (a -> b) -> a -> b
$
      TxOut -> [TxOut] -> [TxOut] -> Coin -> Either ChangeError TxOut
mkChange
        TxOut
BabbageTxOut StandardBabbage
feeTxOut
        [TxOut]
[BabbageTxOut StandardBabbage]
resolvedInputs
        (StrictSeq (BabbageTxOut StandardBabbage)
-> [BabbageTxOut StandardBabbage]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (BabbageTxOut StandardBabbage)
txOuts)
        Coin
fee
  AlonzoTx StandardBabbage
-> Either ErrCoverFee (AlonzoTx StandardBabbage)
forall a. a -> Either ErrCoverFee a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoTx StandardBabbage
 -> Either ErrCoverFee (AlonzoTx StandardBabbage))
-> AlonzoTx StandardBabbage
-> Either ErrCoverFee (AlonzoTx StandardBabbage)
forall a b. (a -> b) -> a -> b
$
    AlonzoTx StandardBabbage
unbalancedTx
      AlonzoTx StandardBabbage
-> (AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage)
-> AlonzoTx StandardBabbage
forall a b. a -> (a -> b) -> b
& (TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> Tx StandardBabbage -> Identity (Tx StandardBabbage)
(TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardBabbage) (TxBody StandardBabbage)
bodyTxL ((TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> ((StrictSeq (BabbageTxOut StandardBabbage)
     -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
    -> TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> (StrictSeq (BabbageTxOut StandardBabbage)
    -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> AlonzoTx StandardBabbage
-> Identity (AlonzoTx StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut StandardBabbage)
 -> Identity (StrictSeq (TxOut StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
(StrictSeq (BabbageTxOut StandardBabbage)
 -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody StandardBabbage) (StrictSeq (TxOut StandardBabbage))
outputsTxBodyL ((StrictSeq (BabbageTxOut StandardBabbage)
  -> Identity (StrictSeq (BabbageTxOut StandardBabbage)))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> (StrictSeq (BabbageTxOut StandardBabbage)
    -> StrictSeq (BabbageTxOut StandardBabbage))
-> AlonzoTx StandardBabbage
-> AlonzoTx StandardBabbage
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (BabbageTxOut StandardBabbage)
-> BabbageTxOut StandardBabbage
-> StrictSeq (BabbageTxOut StandardBabbage)
forall a. StrictSeq a -> a -> StrictSeq a
|> BabbageTxOut StandardBabbage
change)
      AlonzoTx StandardBabbage
-> (AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage)
-> AlonzoTx StandardBabbage
forall a b. a -> (a -> b) -> b
& (TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> Tx StandardBabbage -> Identity (Tx StandardBabbage)
(TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx StandardBabbage) (TxBody StandardBabbage)
bodyTxL ((TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> ((Coin -> Identity Coin)
    -> TxBody StandardBabbage -> Identity (TxBody StandardBabbage))
-> (Coin -> Identity Coin)
-> AlonzoTx StandardBabbage
-> Identity (AlonzoTx StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody StandardBabbage -> Identity (TxBody StandardBabbage)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody StandardBabbage) Coin
feeTxBodyL ((Coin -> Identity Coin)
 -> AlonzoTx StandardBabbage -> Identity (AlonzoTx StandardBabbage))
-> Coin -> AlonzoTx StandardBabbage -> AlonzoTx StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
 where
  findUTxOToPayFees :: Map TxIn (BabbageTxOut StandardBabbage)
-> Either ErrCoverFee (TxIn, BabbageTxOut StandardBabbage)
findUTxOToPayFees Map TxIn (BabbageTxOut StandardBabbage)
utxo = case Map TxIn TxOut -> Maybe (TxIn, TxOut)
findLargestUTxO Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
utxo of
    Maybe (TxIn, TxOut)
Nothing ->
      ErrCoverFee
-> Either ErrCoverFee (TxIn, BabbageTxOut StandardBabbage)
forall a b. a -> Either a b
Left ErrCoverFee
ErrNoFuelUTxOFound
    Just (TxIn
i, TxOut
o) ->
      (TxIn, BabbageTxOut StandardBabbage)
-> Either ErrCoverFee (TxIn, BabbageTxOut StandardBabbage)
forall a b. b -> Either a b
Right (TxIn
i, TxOut
BabbageTxOut StandardBabbage
o)

  getAdaValue :: TxOut -> Coin
  getAdaValue :: TxOut -> Coin
getAdaValue (Babbage.BabbageTxOut Addr (EraCrypto StandardBabbage)
_ Value StandardBabbage
value Datum StandardBabbage
_ StrictMaybe (Script StandardBabbage)
_) =
    MaryValue StandardCrypto -> Coin
forall t. Val t => t -> Coin
coin Value StandardBabbage
MaryValue StandardCrypto
value

  resolveInput :: TxIn -> Either ErrCoverFee TxOut
  resolveInput :: TxIn -> Either ErrCoverFee TxOut
resolveInput TxIn
i = do
    case TxIn
-> Map TxIn (BabbageTxOut StandardBabbage)
-> Maybe (BabbageTxOut StandardBabbage)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
i (Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
lookupUTxO Map TxIn (BabbageTxOut StandardBabbage)
-> Map TxIn (BabbageTxOut StandardBabbage)
-> Map TxIn (BabbageTxOut StandardBabbage)
forall a. Semigroup a => a -> a -> a
<> Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
walletUTxO) of
      Maybe (BabbageTxOut StandardBabbage)
Nothing -> ErrCoverFee -> Either ErrCoverFee TxOut
forall a b. a -> Either a b
Left (ErrCoverFee -> Either ErrCoverFee TxOut)
-> ErrCoverFee -> Either ErrCoverFee TxOut
forall a b. (a -> b) -> a -> b
$ TxIn -> ErrCoverFee
ErrUnknownInput TxIn
i
      Just BabbageTxOut StandardBabbage
o -> BabbageTxOut StandardBabbage
-> Either ErrCoverFee (BabbageTxOut StandardBabbage)
forall a b. b -> Either a b
Right BabbageTxOut StandardBabbage
o

  mkChange ::
    TxOut ->
    [TxOut] ->
    [TxOut] ->
    Coin ->
    Either ChangeError TxOut
  mkChange :: TxOut -> [TxOut] -> [TxOut] -> Coin -> Either ChangeError TxOut
mkChange (Babbage.BabbageTxOut Addr (EraCrypto StandardBabbage)
addr Value StandardBabbage
_ Datum StandardBabbage
datum StrictMaybe (Script StandardBabbage)
_) [TxOut]
resolvedInputs [TxOut]
otherOutputs Coin
fee
    -- FIXME: The delta between in and out must be greater than the min utxo value!
    | Coin
totalIn Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
totalOut =
        ChangeError -> Either ChangeError TxOut
forall a b. a -> Either a b
Left (ChangeError -> Either ChangeError TxOut)
-> ChangeError -> Either ChangeError TxOut
forall a b. (a -> b) -> a -> b
$
          ChangeError
            { $sel:inputBalance:ChangeError :: Coin
inputBalance = Coin
totalIn
            , $sel:outputBalance:ChangeError :: Coin
outputBalance = Coin
totalOut
            }
    | Bool
otherwise =
        TxOut -> Either ChangeError TxOut
forall a b. b -> Either a b
Right (TxOut -> Either ChangeError TxOut)
-> TxOut -> Either ChangeError TxOut
forall a b. (a -> b) -> a -> b
$ Addr (EraCrypto StandardBabbage)
-> Value StandardBabbage
-> Datum StandardBabbage
-> StrictMaybe (Script StandardBabbage)
-> BabbageTxOut StandardBabbage
forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr (EraCrypto era)
-> Value era
-> Datum era
-> StrictMaybe (Script era)
-> BabbageTxOut era
Babbage.BabbageTxOut Addr (EraCrypto StandardBabbage)
addr (Coin -> MaryValue StandardCrypto
forall t s. Inject t s => t -> s
Ledger.inject Coin
changeOut) Datum StandardBabbage
datum StrictMaybe (Script StandardBabbage)
StrictMaybe (AlonzoScript StandardBabbage)
forall {a}. StrictMaybe a
refScript
   where
    totalOut :: Coin
totalOut = (BabbageTxOut StandardBabbage -> Coin)
-> [BabbageTxOut StandardBabbage] -> Coin
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut -> Coin
BabbageTxOut StandardBabbage -> Coin
getAdaValue [TxOut]
[BabbageTxOut StandardBabbage]
otherOutputs Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
fee
    totalIn :: Coin
totalIn = (BabbageTxOut StandardBabbage -> Coin)
-> [BabbageTxOut StandardBabbage] -> Coin
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut -> Coin
BabbageTxOut StandardBabbage -> Coin
getAdaValue [TxOut]
[BabbageTxOut StandardBabbage]
resolvedInputs
    changeOut :: Coin
changeOut = Coin
totalIn Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin -> Coin
forall t. Val t => t -> t
invert Coin
totalOut
    refScript :: StrictMaybe a
refScript = StrictMaybe a
forall {a}. StrictMaybe a
SNothing

  adjustRedeemers :: Set TxIn -> Set TxIn -> Map (PlutusPurpose AsIndex LedgerEra) ExUnits -> Redeemers LedgerEra -> Redeemers LedgerEra
  adjustRedeemers :: Set TxIn
-> Set TxIn
-> Map (PlutusPurpose AsIndex LedgerEra) ExUnits
-> Redeemers LedgerEra
-> Redeemers LedgerEra
adjustRedeemers Set TxIn
initialInputs Set TxIn
finalInputs Map (PlutusPurpose AsIndex LedgerEra) ExUnits
estimatedCosts (Redeemers Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
initialRedeemers) =
    Map (PlutusPurpose AsIndex LedgerEra) (Data LedgerEra, ExUnits)
-> Redeemers LedgerEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIndex era) (Data era, ExUnits)
-> Redeemers era
Redeemers (Map (PlutusPurpose AsIndex LedgerEra) (Data LedgerEra, ExUnits)
 -> Redeemers LedgerEra)
-> Map (PlutusPurpose AsIndex LedgerEra) (Data LedgerEra, ExUnits)
-> Redeemers LedgerEra
forall a b. (a -> b) -> a -> b
$ [(PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits))]
-> Map (PlutusPurpose AsIndex LedgerEra) (Data LedgerEra, ExUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits))]
 -> Map (PlutusPurpose AsIndex LedgerEra) (Data LedgerEra, ExUnits))
-> [(PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits))]
-> Map (PlutusPurpose AsIndex LedgerEra) (Data LedgerEra, ExUnits)
forall a b. (a -> b) -> a -> b
$ ((AlonzoPlutusPurpose AsIndex StandardBabbage,
  (Data StandardBabbage, ExUnits))
 -> (PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits)))
-> [(AlonzoPlutusPurpose AsIndex StandardBabbage,
     (Data StandardBabbage, ExUnits))]
-> [(PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits))]
forall a b. (a -> b) -> [a] -> [b]
map (AlonzoPlutusPurpose AsIndex StandardBabbage,
 (Data StandardBabbage, ExUnits))
-> (PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits))
(AlonzoPlutusPurpose AsIndex StandardBabbage,
 (Data StandardBabbage, ExUnits))
-> (AlonzoPlutusPurpose AsIndex StandardBabbage,
    (Data StandardBabbage, ExUnits))
adjustOne ([(AlonzoPlutusPurpose AsIndex StandardBabbage,
   (Data StandardBabbage, ExUnits))]
 -> [(PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits))])
-> [(AlonzoPlutusPurpose AsIndex StandardBabbage,
     (Data StandardBabbage, ExUnits))]
-> [(PlutusPurpose AsIndex LedgerEra, (Data LedgerEra, ExUnits))]
forall a b. (a -> b) -> a -> b
$ Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
-> [(AlonzoPlutusPurpose AsIndex StandardBabbage,
     (Data StandardBabbage, ExUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  (PlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Data StandardBabbage, ExUnits)
initialRedeemers
   where
    sortedInputs :: [TxIn]
sortedInputs = [TxIn] -> [TxIn]
forall a. Ord a => [a] -> [a]
sort ([TxIn] -> [TxIn]) -> [TxIn] -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set TxIn
initialInputs
    sortedFinalInputs :: [TxIn]
sortedFinalInputs = [TxIn] -> [TxIn]
forall a. Ord a => [a] -> [a]
sort ([TxIn] -> [TxIn]) -> [TxIn] -> [TxIn]
forall a b. (a -> b) -> a -> b
$ Set TxIn -> [TxIn]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set TxIn
finalInputs
    differences :: [Int]
differences = ((TxIn, TxIn) -> Bool) -> [(TxIn, TxIn)] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
List.findIndices (Bool -> Bool
not (Bool -> Bool) -> ((TxIn, TxIn) -> Bool) -> (TxIn, TxIn) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn -> TxIn -> Bool) -> (TxIn, TxIn) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
(==)) ([(TxIn, TxIn)] -> [Int]) -> [(TxIn, TxIn)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [TxIn] -> [TxIn] -> [(TxIn, TxIn)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn]
sortedInputs [TxIn]
sortedFinalInputs

    adjustOne :: (AlonzoPlutusPurpose AsIndex StandardBabbage,
 (Data StandardBabbage, ExUnits))
-> (AlonzoPlutusPurpose AsIndex StandardBabbage,
    (Data StandardBabbage, ExUnits))
adjustOne (AlonzoPlutusPurpose AsIndex StandardBabbage
ptr, (Data StandardBabbage
d, ExUnits
_exUnits)) =
      case AlonzoPlutusPurpose AsIndex StandardBabbage
ptr of
        AlonzoSpending AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
idx
          | Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AsIndex Word32 (TxIn (EraCrypto StandardBabbage)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
idx) Int -> [Int] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Int]
differences ->
              (AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
-> AlonzoPlutusPurpose AsIndex StandardBabbage
forall (f :: * -> * -> *) era.
f Word32 (TxIn (EraCrypto era)) -> AlonzoPlutusPurpose f era
AlonzoSpending (Word32 -> AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
forall ix it. ix -> AsIndex ix it
AsIndex (AsIndex Word32 (TxIn (EraCrypto StandardBabbage)) -> Word32
forall ix it. AsIndex ix it -> ix
unAsIndex AsIndex Word32 (TxIn (EraCrypto StandardBabbage))
idx Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1)), (Data StandardBabbage
d, PlutusPurpose AsIndex LedgerEra -> ExUnits
executionUnitsFor PlutusPurpose AsIndex LedgerEra
AlonzoPlutusPurpose AsIndex StandardBabbage
ptr))
        AlonzoPlutusPurpose AsIndex StandardBabbage
_ ->
          (AlonzoPlutusPurpose AsIndex StandardBabbage
ptr, (Data StandardBabbage
d, PlutusPurpose AsIndex LedgerEra -> ExUnits
executionUnitsFor PlutusPurpose AsIndex LedgerEra
AlonzoPlutusPurpose AsIndex StandardBabbage
ptr))

    executionUnitsFor :: PlutusPurpose AsIndex LedgerEra -> ExUnits
    executionUnitsFor :: PlutusPurpose AsIndex LedgerEra -> ExUnits
executionUnitsFor PlutusPurpose AsIndex LedgerEra
ptr =
      let ExUnits Natural
maxMem Natural
maxCpu = PParams LedgerEra
PParams StandardBabbage
pparams PParams StandardBabbage
-> Getting ExUnits (PParams StandardBabbage) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams StandardBabbage) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams StandardBabbage) ExUnits
ppMaxTxExUnitsL
          ExUnits Natural
totalMem Natural
totalCpu = (ExUnits -> ExUnits)
-> Map (AlonzoPlutusPurpose AsIndex StandardBabbage) ExUnits
-> ExUnits
forall m a.
Monoid m =>
(a -> m)
-> Map (AlonzoPlutusPurpose AsIndex StandardBabbage) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ExUnits -> ExUnits
forall a. a -> a
identity Map (PlutusPurpose AsIndex LedgerEra) ExUnits
Map (AlonzoPlutusPurpose AsIndex StandardBabbage) ExUnits
estimatedCosts
          ExUnits Natural
approxMem Natural
approxCpu = Map (PlutusPurpose AsIndex LedgerEra) ExUnits
Map (AlonzoPlutusPurpose AsIndex StandardBabbage) ExUnits
estimatedCosts Map (AlonzoPlutusPurpose AsIndex StandardBabbage) ExUnits
-> AlonzoPlutusPurpose AsIndex StandardBabbage -> ExUnits
forall k a. Ord k => Map k a -> k -> a
! PlutusPurpose AsIndex LedgerEra
AlonzoPlutusPurpose AsIndex StandardBabbage
ptr
       in Natural -> Natural -> ExUnits
ExUnits
            (Ratio Natural -> Natural
forall b. Integral b => Ratio Natural -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Natural
maxMem Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
approxMem Natural -> Natural -> Ratio Natural
forall a. Integral a => a -> a -> Ratio a
% Natural
totalMem))
            (Ratio Natural -> Natural
forall b. Integral b => Ratio Natural -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Natural
maxCpu Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
approxCpu Natural -> Natural -> Ratio Natural
forall a. Integral a => a -> a -> Ratio a
% Natural
totalCpu))

findLargestUTxO :: Map TxIn TxOut -> Maybe (TxIn, TxOut)
findLargestUTxO :: Map TxIn TxOut -> Maybe (TxIn, TxOut)
findLargestUTxO Map TxIn TxOut
utxo =
  UTxO -> Maybe (TxIn, BabbageTxOut StandardBabbage)
maxLovelaceUTxO UTxO
apiUtxo
 where
  apiUtxo :: UTxO
apiUtxo = [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall out. [(TxIn, out)] -> UTxO' out
UTxO.fromPairs ([(TxIn, TxOut CtxUTxO Era)] -> UTxO)
-> [(TxIn, TxOut CtxUTxO Era)] -> UTxO
forall a b. (a -> b) -> a -> b
$ (TxIn -> TxIn)
-> (BabbageTxOut StandardBabbage -> TxOut CtxUTxO Era)
-> (TxIn, BabbageTxOut StandardBabbage)
-> (TxIn, TxOut CtxUTxO Era)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxIn -> TxIn
fromLedgerTxIn TxOut -> TxOut CtxUTxO Era
BabbageTxOut StandardBabbage -> TxOut CtxUTxO Era
forall ctx. TxOut -> TxOut ctx Era
fromLedgerTxOut ((TxIn, BabbageTxOut StandardBabbage) -> (TxIn, TxOut CtxUTxO Era))
-> [(TxIn, BabbageTxOut StandardBabbage)]
-> [(TxIn, TxOut CtxUTxO Era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map TxIn (BabbageTxOut StandardBabbage)
-> [(TxIn, BabbageTxOut StandardBabbage)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn TxOut
Map TxIn (BabbageTxOut StandardBabbage)
utxo

  maxLovelaceUTxO :: UTxO -> Maybe (TxIn, BabbageTxOut StandardBabbage)
maxLovelaceUTxO =
    ((TxIn, TxOut CtxUTxO Era) -> (TxIn, BabbageTxOut StandardBabbage))
-> Maybe (TxIn, TxOut CtxUTxO Era)
-> Maybe (TxIn, BabbageTxOut StandardBabbage)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxIn -> TxIn)
-> (TxOut CtxUTxO Era -> BabbageTxOut StandardBabbage)
-> (TxIn, TxOut CtxUTxO Era)
-> (TxIn, BabbageTxOut StandardBabbage)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxIn -> TxIn
toLedgerTxIn TxOut CtxUTxO Era -> TxOut
TxOut CtxUTxO Era -> BabbageTxOut StandardBabbage
toLedgerTxOut)
      (Maybe (TxIn, TxOut CtxUTxO Era)
 -> Maybe (TxIn, BabbageTxOut StandardBabbage))
-> (UTxO -> Maybe (TxIn, TxOut CtxUTxO Era))
-> UTxO
-> Maybe (TxIn, BabbageTxOut StandardBabbage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxIn, TxOut CtxUTxO Era)] -> Maybe (TxIn, TxOut CtxUTxO Era)
forall a. [a] -> Maybe a
listToMaybe
      ([(TxIn, TxOut CtxUTxO Era)] -> Maybe (TxIn, TxOut CtxUTxO Era))
-> (UTxO -> [(TxIn, TxOut CtxUTxO Era)])
-> UTxO
-> Maybe (TxIn, TxOut CtxUTxO Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut CtxUTxO Era) -> Down Coin)
-> [(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Coin -> Down Coin
forall a. a -> Down a
Down (Coin -> Down Coin)
-> ((TxIn, TxOut CtxUTxO Era) -> Coin)
-> (TxIn, TxOut CtxUTxO Era)
-> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Coin
selectLovelace (Value -> Coin)
-> ((TxIn, TxOut CtxUTxO Era) -> Value)
-> (TxIn, TxOut CtxUTxO Era)
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxUTxO Era -> Value
forall ctx. TxOut ctx -> Value
Api.txOutValue (TxOut CtxUTxO Era -> Value)
-> ((TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era)
-> (TxIn, TxOut CtxUTxO Era)
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut CtxUTxO Era) -> TxOut CtxUTxO Era
forall a b. (a, b) -> b
snd)
      ([(TxIn, TxOut CtxUTxO Era)] -> [(TxIn, TxOut CtxUTxO Era)])
-> (UTxO -> [(TxIn, TxOut CtxUTxO Era)])
-> UTxO
-> [(TxIn, TxOut CtxUTxO Era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO -> [(TxIn, TxOut CtxUTxO Era)]
forall out. UTxO' out -> [(TxIn, out)]
UTxO.pairs

-- | Estimate cost of script executions on the transaction. This is only an
-- estimates because the transaction isn't sealed at this point and adding new
-- elements to it like change outputs or script integrity hash may increase that
-- cost a little.
estimateScriptsCost ::
  -- | Protocol parameters
  Core.PParams LedgerEra ->
  -- | Start of the blockchain, for converting slots to UTC times
  SystemStart ->
  -- | Information about epoch sizes, for converting slots to UTC times
  EpochInfo (Either Text) ->
  -- | A UTXO needed to resolve inputs
  Map TxIn TxOut ->
  -- | The pre-constructed transaction
  Babbage.AlonzoTx LedgerEra ->
  Either ErrCoverFee (Map (PlutusPurpose AsIndex LedgerEra) ExUnits)
estimateScriptsCost :: PParams LedgerEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn TxOut
-> AlonzoTx LedgerEra
-> Either
     ErrCoverFee (Map (PlutusPurpose AsIndex LedgerEra) ExUnits)
estimateScriptsCost PParams LedgerEra
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo Map TxIn TxOut
utxo AlonzoTx LedgerEra
tx = do
  case Either
  (ContextError StandardBabbage) (RedeemerReport StandardBabbage)
result of
    Left ContextError StandardBabbage
translationError ->
      ErrCoverFee
-> Either
     ErrCoverFee (Map (PlutusPurpose AsIndex LedgerEra) ExUnits)
forall a b. a -> Either a b
Left (ErrCoverFee
 -> Either
      ErrCoverFee (Map (PlutusPurpose AsIndex LedgerEra) ExUnits))
-> ErrCoverFee
-> Either
     ErrCoverFee (Map (PlutusPurpose AsIndex LedgerEra) ExUnits)
forall a b. (a -> b) -> a -> b
$ ContextError LedgerEra -> ErrCoverFee
ErrTranslationError ContextError LedgerEra
ContextError StandardBabbage
translationError
    Right RedeemerReport StandardBabbage
units ->
      (AlonzoPlutusPurpose AsIndex StandardBabbage
 -> Either (TransactionScriptFailure StandardBabbage) ExUnits
 -> Either ErrCoverFee ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIndex StandardBabbage)
     (Either (TransactionScriptFailure StandardBabbage) ExUnits)
-> Either
     ErrCoverFee
     (Map (AlonzoPlutusPurpose AsIndex StandardBabbage) ExUnits)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (\AlonzoPlutusPurpose AsIndex StandardBabbage
ptr -> (TransactionScriptFailure StandardBabbage -> ErrCoverFee)
-> Either (TransactionScriptFailure StandardBabbage) ExUnits
-> Either ErrCoverFee ExUnits
forall a b c. (a -> b) -> Either a c -> Either b c
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((TransactionScriptFailure StandardBabbage -> ErrCoverFee)
 -> Either (TransactionScriptFailure StandardBabbage) ExUnits
 -> Either ErrCoverFee ExUnits)
-> (TransactionScriptFailure StandardBabbage -> ErrCoverFee)
-> Either (TransactionScriptFailure StandardBabbage) ExUnits
-> Either ErrCoverFee ExUnits
forall a b. (a -> b) -> a -> b
$ (PlutusPurpose AsIndex LedgerEra,
 TransactionScriptFailure LedgerEra)
-> ErrCoverFee
(AlonzoPlutusPurpose AsIndex StandardBabbage,
 TransactionScriptFailure StandardBabbage)
-> ErrCoverFee
ErrScriptExecutionFailed ((AlonzoPlutusPurpose AsIndex StandardBabbage,
  TransactionScriptFailure StandardBabbage)
 -> ErrCoverFee)
-> (TransactionScriptFailure StandardBabbage
    -> (AlonzoPlutusPurpose AsIndex StandardBabbage,
        TransactionScriptFailure StandardBabbage))
-> TransactionScriptFailure StandardBabbage
-> ErrCoverFee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AlonzoPlutusPurpose AsIndex StandardBabbage
ptr,)) RedeemerReport StandardBabbage
Map
  (AlonzoPlutusPurpose AsIndex StandardBabbage)
  (Either (TransactionScriptFailure StandardBabbage) ExUnits)
units
 where
  result :: Either
  (ContextError StandardBabbage) (RedeemerReport StandardBabbage)
result =
    PParams StandardBabbage
-> Tx StandardBabbage
-> UTxO StandardBabbage
-> EpochInfo (Either Text)
-> SystemStart
-> Either
     (ContextError StandardBabbage) (RedeemerReport StandardBabbage)
forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Either (ContextError era) (RedeemerReport era)
evalTxExUnits
      PParams LedgerEra
PParams StandardBabbage
pparams
      Tx StandardBabbage
AlonzoTx LedgerEra
tx
      (Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
-> UTxO StandardBabbage
forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn TxOut
Map (TxIn (EraCrypto StandardBabbage)) (TxOut StandardBabbage)
utxo)
      EpochInfo (Either Text)
epochInfo
      SystemStart
systemStart

--
-- Logs
--

data TinyWalletLog
  = BeginInitialize
  | EndInitialize {TinyWalletLog -> UTxO
initialUTxO :: Api.UTxO, TinyWalletLog -> ChainPoint
tip :: ChainPoint}
  | BeginUpdate {TinyWalletLog -> ChainPoint
point :: ChainPoint}
  | EndUpdate {TinyWalletLog -> UTxO
newUTxO :: Api.UTxO}
  | SkipUpdate {point :: ChainPoint}
  deriving stock (TinyWalletLog -> TinyWalletLog -> Bool
(TinyWalletLog -> TinyWalletLog -> Bool)
-> (TinyWalletLog -> TinyWalletLog -> Bool) -> Eq TinyWalletLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TinyWalletLog -> TinyWalletLog -> Bool
== :: TinyWalletLog -> TinyWalletLog -> Bool
$c/= :: TinyWalletLog -> TinyWalletLog -> Bool
/= :: TinyWalletLog -> TinyWalletLog -> Bool
Eq, (forall x. TinyWalletLog -> Rep TinyWalletLog x)
-> (forall x. Rep TinyWalletLog x -> TinyWalletLog)
-> Generic TinyWalletLog
forall x. Rep TinyWalletLog x -> TinyWalletLog
forall x. TinyWalletLog -> Rep TinyWalletLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TinyWalletLog -> Rep TinyWalletLog x
from :: forall x. TinyWalletLog -> Rep TinyWalletLog x
$cto :: forall x. Rep TinyWalletLog x -> TinyWalletLog
to :: forall x. Rep TinyWalletLog x -> TinyWalletLog
Generic, Int -> TinyWalletLog -> ShowS
[TinyWalletLog] -> ShowS
TinyWalletLog -> String
(Int -> TinyWalletLog -> ShowS)
-> (TinyWalletLog -> String)
-> ([TinyWalletLog] -> ShowS)
-> Show TinyWalletLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TinyWalletLog -> ShowS
showsPrec :: Int -> TinyWalletLog -> ShowS
$cshow :: TinyWalletLog -> String
show :: TinyWalletLog -> String
$cshowList :: [TinyWalletLog] -> ShowS
showList :: [TinyWalletLog] -> ShowS
Show)

deriving anyclass instance ToJSON TinyWalletLog
deriving anyclass instance FromJSON TinyWalletLog

instance Arbitrary TinyWalletLog where
  arbitrary :: Gen TinyWalletLog
arbitrary = Gen TinyWalletLog
forall a.
(Generic a, GA UnsizedOpts (Rep a),
 UniformWeight (Weights_ (Rep a))) =>
Gen a
genericArbitrary
  shrink :: TinyWalletLog -> [TinyWalletLog]
shrink = TinyWalletLog -> [TinyWalletLog]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink