{-# 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.Ledger.Address qualified as Ledger
import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext)
import Cardano.Ledger.Alonzo.Scripts (
  AlonzoEraScript (..),
  AsIx (..),
  ExUnits (ExUnits),
  plutusScriptLanguage,
  unAsIx,
 )
import Cardano.Ledger.Alonzo.TxWits (
  Redeemers (..),
  datsTxWitsL,
 )
import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded)
import Cardano.Ledger.Api (
  AlonzoEraTx,
  BabbageEraTxBody,
  ConwayEra,
  Data,
  PParams,
  TransactionScriptFailure,
  Tx,
  bodyTxL,
  calcMinFeeTx,
  coinTxOutL,
  collateralInputsTxBodyL,
  ensureMinCoinTxOut,
  evalTxExUnits,
  feeTxBodyL,
  inputsTxBodyL,
  outputsTxBodyL,
  ppMaxTxExUnitsL,
  rdmrsTxWitsL,
  referenceInputsTxBodyL,
  reqSignerHashesTxBodyL,
  scriptIntegrityHashTxBodyL,
  scriptTxWitsL,
  witsTxL,
  pattern SpendingPurpose,
 )
import Cardano.Ledger.Api.UTxO (EraUTxO, ScriptsNeeded)
import Cardano.Ledger.Babbage.Tx (body, getLanguageView, hashScriptIntegrity)
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 (
  TxUpgradeError,
 )
import Cardano.Ledger.Core qualified as Core
import Cardano.Ledger.Core qualified as Ledger
import Cardano.Ledger.Hashes (EraIndependentTxBody, HashAnnotated, hashAnnotated)
import Cardano.Ledger.Shelley.API (unUTxO)
import Cardano.Ledger.Shelley.API qualified as Ledger
import Cardano.Ledger.Val (invert)
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart (..))
import Control.Concurrent.Class.MonadSTM (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.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,
  fromLedgerUTxO,
  getChainPoint,
  makeShelleyAddress,
  shelleyAddressInEra,
  toLedgerAddr,
  toLedgerTx,
  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
type TxIn = Ledger.TxIn
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 -> SystemStart
systemStart :: SystemStart
  , WalletInfoOnChain -> ChainPoint
tip :: ChainPoint
  -- ^ Latest point on chain the wallet knows of.
  }

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

-- | 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)) ->
  -- | A means to query some pparams.
  IO (PParams ConwayEra) ->
  IO (TinyWallet IO)
newTinyWallet :: Tracer IO TinyWalletLog
-> NetworkId
-> (VerificationKey PaymentKey, SigningKey PaymentKey)
-> ChainQuery IO
-> IO (EpochInfo (Either Text))
-> IO (PParams ConwayEra)
-> IO (TinyWallet IO)
newTinyWallet Tracer IO TinyWalletLog
tracer NetworkId
networkId (VerificationKey PaymentKey
vk, SigningKey PaymentKey
sk) ChainQuery IO
queryWalletInfo IO (EpochInfo (Either Text))
queryEpochInfo IO (PParams ConwayEra)
querySomePParams = 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 ConwayEra))
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 ConwayEra))
-> STM IO (Map TxIn (BabbageTxOut ConwayEra))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> WalletInfoOnChain -> Map TxIn TxOut
WalletInfoOnChain -> Map TxIn (BabbageTxOut ConwayEra)
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 ConwayEra))
$sel:getUTxO:TinyWallet :: STM IO (Map TxIn TxOut)
getUTxO :: STM IO (Map TxIn (BabbageTxOut ConwayEra))
getUTxO
      , $sel:getSeedInput:TinyWallet :: STM IO (Maybe TxIn)
getSeedInput = ((TxIn, BabbageTxOut ConwayEra) -> TxIn)
-> Maybe (TxIn, BabbageTxOut ConwayEra) -> 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 ConwayEra) -> TxIn)
-> (TxIn, BabbageTxOut ConwayEra)
-> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, BabbageTxOut ConwayEra) -> TxIn
forall a b. (a, b) -> a
fst) (Maybe (TxIn, BabbageTxOut ConwayEra) -> Maybe TxIn)
-> (Map TxIn (BabbageTxOut ConwayEra)
    -> Maybe (TxIn, BabbageTxOut ConwayEra))
-> Map TxIn (BabbageTxOut ConwayEra)
-> Maybe TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut ConwayEra) -> Maybe (TxIn, TxOut ConwayEra)
Map TxIn (BabbageTxOut ConwayEra)
-> Maybe (TxIn, BabbageTxOut ConwayEra)
forall era.
EraTxOut era =>
Map TxIn (TxOut era) -> Maybe (TxIn, TxOut era)
findLargestUTxO (Map TxIn (BabbageTxOut ConwayEra) -> Maybe TxIn)
-> STM IO (Map TxIn (BabbageTxOut ConwayEra))
-> STM IO (Maybe TxIn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM IO (Map TxIn (BabbageTxOut ConwayEra))
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
          let ledgerLookupUTxO :: Map TxIn TxOut
ledgerLookupUTxO = UTxO LedgerEra -> Map TxIn TxOut
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO (UTxO LedgerEra -> Map TxIn TxOut)
-> UTxO LedgerEra -> Map TxIn TxOut
forall a b. (a -> b) -> a -> b
$ UTxO -> UTxO LedgerEra
toLedgerUTxO UTxO
lookupUTxO
          WalletInfoOnChain{Map TxIn TxOut
$sel:walletUTxO:WalletInfoOnChain :: WalletInfoOnChain -> Map TxIn TxOut
walletUTxO :: Map TxIn TxOut
walletUTxO, 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
          EpochInfo (Either Text)
epochInfo <- IO (EpochInfo (Either Text))
queryEpochInfo
          -- We query pparams here again as it's possible that a hardfork
          -- occurred and the pparams changed.
          PParams ConwayEra
pparams <- IO (PParams ConwayEra)
querySomePParams
          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 ConwayEra -> Tx
forall era.
IsShelleyBasedEra era =>
Tx (ShelleyLedgerEra era) -> Tx era
fromLedgerTx
              (AlonzoTx ConwayEra -> Tx)
-> Either ErrCoverFee (AlonzoTx ConwayEra) -> Either ErrCoverFee Tx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PParams ConwayEra
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut ConwayEra)
-> Map TxIn (TxOut ConwayEra)
-> Tx ConwayEra
-> Either ErrCoverFee (Tx ConwayEra)
forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era,
 BabbageEraTxBody era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx era
-> Either ErrCoverFee (Tx era)
coverFee_ PParams ConwayEra
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo Map TxIn (TxOut ConwayEra)
Map TxIn TxOut
ledgerLookupUTxO Map TxIn (TxOut ConwayEra)
Map TxIn TxOut
walletUTxO (Tx -> Tx LedgerEra
forall 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 ConwayEra)
utxo' <- STM IO (Map TxIn (BabbageTxOut ConwayEra))
-> IO (Map TxIn (BabbageTxOut ConwayEra))
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 ConwayEra))
 -> IO (Map TxIn (BabbageTxOut ConwayEra)))
-> STM IO (Map TxIn (BabbageTxOut ConwayEra))
-> IO (Map TxIn (BabbageTxOut ConwayEra))
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 -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs [Tx]
txs (Addr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
== Addr
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 ConwayEra)
-> STM (Map TxIn (BabbageTxOut ConwayEra))
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TxIn TxOut
Map TxIn (BabbageTxOut ConwayEra)
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 (TxOut ConwayEra) -> UTxO ConwayEra
forall era. Map TxIn (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn (TxOut ConwayEra)
Map TxIn (BabbageTxOut ConwayEra)
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 (TxOut ConwayEra) -> UTxO ConwayEra
forall era. Map TxIn (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn (TxOut ConwayEra)
Map TxIn TxOut
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
ledgerAddress = AddressInEra Era -> Addr
forall era. AddressInEra era -> Addr
toLedgerAddr (AddressInEra Era -> Addr) -> AddressInEra Era -> Addr
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 -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
applyTxs [Tx]
txs Addr -> Bool
isOurs Map TxIn TxOut
utxo =
  (State (Map TxIn (BabbageTxOut ConwayEra)) ()
 -> Map TxIn (BabbageTxOut ConwayEra) -> Map TxIn TxOut)
-> Map TxIn (BabbageTxOut ConwayEra)
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
-> Map TxIn TxOut
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Map TxIn (BabbageTxOut ConwayEra)) ()
-> Map TxIn (BabbageTxOut ConwayEra) -> Map TxIn TxOut
State (Map TxIn (BabbageTxOut ConwayEra)) ()
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall s a. State s a -> s -> s
execState Map TxIn TxOut
Map TxIn (BabbageTxOut ConwayEra)
utxo (State (Map TxIn (BabbageTxOut ConwayEra)) () -> Map TxIn TxOut)
-> State (Map TxIn (BabbageTxOut ConwayEra)) () -> Map TxIn TxOut
forall a b. (a -> b) -> a -> b
$ do
    [Tx]
-> (Tx -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Tx]
txs ((Tx -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
 -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
-> (Tx -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
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. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
apiTx
      let txId :: TxId
txId = AlonzoTx ConwayEra -> TxId
forall era.
HashAnnotated (TxBody era) EraIndependentTxBody =>
AlonzoTx era -> TxId
getTxId Tx LedgerEra
AlonzoTx ConwayEra
tx
      (Map TxIn (BabbageTxOut ConwayEra)
 -> Map TxIn (BabbageTxOut ConwayEra))
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Map TxIn (BabbageTxOut ConwayEra)
-> Set TxIn -> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
-> TxBody ConwayEra -> Set TxIn
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Set TxIn) (TxBody ConwayEra) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody ConwayEra) (Set TxIn)
inputsTxBodyL (AlonzoTx ConwayEra -> TxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body Tx LedgerEra
AlonzoTx ConwayEra
tx))
      let indexedOutputs :: [(TxIx, BabbageTxOut ConwayEra)]
indexedOutputs =
            let outs :: [BabbageTxOut ConwayEra]
outs = StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra])
-> StrictSeq (BabbageTxOut ConwayEra) -> [BabbageTxOut ConwayEra]
forall a b. (a -> b) -> a -> b
$ AlonzoTx ConwayEra -> TxBody ConwayEra
forall era. AlonzoTx era -> TxBody era
body Tx LedgerEra
AlonzoTx ConwayEra
tx TxBody ConwayEra
-> Getting
     (StrictSeq (BabbageTxOut ConwayEra))
     (TxBody ConwayEra)
     (StrictSeq (BabbageTxOut ConwayEra))
-> StrictSeq (BabbageTxOut ConwayEra)
forall s a. s -> Getting a s a -> a
^. (StrictSeq (TxOut ConwayEra)
 -> Const
      (StrictSeq (BabbageTxOut ConwayEra)) (StrictSeq (TxOut ConwayEra)))
-> TxBody ConwayEra
-> Const (StrictSeq (BabbageTxOut ConwayEra)) (TxBody ConwayEra)
Getting
  (StrictSeq (BabbageTxOut ConwayEra))
  (TxBody ConwayEra)
  (StrictSeq (BabbageTxOut ConwayEra))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody ConwayEra) (StrictSeq (TxOut ConwayEra))
outputsTxBodyL
                maxIx :: Word16
maxIx = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ [BabbageTxOut ConwayEra] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BabbageTxOut ConwayEra]
outs
             in [TxIx]
-> [BabbageTxOut ConwayEra] -> [(TxIx, BabbageTxOut ConwayEra)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word16 -> TxIx
Ledger.TxIx Word16
ix | Word16
ix <- [Word16
0 .. Word16
maxIx]] [BabbageTxOut ConwayEra]
outs
      [(TxIx, BabbageTxOut ConwayEra)]
-> ((TxIx, BabbageTxOut ConwayEra)
    -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(TxIx, BabbageTxOut ConwayEra)]
indexedOutputs (((TxIx, BabbageTxOut ConwayEra)
  -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
 -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
-> ((TxIx, BabbageTxOut ConwayEra)
    -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
forall a b. (a -> b) -> a -> b
$ \(TxIx
ix, out :: BabbageTxOut ConwayEra
out@(Babbage.BabbageTxOut Addr
addr Value ConwayEra
_ Datum ConwayEra
_ StrictMaybe (Script ConwayEra)
_)) ->
        Bool
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Addr -> Bool
isOurs Addr
addr) (State (Map TxIn (BabbageTxOut ConwayEra)) ()
 -> State (Map TxIn (BabbageTxOut ConwayEra)) ())
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
forall a b. (a -> b) -> a -> b
$ (Map TxIn (BabbageTxOut ConwayEra)
 -> Map TxIn (BabbageTxOut ConwayEra))
-> State (Map TxIn (BabbageTxOut ConwayEra)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (TxIn
-> BabbageTxOut ConwayEra
-> Map TxIn (BabbageTxOut ConwayEra)
-> Map TxIn (BabbageTxOut ConwayEra)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TxId -> TxIx -> TxIn
Ledger.TxIn TxId
txId TxIx
ix) BabbageTxOut ConwayEra
out)

getTxId ::
  HashAnnotated
    (Ledger.TxBody era)
    EraIndependentTxBody =>
  Babbage.AlonzoTx era ->
  Ledger.TxId
getTxId :: forall era.
HashAnnotated (TxBody era) EraIndependentTxBody =>
AlonzoTx era -> TxId
getTxId AlonzoTx era
tx = SafeHash EraIndependentTxBody -> TxId
Ledger.TxId (SafeHash EraIndependentTxBody -> TxId)
-> SafeHash EraIndependentTxBody -> TxId
forall a b. (a -> b) -> a -> b
$ TxBody era -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated (AlonzoTx era -> TxBody era
forall era. AlonzoTx era -> TxBody era
body AlonzoTx era
tx)

-- | This are all the error that can happen during coverFee.
data ErrCoverFee
  = ErrNotEnoughFunds ChangeError
  | ErrNoFuelUTxOFound
  | ErrUnknownInput {ErrCoverFee -> TxIn
input :: TxIn}
  | ErrScriptExecutionFailed {ErrCoverFee -> Text
redeemerPointer :: Text, ErrCoverFee -> Text
scriptFailure :: Text}
  | ErrTranslationError (ContextError LedgerEra)
  | ErrConwayUpgradeError (TxUpgradeError ConwayEra)
  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_ ::
  ( EraPlutusContext era
  , Ledger.EraCertState era
  , AlonzoEraTx era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraUTxO era
  , BabbageEraTxBody era
  ) =>
  PParams era ->
  SystemStart ->
  EpochInfo (Either Text) ->
  Map TxIn (Ledger.TxOut era) ->
  Map TxIn (Ledger.TxOut era) ->
  Tx era ->
  Either ErrCoverFee (Tx era)
coverFee_ :: forall era.
(EraPlutusContext era, EraCertState era, AlonzoEraTx era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era,
 BabbageEraTxBody era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Tx era
-> Either ErrCoverFee (Tx era)
coverFee_ PParams era
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo Map TxIn (TxOut era)
lookupUTxO Map TxIn (TxOut era)
walletUTxO Tx era
partialTx = do
  let body :: TxBody era
body = Tx era
partialTx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
  let wits :: TxWits era
wits = Tx era
partialTx Tx era -> Getting (TxWits era) (Tx era) (TxWits era) -> TxWits era
forall s a. s -> Getting a s a -> a
^. Getting (TxWits era) (Tx era) (TxWits era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL
  (TxIn
feeTxIn, TxOut era
feeTxOut) <- Map TxIn (TxOut era) -> Either ErrCoverFee (TxIn, TxOut era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
Map TxIn (TxOut era) -> Either ErrCoverFee (TxIn, TxOut era)
findUTxOToPayFees Map TxIn (TxOut era)
walletUTxO

  let newInputs :: Set TxIn
newInputs = TxBody era
body TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL 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
  [TxOut era]
resolvedInputs <- (TxIn -> Either ErrCoverFee (TxOut era))
-> [TxIn] -> Either ErrCoverFee [TxOut era]
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 era)
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 (TxOut era)
txOuts = TxBody era
body TxBody era
-> Getting
     (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut era)) (TxBody era) (StrictSeq (TxOut era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL StrictSeq (TxOut era)
-> (TxOut era -> TxOut era) -> StrictSeq (TxOut era)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams era
pparams

  -- Compute costs of redeemers
  let utxo :: Map TxIn (TxOut era)
utxo = Map TxIn (TxOut era)
lookupUTxO Map TxIn (TxOut era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOut era)
forall a. Semigroup a => a -> a -> a
<> Map TxIn (TxOut era)
walletUTxO
  Map (PlutusPurpose AsIx era) ExUnits
estimatedScriptCosts <- PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Tx era
-> Either ErrCoverFee (Map (PlutusPurpose AsIx era) ExUnits)
forall era.
(AlonzoEraTx era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Tx era
-> Either ErrCoverFee (Map (PlutusPurpose AsIx era) ExUnits)
estimateScriptsCost PParams era
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo Map TxIn (TxOut era)
utxo Tx era
partialTx
  let adjustedRedeemers :: Redeemers era
adjustedRedeemers =
        Set TxIn
-> Set TxIn
-> Map (PlutusPurpose AsIx era) ExUnits
-> Redeemers era
-> Redeemers era
forall era.
AlonzoEraScript era =>
Set TxIn
-> Set TxIn
-> Map (PlutusPurpose AsIx era) ExUnits
-> Redeemers era
-> Redeemers era
adjustRedeemers
          (TxBody era
body TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)
          Set TxIn
newInputs
          Map (PlutusPurpose AsIx era) ExUnits
estimatedScriptCosts
          (TxWits era
wits TxWits era
-> Getting (Redeemers era) (TxWits era) (Redeemers era)
-> Redeemers era
forall s a. s -> Getting a s a -> a
^. Getting (Redeemers era) (TxWits era) (Redeemers era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL)

  -- Compute script integrity hash from adjusted redeemers
  let referenceScripts :: Map ScriptHash (Script era)
referenceScripts = UTxO era -> Set TxIn -> Map ScriptHash (Script era)
forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn (TxOut era)
utxo) (TxBody era
body TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL)
      langs :: [LangDepView]
langs =
        [ PParams era -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams era
pparams Language
l
        | Script era
script <- Map ScriptHash (Script era) -> [Script era]
forall a. Map ScriptHash a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Map ScriptHash (Script era) -> [Script era])
-> Map ScriptHash (Script era) -> [Script era]
forall a b. (a -> b) -> a -> b
$ (TxWits era
wits TxWits era
-> Getting
     (Map ScriptHash (Script era))
     (TxWits era)
     (Map ScriptHash (Script era))
-> Map ScriptHash (Script era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map ScriptHash (Script era))
  (TxWits era)
  (Map ScriptHash (Script era))
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL) Map ScriptHash (Script era)
-> Map ScriptHash (Script era) -> Map ScriptHash (Script era)
forall a. Semigroup a => a -> a -> a
<> Map ScriptHash (Script era)
referenceScripts
        , 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 era -> Language
forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage (PlutusScript era -> Language)
-> Maybe (PlutusScript era) -> Maybe Language
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script era -> Maybe (PlutusScript era)
forall era.
AlonzoEraScript era =>
Script era -> Maybe (PlutusScript era)
toPlutusScript Script era
script
        ]
      scriptIntegrityHash :: StrictMaybe ScriptIntegrityHash
scriptIntegrityHash =
        Set LangDepView
-> Redeemers era -> TxDats era -> StrictMaybe ScriptIntegrityHash
forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era -> TxDats era -> StrictMaybe ScriptIntegrityHash
hashScriptIntegrity
          ([LangDepView] -> Set LangDepView
forall a. Ord a => [a] -> Set a
Set.fromList [LangDepView]
langs)
          Redeemers era
adjustedRedeemers
          (TxWits era
wits TxWits era
-> Getting (TxDats era) (TxWits era) (TxDats era) -> TxDats era
forall s a. s -> Getting a s a -> a
^. Getting (TxDats era) (TxWits era) (TxDats era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL)
  let
    unbalancedBody :: TxBody era
unbalancedBody =
      TxBody era
body
        TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set TxIn
newInputs
        TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxOut era)
txOuts
        TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
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
        TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody era -> Identity (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> TxBody era -> Identity (TxBody era))
-> StrictMaybe ScriptIntegrityHash -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe ScriptIntegrityHash
scriptIntegrityHash
    unbalancedTx :: Tx era
unbalancedTx =
      Tx era
partialTx
        Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> TxBody era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxBody era
unbalancedBody
        Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Redeemers era -> Identity (Redeemers era))
    -> TxWits era -> Identity (TxWits era))
-> (Redeemers era -> Identity (Redeemers era))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> Tx era -> Identity (Tx era))
-> Redeemers era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers era
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 = UTxO era -> PParams era -> Tx era -> Int -> Coin
forall era.
(EraUTxO era, EraCertState era) =>
UTxO era -> PParams era -> Tx era -> Int -> Coin
calcMinFeeTx (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn (TxOut era)
utxo) PParams era
pparams Tx era
costingTx Int
additionalWitnesses
      costingTx :: Tx era
costingTx =
        Tx era
unbalancedTx
          Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (TxOut era) -> TxOut era -> StrictSeq (TxOut era)
forall a. StrictSeq a -> a -> StrictSeq a
|> TxOut era
feeTxOut)
          Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> (Coin -> Identity Coin)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
10_000_000
      -- We add one additional witness for the fee input
      additionalWitnesses :: Int
additionalWitnesses = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set (KeyHash 'Witness) -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tx era
partialTx Tx era
-> Getting
     (Set (KeyHash 'Witness)) (Tx era) (Set (KeyHash 'Witness))
-> Set (KeyHash 'Witness)
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (Set (KeyHash 'Witness)) (TxBody era))
-> Tx era -> Const (Set (KeyHash 'Witness)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (Set (KeyHash 'Witness)) (TxBody era))
 -> Tx era -> Const (Set (KeyHash 'Witness)) (Tx era))
-> ((Set (KeyHash 'Witness)
     -> Const (Set (KeyHash 'Witness)) (Set (KeyHash 'Witness)))
    -> TxBody era -> Const (Set (KeyHash 'Witness)) (TxBody era))
-> Getting
     (Set (KeyHash 'Witness)) (Tx era) (Set (KeyHash 'Witness))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (KeyHash 'Witness)
 -> Const (Set (KeyHash 'Witness)) (Set (KeyHash 'Witness)))
-> TxBody era -> Const (Set (KeyHash 'Witness)) (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness))
Lens' (TxBody era) (Set (KeyHash 'Witness))
reqSignerHashesTxBodyL)

  -- Balance tx with a change output and computed fee
  TxOut era
change <-
    (ChangeError -> ErrCoverFee)
-> Either ChangeError (TxOut era) -> Either ErrCoverFee (TxOut era)
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 era) -> Either ErrCoverFee (TxOut era))
-> Either ChangeError (TxOut era) -> Either ErrCoverFee (TxOut era)
forall a b. (a -> b) -> a -> b
$
      TxOut era
-> [TxOut era]
-> [TxOut era]
-> Coin
-> Either ChangeError (TxOut era)
forall {era} {era} {era} {t :: * -> *} {t :: * -> *}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Foldable t, Foldable t, EraTxOut era, EraTxOut era,
 EraTxOut era) =>
TxOut era
-> t (TxOut era)
-> t (TxOut era)
-> Coin
-> Either ChangeError (TxOut era)
mkChange
        TxOut era
feeTxOut
        [TxOut era]
resolvedInputs
        (StrictSeq (TxOut era) -> [TxOut era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (TxOut era)
txOuts)
        Coin
fee
  Tx era -> Either ErrCoverFee (Tx era)
forall a. a -> Either ErrCoverFee a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> Either ErrCoverFee (Tx era))
-> Tx era -> Either ErrCoverFee (Tx era)
forall a b. (a -> b) -> a -> b
$
    Tx era
unbalancedTx
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StrictSeq (TxOut era) -> TxOut era -> StrictSeq (TxOut era)
forall a. StrictSeq a -> a -> StrictSeq a
|> TxOut era
change)
      Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> (Coin -> Identity Coin)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
 where
  findUTxOToPayFees :: Map TxIn (TxOut era) -> Either ErrCoverFee (TxIn, TxOut era)
findUTxOToPayFees Map TxIn (TxOut era)
utxo = case Map TxIn (TxOut era) -> Maybe (TxIn, TxOut era)
forall era.
EraTxOut era =>
Map TxIn (TxOut era) -> Maybe (TxIn, TxOut era)
findLargestUTxO Map TxIn (TxOut era)
utxo of
    Maybe (TxIn, TxOut era)
Nothing ->
      ErrCoverFee -> Either ErrCoverFee (TxIn, TxOut era)
forall a b. a -> Either a b
Left ErrCoverFee
ErrNoFuelUTxOFound
    Just (TxIn
i, TxOut era
o) ->
      (TxIn, TxOut era) -> Either ErrCoverFee (TxIn, TxOut era)
forall a b. b -> Either a b
Right (TxIn
i, TxOut era
o)

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

  mkChange :: TxOut era
-> t (TxOut era)
-> t (TxOut era)
-> Coin
-> Either ChangeError (TxOut era)
mkChange TxOut era
feeTxOut t (TxOut era)
resolvedInputs t (TxOut era)
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 era)
forall a b. a -> Either a b
Left (ChangeError -> Either ChangeError (TxOut era))
-> ChangeError -> Either ChangeError (TxOut era)
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 era -> Either ChangeError (TxOut era)
forall a b. b -> Either a b
Right (TxOut era -> Either ChangeError (TxOut era))
-> TxOut era -> Either ChangeError (TxOut era)
forall a b. (a -> b) -> a -> b
$ TxOut era
feeTxOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL ((Coin -> Identity Coin) -> TxOut era -> Identity (TxOut era))
-> Coin -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
changeOut
   where
    totalOut :: Coin
totalOut = (TxOut era -> Coin) -> t (TxOut era) -> Coin
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Getting Coin (TxOut era) Coin -> TxOut era -> Coin
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) t (TxOut era)
otherOutputs Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
fee
    totalIn :: Coin
totalIn = (TxOut era -> Coin) -> t (TxOut era) -> Coin
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Getting Coin (TxOut era) Coin -> TxOut era -> Coin
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) t (TxOut era)
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

  adjustRedeemers ::
    forall era.
    AlonzoEraScript era =>
    Set TxIn ->
    Set TxIn ->
    Map (PlutusPurpose AsIx era) ExUnits ->
    Redeemers era ->
    Redeemers era
  adjustRedeemers :: forall era.
AlonzoEraScript era =>
Set TxIn
-> Set TxIn
-> Map (PlutusPurpose AsIx era) ExUnits
-> Redeemers era
-> Redeemers era
adjustRedeemers Set TxIn
initialInputs Set TxIn
finalInputs Map (PlutusPurpose AsIx era) ExUnits
estimatedCosts (Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
initialRedeemers) =
    Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Redeemers era
forall a b. (a -> b) -> a -> b
$ [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PlutusPurpose AsIx era, (Data era, ExUnits))]
 -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall a b. (a -> b) -> a -> b
$ ((PlutusPurpose AsIx era, (Data era, ExUnits))
 -> (PlutusPurpose AsIx era, (Data era, ExUnits)))
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall a b. (a -> b) -> [a] -> [b]
map (PlutusPurpose AsIx era, (Data era, ExUnits))
-> (PlutusPurpose AsIx era, (Data era, ExUnits))
adjustOne ([(PlutusPurpose AsIx era, (Data era, ExUnits))]
 -> [(PlutusPurpose AsIx era, (Data era, ExUnits))])
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall a b. (a -> b) -> a -> b
$ Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList Map (PlutusPurpose AsIx era) (Data era, 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 :: (PlutusPurpose AsIx era, (Data era, ExUnits)) -> (PlutusPurpose AsIx era, (Data era, ExUnits))
    adjustOne :: (PlutusPurpose AsIx era, (Data era, ExUnits))
-> (PlutusPurpose AsIx era, (Data era, ExUnits))
adjustOne (PlutusPurpose AsIx era
ptr, (Data era
d, ExUnits
_exUnits)) =
      case PlutusPurpose AsIx era
ptr of
        SpendingPurpose AsIx Word32 TxIn
idx
          | Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (AsIx Word32 TxIn -> Word32
forall ix it. AsIx ix it -> ix
unAsIx AsIx Word32 TxIn
idx) Int -> [Int] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Int]
differences ->
              (AsIx Word32 TxIn -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
SpendingPurpose (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
AsIx (AsIx Word32 TxIn -> Word32
forall ix it. AsIx ix it -> ix
unAsIx AsIx Word32 TxIn
idx Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1)), (Data era
d, PlutusPurpose AsIx era -> ExUnits
executionUnitsFor PlutusPurpose AsIx era
ptr))
        PlutusPurpose AsIx era
_ ->
          (PlutusPurpose AsIx era
ptr, (Data era
d, PlutusPurpose AsIx era -> ExUnits
executionUnitsFor PlutusPurpose AsIx era
ptr))

    executionUnitsFor :: PlutusPurpose AsIx era -> ExUnits
    executionUnitsFor :: PlutusPurpose AsIx era -> ExUnits
executionUnitsFor PlutusPurpose AsIx era
ptr =
      let ExUnits Nat
maxMem Nat
maxCpu = PParams era
pparams PParams era -> Getting ExUnits (PParams era) ExUnits -> ExUnits
forall s a. s -> Getting a s a -> a
^. Getting ExUnits (PParams era) ExUnits
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
          ExUnits Nat
totalMem Nat
totalCpu = (ExUnits -> ExUnits)
-> Map (PlutusPurpose AsIx era) ExUnits -> ExUnits
forall m a.
Monoid m =>
(a -> m) -> Map (PlutusPurpose AsIx era) 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 AsIx era) ExUnits
estimatedCosts
          ExUnits Nat
approxMem Nat
approxCpu = Map (PlutusPurpose AsIx era) ExUnits
estimatedCosts Map (PlutusPurpose AsIx era) ExUnits
-> PlutusPurpose AsIx era -> ExUnits
forall k a. Ord k => Map k a -> k -> a
! PlutusPurpose AsIx era
ptr
       in Nat -> Nat -> ExUnits
ExUnits
            (Ratio Nat -> Nat
forall b. Integral b => Ratio Nat -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Nat
maxMem Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
* Nat
approxMem Nat -> Nat -> Ratio Nat
forall a. Integral a => a -> a -> Ratio a
% Nat
totalMem))
            (Ratio Nat -> Nat
forall b. Integral b => Ratio Nat -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Nat
maxCpu Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
* Nat
approxCpu Nat -> Nat -> Ratio Nat
forall a. Integral a => a -> a -> Ratio a
% Nat
totalCpu))

findLargestUTxO :: Ledger.EraTxOut era => Map TxIn (Ledger.TxOut era) -> Maybe (TxIn, Ledger.TxOut era)
findLargestUTxO :: forall era.
EraTxOut era =>
Map TxIn (TxOut era) -> Maybe (TxIn, TxOut era)
findLargestUTxO Map TxIn (TxOut era)
utxo =
  [(TxIn, TxOut era)] -> Maybe (TxIn, TxOut era)
forall a. [a] -> Maybe a
listToMaybe
    ([(TxIn, TxOut era)] -> Maybe (TxIn, TxOut era))
-> ([(TxIn, TxOut era)] -> [(TxIn, TxOut era)])
-> [(TxIn, TxOut era)]
-> Maybe (TxIn, TxOut era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxIn, TxOut era) -> Down Coin)
-> [(TxIn, TxOut era)] -> [(TxIn, TxOut 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 era) -> Coin) -> (TxIn, TxOut era) -> Down Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Coin (TxOut era) Coin -> TxOut era -> Coin
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL (TxOut era -> Coin)
-> ((TxIn, TxOut era) -> TxOut era) -> (TxIn, TxOut era) -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn, TxOut era) -> TxOut era
forall a b. (a, b) -> b
snd)
    ([(TxIn, TxOut era)] -> Maybe (TxIn, TxOut era))
-> [(TxIn, TxOut era)] -> Maybe (TxIn, TxOut era)
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut era) -> [(TxIn, TxOut era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut era)
utxo

-- | 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 ::
  forall era.
  (AlonzoEraTx era, EraPlutusContext era, ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
  -- | Protocol parameters
  Core.PParams era ->
  -- | 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 (Ledger.TxOut era) ->
  -- | The pre-constructed transaction
  Tx era ->
  Either ErrCoverFee (Map (PlutusPurpose AsIx era) ExUnits)
estimateScriptsCost :: forall era.
(AlonzoEraTx era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, EraUTxO era) =>
PParams era
-> SystemStart
-> EpochInfo (Either Text)
-> Map TxIn (TxOut era)
-> Tx era
-> Either ErrCoverFee (Map (PlutusPurpose AsIx era) ExUnits)
estimateScriptsCost PParams era
pparams SystemStart
systemStart EpochInfo (Either Text)
epochInfo Map TxIn (TxOut era)
utxo Tx era
tx = do
  (PlutusPurpose AsIx era
 -> Either (TransactionScriptFailure era) ExUnits
 -> Either ErrCoverFee ExUnits)
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
-> Either ErrCoverFee (Map (PlutusPurpose AsIx era) ExUnits)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey PlutusPurpose AsIx era
-> Either (TransactionScriptFailure era) ExUnits
-> Either ErrCoverFee ExUnits
forall {a} {a} {b}.
(Show a, Show a) =>
a -> Either a b -> Either ErrCoverFee b
convertResult Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
result
 where
  result ::
    Map
      (PlutusPurpose AsIx era)
      (Either (TransactionScriptFailure era) ExUnits)
  result :: Map
  (PlutusPurpose AsIx era)
  (Either (TransactionScriptFailure era) ExUnits)
result =
    PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Map
     (PlutusPurpose AsIx era)
     (Either (TransactionScriptFailure era) ExUnits)
forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits
      PParams era
pparams
      Tx era
tx
      (Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
Ledger.UTxO Map TxIn (TxOut era)
utxo)
      EpochInfo (Either Text)
epochInfo
      SystemStart
systemStart
  convertResult :: a -> Either a b -> Either ErrCoverFee b
convertResult a
ptr = \case
    Right b
exUnits -> b -> Either ErrCoverFee b
forall a b. b -> Either a b
Right b
exUnits
    Left a
failure ->
      ErrCoverFee -> Either ErrCoverFee b
forall a b. a -> Either a b
Left (ErrCoverFee -> Either ErrCoverFee b)
-> ErrCoverFee -> Either ErrCoverFee b
forall a b. (a -> b) -> a -> b
$
        ErrScriptExecutionFailed
          { $sel:redeemerPointer:ErrNotEnoughFunds :: Text
redeemerPointer = a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
ptr
          , $sel:scriptFailure:ErrNotEnoughFunds :: Text
scriptFailure = a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
failure
          }

--
-- 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

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