{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}

-- | Fee calculation
--
module Cardano.Api.Fees (
    -- * Transaction fees
    transactionFee,
    estimateTransactionFee,
    evaluateTransactionFee,
    estimateTransactionKeyWitnessCount,

    -- * Script execution units
    evaluateTransactionExecutionUnits,
    ScriptExecutionError(..),
    TransactionValidityError(..),

    -- * Transaction balance
    evaluateTransactionBalance,

    -- * Automated transaction building
    makeTransactionBodyAutoBalance,
    BalancedTxBody(..),
    TxBodyErrorAutoBalance(..),

    -- * Minimum UTxO calculation
    calculateMinimumUTxO,
    MinimumUTxOError(..),

    -- * Internal helpers
    mapTxScriptWitnesses,
    toLedgerEpochInfo,
  ) where

import           Prelude

import qualified Data.Array as Array
import           Data.Bifunctor (bimap, first)
import qualified Data.ByteString as BS
import           Data.ByteString.Short (ShortByteString)
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (catMaybes, fromMaybe, maybeToList)
import           Data.Ratio
import           Data.Sequence.Strict (StrictSeq (..))
import           Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import           GHC.Records (HasField (..))
import           Numeric.Natural

import           Control.Monad.Trans.Except
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.String as PP

import qualified Cardano.Binary as CBOR
import qualified Cardano.Ledger.BaseTypes as Ledger
import           Cardano.Slotting.EpochInfo (EpochInfo, hoistEpochInfo)

import qualified Cardano.Chain.Common as Byron

import qualified Cardano.Ledger.Coin as Ledger
import qualified Cardano.Ledger.Core as Ledger
import qualified Cardano.Ledger.Crypto as Ledger
import qualified Cardano.Ledger.Era as Ledger.Era (Crypto)
import qualified Cardano.Ledger.Hashes as Ledger
import qualified Cardano.Ledger.Keys as Ledger
import qualified Cardano.Ledger.Shelley.API as Ledger (CLI, DCert, TxIn, Wdrl)
import qualified Cardano.Ledger.Shelley.API.Wallet as Ledger (evaluateTransactionBalance,
                   evaluateTransactionFee)

import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley
import           Cardano.Ledger.Shelley.PParams (PParams' (..))

import qualified Cardano.Ledger.Mary.Value as Mary

import qualified Cardano.Ledger.Alonzo as Alonzo
import qualified Cardano.Ledger.Alonzo.Language as Alonzo
import           Cardano.Ledger.Alonzo.PParams (PParams' (..))
import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
import qualified Cardano.Ledger.Alonzo.Tools as Alonzo
import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo
import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo

import qualified Plutus.V1.Ledger.Api as Plutus

import qualified Cardano.Ledger.Babbage as Babbage
import           Cardano.Ledger.Babbage.PParams (PParams' (..))

import qualified Ouroboros.Consensus.HardFork.History as Consensus

import           Cardano.Api.Address
import           Cardano.Api.Certificate
import           Cardano.Api.Eras
import           Cardano.Api.Error
import           Cardano.Api.Modes
import           Cardano.Api.NetworkId
import           Cardano.Api.ProtocolParameters
import           Cardano.Api.Query
import           Cardano.Api.Script
import           Cardano.Api.Tx
import           Cardano.Api.TxBody
import           Cardano.Api.Value

{- HLINT ignore "Redundant return" -}

-- ----------------------------------------------------------------------------
-- Transaction fees
--

-- | For a concrete fully-constructed transaction, determine the minimum fee
-- that it needs to pay.
--
-- This function is simple, but if you are doing input selection then you
-- probably want to consider estimateTransactionFee.
--
transactionFee :: forall era.
                  IsShelleyBasedEra era
               => Natural -- ^ The fixed tx fee
               -> Natural -- ^ The tx fee per byte
               -> Tx era
               -> Lovelace
transactionFee :: Natural -> Natural -> Tx era -> Lovelace
transactionFee Natural
txFeeFixed Natural
txFeePerByte Tx era
tx =
  let a :: Integer
a = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
txFeePerByte
      b :: Integer
b = Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
txFeeFixed
  in case Tx era
tx of
       ShelleyTx ShelleyBasedEra era
_ Tx (ShelleyLedgerEra era)
tx' -> let x :: Integer
x = ShelleyBasedEra era
-> (HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer =>
    Integer)
-> Integer
forall ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> (HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a)
-> a
obtainHasField ShelleyBasedEra era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra ((HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => Integer)
 -> Integer)
-> (HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer =>
    Integer)
-> Integer
forall a b. (a -> b) -> a -> b
$ Tx (ShelleyLedgerEra era) -> Integer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"txsize" Tx (ShelleyLedgerEra era)
tx'
                          in Integer -> Lovelace
Lovelace (Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
b)
       --TODO: This can be made to work for Byron txs too. Do that: fill in this case
       -- and remove the IsShelleyBasedEra constraint.
       ByronTx ATxAux ByteString
_ -> case ShelleyBasedEra ByronEra
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra :: ShelleyBasedEra ByronEra of {}
 where
  obtainHasField
    :: ShelleyLedgerEra era ~ ledgerera
    => ShelleyBasedEra era
    -> ( HasField "txsize" (Ledger.Tx (ShelleyLedgerEra era)) Integer
        => a)
    -> a
  obtainHasField :: ShelleyBasedEra era
-> (HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a)
-> a
obtainHasField ShelleyBasedEra era
ShelleyBasedEraShelley HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f
  obtainHasField ShelleyBasedEra era
ShelleyBasedEraAllegra HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f
  obtainHasField ShelleyBasedEra era
ShelleyBasedEraMary    HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f
  obtainHasField ShelleyBasedEra era
ShelleyBasedEraAlonzo  HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f
  obtainHasField ShelleyBasedEra era
ShelleyBasedEraBabbage HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (ShelleyLedgerEra era)) Integer => a
f

{-# DEPRECATED transactionFee "Use 'evaluateTransactionFee' instead" #-}


--TODO: in the Byron case the per-byte is non-integral, would need different
-- parameters. e.g. a new data type for fee params, Byron vs Shelley

-- | This can estimate what the transaction fee will be, based on a starting
-- base transaction, plus the numbers of the additional components of the
-- transaction that may be added.
--
-- So for example with wallet coin selection, the base transaction should
-- contain all the things not subject to coin selection (such as script inputs,
-- metadata, withdrawals, certs etc)
--
estimateTransactionFee :: forall era.
                          IsShelleyBasedEra era
                       => NetworkId
                       -> Natural -- ^ The fixed tx fee
                       -> Natural -- ^ The tx fee per byte
                       -> Tx era
                       -> Int -- ^ The number of extra UTxO transaction inputs
                       -> Int -- ^ The number of extra transaction outputs
                       -> Int -- ^ The number of extra Shelley key witnesses
                       -> Int -- ^ The number of extra Byron key witnesses
                       -> Lovelace
estimateTransactionFee :: NetworkId
-> Natural
-> Natural
-> Tx era
-> Int
-> Int
-> Int
-> Int
-> Lovelace
estimateTransactionFee NetworkId
nw Natural
txFeeFixed Natural
txFeePerByte (ShelleyTx ShelleyBasedEra era
era Tx (ShelleyLedgerEra era)
tx) =
    let Lovelace Integer
baseFee = Natural -> Natural -> Tx era -> Lovelace
forall era.
IsShelleyBasedEra era =>
Natural -> Natural -> Tx era -> Lovelace
transactionFee Natural
txFeeFixed Natural
txFeePerByte (ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
forall era.
ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
ShelleyTx ShelleyBasedEra era
era Tx (ShelleyLedgerEra era)
tx)
     in \Int
nInputs Int
nOutputs Int
nShelleyKeyWitnesses Int
nByronKeyWitnesses ->

        --TODO: this is fragile. Move something like this to the ledger and
        -- make it robust, based on the txsize calculation.
        let extraBytes :: Int
            extraBytes :: Int
extraBytes = Int
nInputs               Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeInput
                       Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nOutputs              Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeOutput
                       Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nByronKeyWitnesses    Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeByronKeyWitnesses
                       Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nShelleyKeyWitnesses  Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeShelleyKeyWitnesses

         in Integer -> Lovelace
Lovelace (Integer
baseFee Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
txFeePerByte Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
extraBytes)
  where
    sizeInput :: Int
sizeInput               = Int
smallArray Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
uint Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hashObj
    sizeOutput :: Int
sizeOutput              = Int
smallArray Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
uint Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
address
    sizeByronKeyWitnesses :: Int
sizeByronKeyWitnesses   = Int
smallArray Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
keyObj Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sigObj Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ccodeObj Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
attrsObj
    sizeShelleyKeyWitnesses :: Int
sizeShelleyKeyWitnesses = Int
smallArray Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
keyObj Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sigObj

    smallArray :: Int
smallArray  = Int
1
    uint :: Int
uint        = Int
5

    hashObj :: Int
hashObj     = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hashLen
    hashLen :: Int
hashLen     = Int
32

    keyObj :: Int
keyObj      = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
keyLen
    keyLen :: Int
keyLen      = Int
32

    sigObj :: Int
sigObj      = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sigLen
    sigLen :: Int
sigLen      = Int
64

    ccodeObj :: Int
ccodeObj    = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ccodeLen
    ccodeLen :: Int
ccodeLen    = Int
32

    address :: Int
address     = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
addrHeader Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
addrHashLen
    addrHeader :: Int
addrHeader  = Int
1
    addrHashLen :: Int
addrHashLen = Int
28

    attrsObj :: Int
attrsObj    = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
attributes
    attributes :: ByteString
attributes  = Attributes AddrAttributes -> ByteString
forall a. ToCBOR a => a -> ByteString
CBOR.serialize' (Attributes AddrAttributes -> ByteString)
-> Attributes AddrAttributes -> ByteString
forall a b. (a -> b) -> a -> b
$
                    AddrAttributes -> Attributes AddrAttributes
forall h. h -> Attributes h
Byron.mkAttributes AddrAttributes :: Maybe HDAddressPayload -> NetworkMagic -> AddrAttributes
Byron.AddrAttributes {
                      aaVKDerivationPath :: Maybe HDAddressPayload
Byron.aaVKDerivationPath = Maybe HDAddressPayload
forall a. Maybe a
Nothing,
                      aaNetworkMagic :: NetworkMagic
Byron.aaNetworkMagic     = NetworkId -> NetworkMagic
toByronNetworkMagic NetworkId
nw
                    }

--TODO: This can be made to work for Byron txs too. Do that: fill in this case
-- and remove the IsShelleyBasedEra constraint.
estimateTransactionFee NetworkId
_ Natural
_ Natural
_ (ByronTx ATxAux ByteString
_) =
    case ShelleyBasedEra era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra :: ShelleyBasedEra era of {}

--TODO: also deprecate estimateTransactionFee:
--{-# DEPRECATED estimateTransactionFee "Use 'evaluateTransactionFee' instead" #-}


-- | Compute the transaction fee for a proposed transaction, with the
-- assumption that there will be the given number of key witnesses (i.e.
-- signatures).
--
-- TODO: we need separate args for Shelley vs Byron key sigs
--
evaluateTransactionFee :: forall era.
                          IsShelleyBasedEra era
                       => ProtocolParameters
                       -> TxBody era
                       -> Word  -- ^ The number of Shelley key witnesses
                       -> Word  -- ^ The number of Byron key witnesses
                       -> Lovelace
evaluateTransactionFee :: ProtocolParameters -> TxBody era -> Word -> Word -> Lovelace
evaluateTransactionFee ProtocolParameters
_ TxBody era
_ Word
_ Word
byronwitcount | Word
byronwitcount Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
0 =
  [Char] -> Lovelace
forall a. HasCallStack => [Char] -> a
error [Char]
"evaluateTransactionFee: TODO support Byron key witnesses"

evaluateTransactionFee ProtocolParameters
pparams TxBody era
txbody Word
keywitcount Word
_byronwitcount =
    case [KeyWitness era] -> TxBody era -> Tx era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody era
txbody of
      ByronTx{} -> case ShelleyBasedEra era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra :: ShelleyBasedEra era of {}
      --TODO: we could actually support Byron here, it'd be different but simpler

      ShelleyTx ShelleyBasedEra era
era Tx (ShelleyLedgerEra era)
tx -> ShelleyBasedEra era
-> (CLI (ShelleyLedgerEra era) => Lovelace) -> Lovelace
forall ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> (CLI ledgerera => a) -> a
withLedgerConstraints ShelleyBasedEra era
era (ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Lovelace
forall ledgerera.
(ShelleyLedgerEra era ~ ledgerera, CLI ledgerera) =>
ShelleyBasedEra era -> Tx ledgerera -> Lovelace
evalShelleyBasedEra ShelleyBasedEra era
era Tx (ShelleyLedgerEra era)
tx)
  where
    evalShelleyBasedEra :: forall ledgerera.
                           ShelleyLedgerEra era ~ ledgerera
                        => Ledger.CLI ledgerera
                        => ShelleyBasedEra era
                        -> Ledger.Tx ledgerera
                        -> Lovelace
    evalShelleyBasedEra :: ShelleyBasedEra era -> Tx ledgerera -> Lovelace
evalShelleyBasedEra ShelleyBasedEra era
era Tx ledgerera
tx =
      Coin -> Lovelace
fromShelleyLovelace (Coin -> Lovelace) -> Coin -> Lovelace
forall a b. (a -> b) -> a -> b
$
        PParams ledgerera -> Tx ledgerera -> Word -> Coin
forall era. CLI era => PParams era -> Tx era -> Word -> Coin
Ledger.evaluateTransactionFee
          (ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
toLedgerPParams ShelleyBasedEra era
era ProtocolParameters
pparams)
          Tx ledgerera
tx
          Word
keywitcount

    -- Conjure up all the necessary class instances and evidence
    withLedgerConstraints
      :: ShelleyLedgerEra era ~ ledgerera
      => ShelleyBasedEra era
      -> (   Ledger.CLI ledgerera
          => a)
      -> a
    withLedgerConstraints :: ShelleyBasedEra era -> (CLI ledgerera => a) -> a
withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraShelley CLI ledgerera => a
f = a
CLI ledgerera => a
f
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraAllegra CLI ledgerera => a
f = a
CLI ledgerera => a
f
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraMary    CLI ledgerera => a
f = a
CLI ledgerera => a
f
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraAlonzo  CLI ledgerera => a
f = a
CLI ledgerera => a
f
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraBabbage CLI ledgerera => a
f = a
CLI ledgerera => a
f

-- | Give an approximate count of the number of key witnesses (i.e. signatures)
-- a transaction will need.
--
-- This is an estimate not a precise count in that it can over-estimate: it
-- makes conservative assumptions such as all inputs are from distinct
-- addresses, but in principle multiple inputs can use the same address and we
-- only need a witness per address.
--
-- Similarly there can be overlap between the regular and collateral inputs,
-- but we conservatively assume they are distinct.
--
-- TODO: it is worth us considering a more precise count that relies on the
-- UTxO to resolve which inputs are for distinct addresses, and also to count
-- the number of Shelley vs Byron style witnesses.
--
estimateTransactionKeyWitnessCount :: TxBodyContent BuildTx era -> Word
estimateTransactionKeyWitnessCount :: TxBodyContent BuildTx era -> Word
estimateTransactionKeyWitnessCount TxBodyContent {
                                     TxIns BuildTx era
txIns :: forall build era. TxBodyContent build era -> TxIns build era
txIns :: TxIns BuildTx era
txIns,
                                     TxInsCollateral era
txInsCollateral :: forall build era. TxBodyContent build era -> TxInsCollateral era
txInsCollateral :: TxInsCollateral era
txInsCollateral,
                                     TxExtraKeyWitnesses era
txExtraKeyWits :: forall build era.
TxBodyContent build era -> TxExtraKeyWitnesses era
txExtraKeyWits :: TxExtraKeyWitnesses era
txExtraKeyWits,
                                     TxWithdrawals BuildTx era
txWithdrawals :: forall build era.
TxBodyContent build era -> TxWithdrawals build era
txWithdrawals :: TxWithdrawals BuildTx era
txWithdrawals,
                                     TxCertificates BuildTx era
txCertificates :: forall build era.
TxBodyContent build era -> TxCertificates build era
txCertificates :: TxCertificates BuildTx era
txCertificates,
                                     TxUpdateProposal era
txUpdateProposal :: forall build era. TxBodyContent build era -> TxUpdateProposal era
txUpdateProposal :: TxUpdateProposal era
txUpdateProposal
                                   } =
  Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$
    [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ () | (TxIn
_txin, BuildTxWith KeyWitness{}) <- TxIns BuildTx era
txIns ]

  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case TxInsCollateral era
txInsCollateral of
      TxInsCollateral CollateralSupportedInEra era
_ [TxIn]
txins
        -> [TxIn] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxIn]
txins
      TxInsCollateral era
_ -> Int
0

  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case TxExtraKeyWitnesses era
txExtraKeyWits of
      TxExtraKeyWitnesses TxExtraKeyWitnessesSupportedInEra era
_ [Hash PaymentKey]
khs
        -> [Hash PaymentKey] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hash PaymentKey]
khs
      TxExtraKeyWitnesses era
_ -> Int
0

  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case TxWithdrawals BuildTx era
txWithdrawals of
      TxWithdrawals WithdrawalsSupportedInEra era
_ [(StakeAddress, Lovelace,
  BuildTxWith BuildTx (Witness WitCtxStake era))]
withdrawals
        -> [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ () | (StakeAddress
_, Lovelace
_, BuildTxWith KeyWitness{}) <- [(StakeAddress, Lovelace,
  BuildTxWith BuildTx (Witness WitCtxStake era))]
withdrawals ]
      TxWithdrawals BuildTx era
_ -> Int
0

  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case TxCertificates BuildTx era
txCertificates of
      TxCertificates CertificatesSupportedInEra era
_ [Certificate]
_ (BuildTxWith Map StakeCredential (Witness WitCtxStake era)
witnesses)
        -> [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ () | KeyWitness{} <- Map StakeCredential (Witness WitCtxStake era)
-> [Witness WitCtxStake era]
forall k a. Map k a -> [a]
Map.elems Map StakeCredential (Witness WitCtxStake era)
witnesses ]
      TxCertificates BuildTx era
_ -> Int
0

  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case TxUpdateProposal era
txUpdateProposal of
      TxUpdateProposal UpdateProposalSupportedInEra era
_ (UpdateProposal Map (Hash GenesisKey) ProtocolParametersUpdate
updatePerGenesisKey EpochNo
_)
        -> Map (Hash GenesisKey) ProtocolParametersUpdate -> Int
forall k a. Map k a -> Int
Map.size Map (Hash GenesisKey) ProtocolParametersUpdate
updatePerGenesisKey
      TxUpdateProposal era
_ -> Int
0


-- ----------------------------------------------------------------------------
-- Script execution units
--

type PlutusScriptBytes = ShortByteString

type ResolvablePointers =
       Map
         Alonzo.RdmrPtr
         ( Alonzo.ScriptPurpose Ledger.StandardCrypto
         , Maybe (PlutusScriptBytes, Alonzo.Language)
         , Ledger.ScriptHash Ledger.StandardCrypto
         )

-- | The different possible reasons that executing a script can fail,
-- as reported by 'evaluateTransactionExecutionUnits'.
--
-- The first three of these are about failures before we even get to execute
-- the script, and two are the result of execution.
--
data ScriptExecutionError =

       -- | The script depends on a 'TxIn' that has not been provided in the
       -- given 'UTxO' subset. The given 'UTxO' must cover all the inputs
       -- the transaction references.
       ScriptErrorMissingTxIn TxIn

       -- | The 'TxIn' the script is spending does not have a 'ScriptDatum'.
       -- All inputs guarded by Plutus scripts need to have been created with
       -- a 'ScriptDatum'.
     | ScriptErrorTxInWithoutDatum TxIn

       -- | The 'ScriptDatum' provided does not match the one from the 'UTxO'.
       -- This means the wrong 'ScriptDatum' value has been provided.
       --
     | ScriptErrorWrongDatum (Hash ScriptData)

       -- | The script evaluation failed. This usually means it evaluated to an
       -- error value. This is not a case of running out of execution units
       -- (which is not possible for 'evaluateTransactionExecutionUnits' since
       -- the whole point of it is to discover how many execution units are
       -- needed).
       --
     | ScriptErrorEvaluationFailed Plutus.EvaluationError [Text.Text]

       -- | The execution units overflowed a 64bit word. Congratulations if
       -- you encounter this error. With the current style of cost model this
       -- would need a script to run for over 7 months, which is somewhat more
       -- than the expected maximum of a few milliseconds.
       --
     | ScriptErrorExecutionUnitsOverflow

       -- | An attempt was made to spend a key witnessed tx input
       -- with a script witness.
     | ScriptErrorNotPlutusWitnessedTxIn ScriptWitnessIndex ScriptHash

       -- | The redeemer pointer points to a script hash that does not exist
       -- in the transaction nor in the UTxO as a reference script"
     | ScriptErrorRedeemerPointsToUnknownScriptHash ScriptWitnessIndex

       -- | A redeemer pointer points to a script that does not exist.
     | ScriptErrorMissingScript
         Alonzo.RdmrPtr -- The invalid pointer
         ResolvablePointers -- A mapping a pointers that are possible to resolve

       -- | A cost model was missing for a language which was used.
     | ScriptErrorMissingCostModel Alonzo.Language
  deriving Int -> ScriptExecutionError -> ShowS
[ScriptExecutionError] -> ShowS
ScriptExecutionError -> [Char]
(Int -> ScriptExecutionError -> ShowS)
-> (ScriptExecutionError -> [Char])
-> ([ScriptExecutionError] -> ShowS)
-> Show ScriptExecutionError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ScriptExecutionError] -> ShowS
$cshowList :: [ScriptExecutionError] -> ShowS
show :: ScriptExecutionError -> [Char]
$cshow :: ScriptExecutionError -> [Char]
showsPrec :: Int -> ScriptExecutionError -> ShowS
$cshowsPrec :: Int -> ScriptExecutionError -> ShowS
Show

instance Error ScriptExecutionError where
  displayError :: ScriptExecutionError -> [Char]
displayError (ScriptErrorMissingTxIn TxIn
txin) =
      [Char]
"The supplied UTxO is missing the txin " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (TxIn -> Text
renderTxIn TxIn
txin)

  displayError (ScriptErrorTxInWithoutDatum TxIn
txin) =
      [Char]
"The Plutus script witness for the txin does not have a script datum "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"(according to the UTxO). The txin in question is "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (TxIn -> Text
renderTxIn TxIn
txin)

  displayError (ScriptErrorWrongDatum Hash ScriptData
dh) =
      [Char]
"The Plutus script witness has the wrong datum (according to the UTxO). "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"The expected datum value has hash " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Hash ScriptData -> [Char]
forall a. Show a => a -> [Char]
show Hash ScriptData
dh

  displayError (ScriptErrorEvaluationFailed EvaluationError
evalErr [Text]
logs) =
      [Char]
"The Plutus script evaluation failed: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ EvaluationError -> [Char]
forall p. Pretty p => p -> [Char]
pp EvaluationError
evalErr [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
      [Char]
"\nScript debugging logs: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat ((Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
t -> Text -> [Char]
Text.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
t Text -> Text -> Text
`Text.append` Text
"\n") [Text]
logs)
    where
      pp :: PP.Pretty p => p -> String
      pp :: p -> [Char]
pp = SimpleDocStream Any -> [Char]
forall ann. SimpleDocStream ann -> [Char]
PP.renderString
         (SimpleDocStream Any -> [Char])
-> (p -> SimpleDocStream Any) -> p -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
PP.defaultLayoutOptions
         (Doc Any -> SimpleDocStream Any)
-> (p -> Doc Any) -> p -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Doc Any
forall a ann. Pretty a => a -> Doc ann
PP.pretty

  displayError ScriptExecutionError
ScriptErrorExecutionUnitsOverflow =
      [Char]
"The execution units required by this Plutus script overflows a 64bit "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"word. In a properly configured chain this should be practically "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"impossible. So this probably indicates a chain configuration problem, "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"perhaps with the values in the cost model."

  displayError (ScriptErrorNotPlutusWitnessedTxIn ScriptWitnessIndex
scriptWitness ScriptHash
scriptHash) =
      ScriptWitnessIndex -> [Char]
renderScriptWitnessIndex ScriptWitnessIndex
scriptWitness [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not a Plutus script \
      \witnessed tx input and cannot be spent using a Plutus script witness."
      [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"The script hash is " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ScriptHash -> [Char]
forall a. Show a => a -> [Char]
show ScriptHash
scriptHash [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"."

  displayError (ScriptErrorRedeemerPointsToUnknownScriptHash ScriptWitnessIndex
scriptWitness) =
      ScriptWitnessIndex -> [Char]
renderScriptWitnessIndex ScriptWitnessIndex
scriptWitness [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" points to a script hash \
      \that is not known."

  displayError (ScriptErrorMissingScript RdmrPtr
rdmrPtr ResolvablePointers
resolveable) =
     [Char]
"The redeemer pointer: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> RdmrPtr -> [Char]
forall a. Show a => a -> [Char]
show RdmrPtr
rdmrPtr [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" points to a Plutus \
     \script that does not exist.\n" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
     [Char]
"The pointers that can be resolved are: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ResolvablePointers -> [Char]
forall a. Show a => a -> [Char]
show ResolvablePointers
resolveable

  displayError (ScriptErrorMissingCostModel Language
language) =
      [Char]
"No cost model was found for language " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Language -> [Char]
forall a. Show a => a -> [Char]
show Language
language

data TransactionValidityError =
    -- | The transaction validity interval is too far into the future.
    --
    -- Transactions with Plutus scripts need to have a validity interval that is
    -- not so far in the future that we cannot reliably determine the UTC time
    -- corresponding to the validity interval expressed in slot numbers.
    --
    -- This is because the Plutus scripts get given the transaction validity
    -- interval in UTC time, so that they are not sensitive to slot lengths.
    --
    -- If either end of the validity interval is beyond the so called \"time
    -- horizon\" then the consensus algorithm is not able to reliably determine
    -- the relationship between slots and time. This is this situation in which
    -- this error is reported. For the Cardano mainnet the time horizon is 36
    -- hours beyond the current time. This effectively means we cannot submit
    -- check or submit transactions that use Plutus scripts that have the end
    -- of their validity interval more than 36 hours into the future.
    TransactionValidityIntervalError Consensus.PastHorizonException

  | TransactionValidityTranslationError (Alonzo.TranslationError Ledger.StandardCrypto)

  | TransactionValidityCostModelError (Map AnyPlutusScriptVersion CostModel) String

deriving instance Show TransactionValidityError

instance Error TransactionValidityError where
  displayError :: TransactionValidityError -> [Char]
displayError (TransactionValidityIntervalError PastHorizonException
pastTimeHorizon) =
      [Char]
"The transaction validity interval is too far in the future. "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"For this network it must not be more than "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> [Char]
forall a. Show a => a -> [Char]
show (PastHorizonException -> Word
timeHorizonSlots PastHorizonException
pastTimeHorizon)
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"slots ahead of the current time slot. "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"(Transactions with Plutus scripts must have validity intervals that "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"are close enough in the future that we can reliably turn the slot "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"numbers into UTC wall clock times.)"
    where
      timeHorizonSlots :: Consensus.PastHorizonException -> Word
      timeHorizonSlots :: PastHorizonException -> Word
timeHorizonSlots Consensus.PastHorizon{[EraSummary]
pastHorizonSummary :: PastHorizonException -> [EraSummary]
pastHorizonSummary :: [EraSummary]
Consensus.pastHorizonSummary}
        | eraSummaries :: [EraSummary]
eraSummaries@(EraSummary
_:[EraSummary]
_) <- [EraSummary]
pastHorizonSummary
        , Consensus.StandardSafeZone Word64
slots <-
            (EraParams -> SafeZone
Consensus.eraSafeZone (EraParams -> SafeZone)
-> ([EraSummary] -> EraParams) -> [EraSummary] -> SafeZone
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraSummary -> EraParams
Consensus.eraParams (EraSummary -> EraParams)
-> ([EraSummary] -> EraSummary) -> [EraSummary] -> EraParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EraSummary] -> EraSummary
forall a. [a] -> a
last) [EraSummary]
eraSummaries
        = Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
slots

        | Bool
otherwise
        = Word
0 -- This should be impossible.
  displayError (TransactionValidityTranslationError TranslationError StandardCrypto
errmsg) =
    [Char]
"Error translating the transaction context: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> TranslationError StandardCrypto -> [Char]
forall a. Show a => a -> [Char]
show TranslationError StandardCrypto
errmsg

  displayError (TransactionValidityCostModelError Map AnyPlutusScriptVersion CostModel
cModels [Char]
err) =
    [Char]
"An error occurred while converting from the cardano-api cost" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    [Char]
" models to the cardano-ledger cost models. Error: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
err [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    [Char]
" Cost models: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map AnyPlutusScriptVersion CostModel -> [Char]
forall a. Show a => a -> [Char]
show Map AnyPlutusScriptVersion CostModel
cModels

-- | Compute the 'ExecutionUnits' needed for each script in the transaction.
--
-- This works by running all the scripts and counting how many execution units
-- are actually used.
--
evaluateTransactionExecutionUnits
  :: forall era mode.
     EraInMode era mode
  -> SystemStart
  -> EraHistory mode
  -> ProtocolParameters
  -> UTxO era
  -> TxBody era
  -> Either TransactionValidityError
            (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits :: EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits EraInMode era mode
_eraInMode SystemStart
systemstart EraHistory mode
history ProtocolParameters
pparams UTxO era
utxo TxBody era
txbody =
    case [KeyWitness era] -> TxBody era -> Tx era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody era
txbody of
      ByronTx {}                 -> Either
  TransactionValidityError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
      ShelleyTx ShelleyBasedEra era
era Tx (ShelleyLedgerEra era)
tx' ->
        case ShelleyBasedEra era
era of
          ShelleyBasedEra era
ShelleyBasedEraShelley -> Either
  TransactionValidityError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
          ShelleyBasedEra era
ShelleyBasedEraAllegra -> Either
  TransactionValidityError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
          ShelleyBasedEra era
ShelleyBasedEraMary    -> Either
  TransactionValidityError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
          ShelleyBasedEra era
ShelleyBasedEraAlonzo  -> ShelleyBasedEra era
-> Tx StandardAlonzo
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall ledgerera.
(ShelleyLedgerEra era ~ ledgerera, ledgerera ~ StandardAlonzo,
 LedgerEraConstraints ledgerera) =>
ShelleyBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalAlonzo ShelleyBasedEra era
era Tx StandardAlonzo
Tx (ShelleyLedgerEra era)
tx'
          ShelleyBasedEra era
ShelleyBasedEraBabbage ->
            case CardanoEra era -> Maybe (CollateralSupportedInEra era)
forall era. CardanoEra era -> Maybe (CollateralSupportedInEra era)
collateralSupportedInEra (CardanoEra era -> Maybe (CollateralSupportedInEra era))
-> CardanoEra era -> Maybe (CollateralSupportedInEra era)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> CardanoEra era
forall era. ShelleyBasedEra era -> CardanoEra era
shelleyBasedToCardanoEra ShelleyBasedEra era
era of
              Just CollateralSupportedInEra era
supp -> CollateralSupportedInEra era
-> (HasField "_maxTxExUnits" (PParams StandardBabbage) ExUnits =>
    Either
      TransactionValidityError
      (Map
         ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)))
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
CollateralSupportedInEra era
-> (HasField "_maxTxExUnits" (PParams ledgerera) ExUnits => a) -> a
obtainHasFieldConstraint CollateralSupportedInEra era
supp ((HasField "_maxTxExUnits" (PParams StandardBabbage) ExUnits =>
  Either
    TransactionValidityError
    (Map
       ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)))
 -> Either
      TransactionValidityError
      (Map
         ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)))
-> (HasField "_maxTxExUnits" (PParams StandardBabbage) ExUnits =>
    Either
      TransactionValidityError
      (Map
         ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)))
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> Tx StandardBabbage
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall ledgerera.
(ShelleyLedgerEra era ~ ledgerera, ledgerera ~ StandardBabbage,
 HasField "_maxTxExUnits" (PParams ledgerera) ExUnits,
 HasField "_protocolVersion" (PParams ledgerera) ProtVer) =>
ShelleyBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalBabbage ShelleyBasedEra era
era Tx StandardBabbage
Tx (ShelleyLedgerEra era)
tx'
              Maybe (CollateralSupportedInEra era)
Nothing -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall (m :: * -> *) a. Monad m => a -> m a
return Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
forall a. Monoid a => a
mempty
  where
    -- Pre-Alonzo eras do not support languages with execution unit accounting.
    evalPreAlonzo :: Either TransactionValidityError
                            (Map ScriptWitnessIndex
                                 (Either ScriptExecutionError ExecutionUnits))
    evalPreAlonzo :: Either
  TransactionValidityError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo = Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. b -> Either a b
Right Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
forall k a. Map k a
Map.empty

    evalAlonzo :: forall ledgerera.
                  ShelleyLedgerEra era ~ ledgerera
               => ledgerera ~ Alonzo.AlonzoEra Ledger.StandardCrypto
               => LedgerEraConstraints ledgerera
               => ShelleyBasedEra era
               -> Ledger.Tx ledgerera
               -> Either TransactionValidityError
                         (Map ScriptWitnessIndex
                              (Either ScriptExecutionError ExecutionUnits))
    evalAlonzo :: ShelleyBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalAlonzo ShelleyBasedEra era
era Tx ledgerera
tx = do
      Array Language CostModel
cModelArray <- Map AnyPlutusScriptVersion CostModel
-> Either TransactionValidityError (Array Language CostModel)
toAlonzoCostModelsArray (ProtocolParameters -> Map AnyPlutusScriptVersion CostModel
protocolParamCostModels ProtocolParameters
pparams)
      case PParams StandardAlonzo
-> Tx StandardAlonzo
-> UTxO StandardAlonzo
-> EpochInfo (Either Text)
-> SystemStart
-> Array Language CostModel
-> Either
     (TranslationError (Crypto StandardAlonzo))
     (RedeemerReport (Crypto StandardAlonzo))
forall era.
(Era era, ExtendedUTxO era,
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "txdats" (Witnesses era) (TxDats era),
 HasField "txrdmrs" (Witnesses era) (Redeemers era),
 HasField "_maxTxExUnits" (PParams era) ExUnits,
 HasField "_protocolVersion" (PParams era) ProtVer,
 Script era ~ Script era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Array Language CostModel
-> Either
     (TranslationError (Crypto era)) (RedeemerReport (Crypto era))
Alonzo.evaluateTransactionExecutionUnits
             (ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
toLedgerPParams ShelleyBasedEra era
era ProtocolParameters
pparams)
             Tx ledgerera
Tx StandardAlonzo
tx
             (ShelleyBasedEra era -> UTxO era -> UTxO StandardAlonzo
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO era -> UTxO ledgerera
toLedgerUTxO ShelleyBasedEra era
era UTxO era
utxo)
             (EraHistory mode -> EpochInfo (Either Text)
forall mode. EraHistory mode -> EpochInfo (Either Text)
toLedgerEpochInfo EraHistory mode
history)
             SystemStart
systemstart
             Array Language CostModel
cModelArray
        of Left TranslationError (Crypto StandardAlonzo)
err -> TransactionValidityError
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. a -> Either a b
Left (TranslationError StandardCrypto -> TransactionValidityError
TransactionValidityTranslationError TranslationError StandardCrypto
TranslationError (Crypto StandardAlonzo)
err)
           Right RedeemerReport (Crypto StandardAlonzo)
exmap -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. b -> Either a b
Right (Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
-> Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
fromLedgerScriptExUnitsMap Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
RedeemerReport (Crypto StandardAlonzo)
exmap)

    evalBabbage :: forall ledgerera.
                  ShelleyLedgerEra era ~ ledgerera
               => ledgerera ~ Babbage.BabbageEra Ledger.StandardCrypto
               => HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits
               => HasField"_protocolVersion" (Ledger.PParams ledgerera) Ledger.ProtVer
               => ShelleyBasedEra era
               -> Ledger.Tx ledgerera
               -> Either TransactionValidityError
                         (Map ScriptWitnessIndex
                              (Either ScriptExecutionError ExecutionUnits))
    evalBabbage :: ShelleyBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalBabbage ShelleyBasedEra era
era Tx ledgerera
tx = do
      Array Language CostModel
costModelsArray <- Map AnyPlutusScriptVersion CostModel
-> Either TransactionValidityError (Array Language CostModel)
toAlonzoCostModelsArray (ProtocolParameters -> Map AnyPlutusScriptVersion CostModel
protocolParamCostModels ProtocolParameters
pparams)
      case PParams StandardBabbage
-> Tx StandardBabbage
-> UTxO StandardBabbage
-> EpochInfo (Either Text)
-> SystemStart
-> Array Language CostModel
-> Either
     (TranslationError (Crypto StandardBabbage))
     (RedeemerReport (Crypto StandardBabbage))
forall era.
(Era era, ExtendedUTxO era,
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "txdats" (Witnesses era) (TxDats era),
 HasField "txrdmrs" (Witnesses era) (Redeemers era),
 HasField "_maxTxExUnits" (PParams era) ExUnits,
 HasField "_protocolVersion" (PParams era) ProtVer,
 Script era ~ Script era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> Array Language CostModel
-> Either
     (TranslationError (Crypto era)) (RedeemerReport (Crypto era))
Alonzo.evaluateTransactionExecutionUnits
             (ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
toLedgerPParams ShelleyBasedEra era
era ProtocolParameters
pparams)
             Tx ledgerera
Tx StandardBabbage
tx
             (ShelleyBasedEra era -> UTxO era -> UTxO StandardBabbage
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO era -> UTxO ledgerera
toLedgerUTxO ShelleyBasedEra era
era UTxO era
utxo)
             (EraHistory mode -> EpochInfo (Either Text)
forall mode. EraHistory mode -> EpochInfo (Either Text)
toLedgerEpochInfo EraHistory mode
history)
             SystemStart
systemstart
             Array Language CostModel
costModelsArray
        of Left TranslationError (Crypto StandardBabbage)
err    -> TransactionValidityError
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. a -> Either a b
Left (TranslationError StandardCrypto -> TransactionValidityError
TransactionValidityTranslationError TranslationError StandardCrypto
TranslationError (Crypto StandardBabbage)
err)
           Right RedeemerReport (Crypto StandardBabbage)
exmap -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. b -> Either a b
Right (Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
-> Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
fromLedgerScriptExUnitsMap Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
RedeemerReport (Crypto StandardBabbage)
exmap)


    toAlonzoCostModelsArray
      :: Map AnyPlutusScriptVersion CostModel
      -> Either TransactionValidityError (Array.Array Alonzo.Language Alonzo.CostModel)
    toAlonzoCostModelsArray :: Map AnyPlutusScriptVersion CostModel
-> Either TransactionValidityError (Array Language CostModel)
toAlonzoCostModelsArray Map AnyPlutusScriptVersion CostModel
costmodels = do
      Alonzo.CostModels Map Language CostModel
cModels <- ([Char] -> TransactionValidityError)
-> Either [Char] CostModels
-> Either TransactionValidityError CostModels
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Map AnyPlutusScriptVersion CostModel
-> [Char] -> TransactionValidityError
TransactionValidityCostModelError Map AnyPlutusScriptVersion CostModel
costmodels) (Either [Char] CostModels
 -> Either TransactionValidityError CostModels)
-> Either [Char] CostModels
-> Either TransactionValidityError CostModels
forall a b. (a -> b) -> a -> b
$ Map AnyPlutusScriptVersion CostModel -> Either [Char] CostModels
toAlonzoCostModels Map AnyPlutusScriptVersion CostModel
costmodels
      Array Language CostModel
-> Either TransactionValidityError (Array Language CostModel)
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Language CostModel
 -> Either TransactionValidityError (Array Language CostModel))
-> Array Language CostModel
-> Either TransactionValidityError (Array Language CostModel)
forall a b. (a -> b) -> a -> b
$ (Language, Language)
-> [(Language, CostModel)] -> Array Language CostModel
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (Language
forall a. Bounded a => a
minBound, Language
forall a. Bounded a => a
maxBound) (Map Language CostModel -> [(Language, CostModel)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Language CostModel
cModels)

    fromLedgerScriptExUnitsMap
      :: Map Alonzo.RdmrPtr (Either (Alonzo.TransactionScriptFailure Ledger.StandardCrypto)
                                    Alonzo.ExUnits)
      -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
    fromLedgerScriptExUnitsMap :: Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
-> Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
fromLedgerScriptExUnitsMap Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
exmap =
      [(ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)]
-> Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (RdmrPtr -> ScriptWitnessIndex
fromAlonzoRdmrPtr RdmrPtr
rdmrptr,
           (TransactionScriptFailure StandardCrypto -> ScriptExecutionError)
-> (ExUnits -> ExecutionUnits)
-> Either (TransactionScriptFailure StandardCrypto) ExUnits
-> Either ScriptExecutionError ExecutionUnits
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TransactionScriptFailure StandardCrypto -> ScriptExecutionError
fromAlonzoScriptExecutionError ExUnits -> ExecutionUnits
fromAlonzoExUnits Either (TransactionScriptFailure StandardCrypto) ExUnits
exunitsOrFailure)
        | (RdmrPtr
rdmrptr, Either (TransactionScriptFailure StandardCrypto) ExUnits
exunitsOrFailure) <- Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
-> [(RdmrPtr,
     Either (TransactionScriptFailure StandardCrypto) ExUnits)]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  RdmrPtr (Either (TransactionScriptFailure StandardCrypto) ExUnits)
exmap ]

    fromAlonzoScriptExecutionError :: Alonzo.TransactionScriptFailure Ledger.StandardCrypto
                                   -> ScriptExecutionError
    fromAlonzoScriptExecutionError :: TransactionScriptFailure StandardCrypto -> ScriptExecutionError
fromAlonzoScriptExecutionError TransactionScriptFailure StandardCrypto
failure =
      case TransactionScriptFailure StandardCrypto
failure of
        Alonzo.UnknownTxIn     TxIn StandardCrypto
txin -> TxIn -> ScriptExecutionError
ScriptErrorMissingTxIn TxIn
txin'
                                         where txin' :: TxIn
txin' = TxIn StandardCrypto -> TxIn
fromShelleyTxIn TxIn StandardCrypto
txin
        Alonzo.InvalidTxIn     TxIn StandardCrypto
txin -> TxIn -> ScriptExecutionError
ScriptErrorTxInWithoutDatum TxIn
txin'
                                         where txin' :: TxIn
txin' = TxIn StandardCrypto -> TxIn
fromShelleyTxIn TxIn StandardCrypto
txin
        Alonzo.MissingDatum      DataHash StandardCrypto
dh -> Hash ScriptData -> ScriptExecutionError
ScriptErrorWrongDatum (DataHash StandardCrypto -> Hash ScriptData
ScriptDataHash DataHash StandardCrypto
dh)
        Alonzo.ValidationFailedV1 EvaluationError
err [Text]
logs -> EvaluationError -> [Text] -> ScriptExecutionError
ScriptErrorEvaluationFailed EvaluationError
err [Text]
logs
        Alonzo.ValidationFailedV2 EvaluationError
err [Text]
logs -> EvaluationError -> [Text] -> ScriptExecutionError
ScriptErrorEvaluationFailed EvaluationError
err [Text]
logs
        Alonzo.IncompatibleBudget ExBudget
_ -> ScriptExecutionError
ScriptErrorExecutionUnitsOverflow

        -- This is only possible for spending scripts and occurs when
        -- we attempt to spend a key witnessed tx input with a Plutus
        -- script witness.
        Alonzo.RedeemerNotNeeded RdmrPtr
rdmrPtr ScriptHash StandardCrypto
scriptHash ->
          ScriptWitnessIndex -> ScriptHash -> ScriptExecutionError
ScriptErrorNotPlutusWitnessedTxIn
            (RdmrPtr -> ScriptWitnessIndex
fromAlonzoRdmrPtr RdmrPtr
rdmrPtr)
            (ScriptHash StandardCrypto -> ScriptHash
fromShelleyScriptHash ScriptHash StandardCrypto
scriptHash)
        Alonzo.RedeemerPointsToUnknownScriptHash RdmrPtr
rdmrPtr ->
          ScriptWitnessIndex -> ScriptExecutionError
ScriptErrorRedeemerPointsToUnknownScriptHash (ScriptWitnessIndex -> ScriptExecutionError)
-> ScriptWitnessIndex -> ScriptExecutionError
forall a b. (a -> b) -> a -> b
$ RdmrPtr -> ScriptWitnessIndex
fromAlonzoRdmrPtr RdmrPtr
rdmrPtr
        -- This should not occur while using cardano-cli because we zip together
        -- the Plutus script and the use site (txin, certificate etc). Therefore
        -- the redeemer pointer will always point to a Plutus script.
        Alonzo.MissingScript RdmrPtr
rdmrPtr ResolvablePointers
resolveable -> RdmrPtr -> ResolvablePointers -> ScriptExecutionError
ScriptErrorMissingScript RdmrPtr
rdmrPtr ResolvablePointers
resolveable

        Alonzo.NoCostModelInLedgerState Language
l -> Language -> ScriptExecutionError
ScriptErrorMissingCostModel Language
l


    obtainHasFieldConstraint
      :: ShelleyLedgerEra era ~ ledgerera
      => CollateralSupportedInEra era
      -> (HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits => a) ->  a
    obtainHasFieldConstraint :: CollateralSupportedInEra era
-> (HasField "_maxTxExUnits" (PParams ledgerera) ExUnits => a) -> a
obtainHasFieldConstraint CollateralSupportedInEra era
CollateralInAlonzoEra HasField "_maxTxExUnits" (PParams ledgerera) ExUnits => a
f =  a
HasField "_maxTxExUnits" (PParams ledgerera) ExUnits => a
f
    obtainHasFieldConstraint CollateralSupportedInEra era
CollateralInBabbageEra HasField "_maxTxExUnits" (PParams ledgerera) ExUnits => a
f =  a
HasField "_maxTxExUnits" (PParams ledgerera) ExUnits => a
f

toLedgerEpochInfo :: EraHistory mode -> EpochInfo (Either Text.Text)
toLedgerEpochInfo :: EraHistory mode -> EpochInfo (Either Text)
toLedgerEpochInfo (EraHistory ConsensusMode mode
_ Interpreter xs
interpreter) =
    (forall a. Except PastHorizonException a -> Either Text a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo ((PastHorizonException -> Text)
-> Either PastHorizonException a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Char] -> Text
Text.pack ([Char] -> Text)
-> (PastHorizonException -> [Char]) -> PastHorizonException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PastHorizonException -> [Char]
forall a. Show a => a -> [Char]
show) (Either PastHorizonException a -> Either Text a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except PastHorizonException a -> Either PastHorizonException a
forall e a. Except e a -> Either e a
runExcept) (EpochInfo (Except PastHorizonException)
 -> EpochInfo (Either Text))
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either Text)
forall a b. (a -> b) -> a -> b
$
      Interpreter xs -> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Interpreter xs -> EpochInfo (Except PastHorizonException)
Consensus.interpreterToEpochInfo Interpreter xs
interpreter

-- ----------------------------------------------------------------------------
-- Transaction balance
--

-- | Compute the total balance of the proposed transaction. Ultimately a valid
-- transaction must be fully balanced: that is have a total value of zero.
--
-- Finding the (non-zero) balance of partially constructed transaction is
-- useful for adjusting a transaction to be fully balanced.
--
evaluateTransactionBalance :: forall era.
                              IsShelleyBasedEra era
                           => ProtocolParameters
                           -> Set PoolId
                           -> UTxO era
                           -> TxBody era
                           -> TxOutValue era
evaluateTransactionBalance :: ProtocolParameters
-> Set PoolId -> UTxO era -> TxBody era -> TxOutValue era
evaluateTransactionBalance ProtocolParameters
_ Set PoolId
_ UTxO era
_ (ByronTxBody Annotated Tx ByteString
_) =
    case ShelleyBasedEra era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra :: ShelleyBasedEra era of {}
    --TODO: we could actually support Byron here, it'd be different but simpler

evaluateTransactionBalance ProtocolParameters
pparams Set PoolId
poolids UTxO era
utxo
                           (ShelleyTxBody ShelleyBasedEra era
era TxBody (ShelleyLedgerEra era)
txbody [Script (ShelleyLedgerEra era)]
_ TxBodyScriptData era
_ Maybe (AuxiliaryData (ShelleyLedgerEra era))
_ TxScriptValidity era
_) =
    ShelleyBasedEra era
-> ((LedgerEraConstraints (ShelleyLedgerEra era),
     LedgerAdaOnlyConstraints (ShelleyLedgerEra era),
     LedgerPParamsConstraints (ShelleyLedgerEra era),
     LedgerTxBodyConstraints (ShelleyLedgerEra era)) =>
    OnlyAdaSupportedInEra era -> TxOutValue era)
-> ((LedgerEraConstraints (ShelleyLedgerEra era),
     LedgerMultiAssetConstraints (ShelleyLedgerEra era),
     LedgerPParamsConstraints (ShelleyLedgerEra era),
     LedgerTxBodyConstraints (ShelleyLedgerEra era)) =>
    MultiAssetSupportedInEra era -> TxOutValue era)
-> TxOutValue era
forall ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((LedgerEraConstraints ledgerera,
     LedgerAdaOnlyConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    OnlyAdaSupportedInEra era -> a)
-> ((LedgerEraConstraints ledgerera,
     LedgerMultiAssetConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    MultiAssetSupportedInEra era -> a)
-> a
withLedgerConstraints ShelleyBasedEra era
era (LedgerEraConstraints (ShelleyLedgerEra era),
 LedgerAdaOnlyConstraints (ShelleyLedgerEra era),
 LedgerPParamsConstraints (ShelleyLedgerEra era),
 LedgerTxBodyConstraints (ShelleyLedgerEra era)) =>
OnlyAdaSupportedInEra era -> TxOutValue era
forall ledgerera.
(ShelleyLedgerEra era ~ ledgerera, LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> TxOutValue era
evalAdaOnly (LedgerEraConstraints (ShelleyLedgerEra era),
 LedgerMultiAssetConstraints (ShelleyLedgerEra era),
 LedgerPParamsConstraints (ShelleyLedgerEra era),
 LedgerTxBodyConstraints (ShelleyLedgerEra era)) =>
MultiAssetSupportedInEra era -> TxOutValue era
forall ledgerera.
(ShelleyLedgerEra era ~ ledgerera, LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera) =>
MultiAssetSupportedInEra era -> TxOutValue era
evalMultiAsset
  where
    isNewPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool
    isNewPool :: KeyHash 'StakePool StandardCrypto -> Bool
isNewPool KeyHash 'StakePool StandardCrypto
kh = KeyHash 'StakePool StandardCrypto -> PoolId
StakePoolKeyHash KeyHash 'StakePool StandardCrypto
kh PoolId -> Set PoolId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set PoolId
poolids

    evalMultiAsset :: forall ledgerera.
                      ShelleyLedgerEra era ~ ledgerera
                   => LedgerEraConstraints ledgerera
                   => LedgerMultiAssetConstraints ledgerera
                   => MultiAssetSupportedInEra era
                   -> TxOutValue era
    evalMultiAsset :: MultiAssetSupportedInEra era -> TxOutValue era
evalMultiAsset MultiAssetSupportedInEra era
evidence =
      MultiAssetSupportedInEra era -> Value -> TxOutValue era
forall era. MultiAssetSupportedInEra era -> Value -> TxOutValue era
TxOutValue MultiAssetSupportedInEra era
evidence (Value -> TxOutValue era)
-> (Value StandardCrypto -> Value)
-> Value StandardCrypto
-> TxOutValue era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value StandardCrypto -> Value
fromMaryValue (Value StandardCrypto -> TxOutValue era)
-> Value StandardCrypto -> TxOutValue era
forall a b. (a -> b) -> a -> b
$
         PParams ledgerera
-> UTxO ledgerera
-> (KeyHash 'StakePool (Crypto ledgerera) -> Bool)
-> TxBody ledgerera
-> Value ledgerera
forall era.
CLI era =>
PParams era
-> UTxO era
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> TxBody era
-> Value era
Ledger.evaluateTransactionBalance
           (ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
toLedgerPParams ShelleyBasedEra era
era ProtocolParameters
pparams)
           (ShelleyBasedEra era -> UTxO era -> UTxO ledgerera
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO era -> UTxO ledgerera
toLedgerUTxO ShelleyBasedEra era
era UTxO era
utxo)
           KeyHash 'StakePool StandardCrypto -> Bool
KeyHash 'StakePool (Crypto ledgerera) -> Bool
isNewPool
           TxBody ledgerera
TxBody (ShelleyLedgerEra era)
txbody

    evalAdaOnly :: forall ledgerera.
                   ShelleyLedgerEra era ~ ledgerera
                => LedgerEraConstraints ledgerera
                => LedgerAdaOnlyConstraints ledgerera
                => OnlyAdaSupportedInEra era
                -> TxOutValue era
    evalAdaOnly :: OnlyAdaSupportedInEra era -> TxOutValue era
evalAdaOnly OnlyAdaSupportedInEra era
evidence =
     OnlyAdaSupportedInEra era -> Lovelace -> TxOutValue era
forall era. OnlyAdaSupportedInEra era -> Lovelace -> TxOutValue era
TxOutAdaOnly OnlyAdaSupportedInEra era
evidence (Lovelace -> TxOutValue era)
-> (Coin -> Lovelace) -> Coin -> TxOutValue era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Lovelace
fromShelleyLovelace
       (Coin -> TxOutValue era) -> Coin -> TxOutValue era
forall a b. (a -> b) -> a -> b
$ PParams ledgerera
-> UTxO ledgerera
-> (KeyHash 'StakePool (Crypto ledgerera) -> Bool)
-> TxBody ledgerera
-> Value ledgerera
forall era.
CLI era =>
PParams era
-> UTxO era
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> TxBody era
-> Value era
Ledger.evaluateTransactionBalance
           (ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era
-> ProtocolParameters -> PParams (ShelleyLedgerEra era)
toLedgerPParams ShelleyBasedEra era
era ProtocolParameters
pparams)
           (ShelleyBasedEra era -> UTxO era -> UTxO ledgerera
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO era -> UTxO ledgerera
toLedgerUTxO ShelleyBasedEra era
era UTxO era
utxo)
           KeyHash 'StakePool StandardCrypto -> Bool
KeyHash 'StakePool (Crypto ledgerera) -> Bool
isNewPool
           TxBody ledgerera
TxBody (ShelleyLedgerEra era)
txbody

    -- Conjur up all the necessary class instances and evidence
    withLedgerConstraints
      :: ShelleyLedgerEra era ~ ledgerera
      => ShelleyBasedEra era
      -> (   LedgerEraConstraints ledgerera
          => LedgerAdaOnlyConstraints ledgerera
          => LedgerPParamsConstraints ledgerera
          => LedgerTxBodyConstraints ledgerera
          => OnlyAdaSupportedInEra era
          -> a)
      -> (   LedgerEraConstraints ledgerera
          => LedgerMultiAssetConstraints ledgerera
          => LedgerPParamsConstraints ledgerera
          => LedgerTxBodyConstraints ledgerera
          => MultiAssetSupportedInEra era
          -> a)
      -> a
    withLedgerConstraints :: ShelleyBasedEra era
-> ((LedgerEraConstraints ledgerera,
     LedgerAdaOnlyConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    OnlyAdaSupportedInEra era -> a)
-> ((LedgerEraConstraints ledgerera,
     LedgerMultiAssetConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    MultiAssetSupportedInEra era -> a)
-> a
withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraShelley (LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> a
f (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
_  = (LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> a
OnlyAdaSupportedInEra era -> a
f OnlyAdaSupportedInEra era
OnlyAdaSupportedInEra ShelleyEra
AdaOnlyInShelleyEra
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraAllegra (LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> a
f (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
_  = (LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> a
OnlyAdaSupportedInEra era -> a
f OnlyAdaSupportedInEra era
OnlyAdaSupportedInEra AllegraEra
AdaOnlyInAllegraEra
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraMary    (LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> a
_ (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
f  = (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
MultiAssetSupportedInEra era -> a
f MultiAssetSupportedInEra era
MultiAssetSupportedInEra MaryEra
MultiAssetInMaryEra
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraAlonzo  (LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> a
_ (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
f  = (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
MultiAssetSupportedInEra era -> a
f MultiAssetSupportedInEra era
MultiAssetSupportedInEra AlonzoEra
MultiAssetInAlonzoEra
    withLedgerConstraints ShelleyBasedEra era
ShelleyBasedEraBabbage (LedgerEraConstraints ledgerera,
 LedgerAdaOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyAdaSupportedInEra era -> a
_ (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
f = (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
MultiAssetSupportedInEra era -> a
f MultiAssetSupportedInEra era
MultiAssetSupportedInEra BabbageEra
MultiAssetInBabbageEra

type LedgerEraConstraints ledgerera =
       ( Ledger.Era.Crypto ledgerera ~ Ledger.StandardCrypto
       , Ledger.CLI ledgerera
       )

type LedgerAdaOnlyConstraints ledgerera =
         Ledger.Value ledgerera ~ Ledger.Coin

type LedgerMultiAssetConstraints ledgerera =
       ( Ledger.Value ledgerera ~ Mary.Value Ledger.StandardCrypto
       , HasField "mint" (Ledger.TxBody ledgerera) (Ledger.Value ledgerera)
       )

type LedgerPParamsConstraints ledgerera =
       ( HasField "_minfeeA"     (Ledger.PParams ledgerera) Natural
       , HasField "_minfeeB"     (Ledger.PParams ledgerera) Natural
       , HasField "_keyDeposit"  (Ledger.PParams ledgerera) Ledger.Coin
       , HasField "_poolDeposit" (Ledger.PParams ledgerera) Ledger.Coin
       )

type LedgerTxBodyConstraints ledgerera =
       ( HasField "certs" (Ledger.TxBody ledgerera)
                          (StrictSeq (Ledger.DCert Ledger.StandardCrypto))
       , HasField "inputs" (Ledger.TxBody ledgerera)
                           (Set (Ledger.TxIn Ledger.StandardCrypto))
       , HasField "wdrls" (Ledger.TxBody ledgerera) (Ledger.Wdrl Ledger.StandardCrypto)
       )


-- ----------------------------------------------------------------------------
-- Automated transaction building
--

-- | The possible errors that can arise from 'makeTransactionBodyAutoBalance'.
--
data TxBodyErrorAutoBalance =

       -- | The same errors that can arise from 'makeTransactionBody'.
       TxBodyError TxBodyError

       -- | One or more of the scripts fails to execute correctly.
     | TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]

       -- | One or more of the scripts were expected to fail validation, but none did.
     | TxBodyScriptBadScriptValidity

       -- | The balance of the non-ada assets is not zero. The 'Value' here is
       -- that residual non-zero balance. The 'makeTransactionBodyAutoBalance'
       -- function only automatically balances ada, not other assets.
     | TxBodyErrorAssetBalanceWrong Value

       -- | There is not enough ada to cover both the outputs and the fees.
       -- The transaction should be changed to provide more input ada, or
       -- otherwise adjusted to need less (e.g. outputs, script etc).
       --
     | TxBodyErrorAdaBalanceNegative Lovelace

       -- | There is enough ada to cover both the outputs and the fees, but the
       -- resulting change is too small: it is under the minimum value for
       -- new UTxO entries. The transaction should be changed to provide more
       -- input ada.
       --
     | TxBodyErrorAdaBalanceTooSmall
         -- ^ Offending TxOut
         TxOutInAnyEra
         -- ^ Minimum UTxO
         Lovelace
         -- ^ Tx balance
         Lovelace

       -- | 'makeTransactionBodyAutoBalance' does not yet support the Byron era.
     | TxBodyErrorByronEraNotSupported

       -- | The 'ProtocolParameters' must provide the value for the min utxo
       -- parameter, for eras that use this parameter.
     | TxBodyErrorMissingParamMinUTxO

       -- | The transaction validity interval is too far into the future.
       -- See 'TransactionValidityIntervalError' for details.
     | TxBodyErrorValidityInterval TransactionValidityError

       -- | The minimum spendable UTxO threshold has not been met.
     | TxBodyErrorMinUTxONotMet
         -- ^ Offending TxOut
         TxOutInAnyEra
         -- ^ Minimum UTxO
         Lovelace
     | TxBodyErrorMinUTxOMissingPParams MinimumUTxOError
     | TxBodyErrorNonAdaAssetsUnbalanced Value
     | TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap
         ScriptWitnessIndex
         (Map ScriptWitnessIndex ExecutionUnits)


  deriving Int -> TxBodyErrorAutoBalance -> ShowS
[TxBodyErrorAutoBalance] -> ShowS
TxBodyErrorAutoBalance -> [Char]
(Int -> TxBodyErrorAutoBalance -> ShowS)
-> (TxBodyErrorAutoBalance -> [Char])
-> ([TxBodyErrorAutoBalance] -> ShowS)
-> Show TxBodyErrorAutoBalance
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TxBodyErrorAutoBalance] -> ShowS
$cshowList :: [TxBodyErrorAutoBalance] -> ShowS
show :: TxBodyErrorAutoBalance -> [Char]
$cshow :: TxBodyErrorAutoBalance -> [Char]
showsPrec :: Int -> TxBodyErrorAutoBalance -> ShowS
$cshowsPrec :: Int -> TxBodyErrorAutoBalance -> ShowS
Show


instance Error TxBodyErrorAutoBalance where
  displayError :: TxBodyErrorAutoBalance -> [Char]
displayError (TxBodyError TxBodyError
err) = TxBodyError -> [Char]
forall e. Error e => e -> [Char]
displayError TxBodyError
err

  displayError (TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]
failures) =
      [Char]
"The following scripts have execution failures:\n"
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines [ [Char]
"the script for " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptWitnessIndex -> [Char]
renderScriptWitnessIndex ScriptWitnessIndex
index
                [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" failed with: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptExecutionError -> [Char]
forall e. Error e => e -> [Char]
displayError ScriptExecutionError
failure
              | (ScriptWitnessIndex
index, ScriptExecutionError
failure) <- [(ScriptWitnessIndex, ScriptExecutionError)]
failures ]

  displayError TxBodyErrorAutoBalance
TxBodyScriptBadScriptValidity =
      [Char]
"One or more of the scripts were expected to fail validation, but none did."

  displayError (TxBodyErrorAssetBalanceWrong Value
_value) =
      [Char]
"The transaction does not correctly balance in its non-ada assets. "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"The balance between inputs and outputs should sum to zero. "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"The actual balance is: "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"TODO: move the Value renderer and parser from the CLI into the API and use them here"
   -- TODO: do this ^^

  displayError (TxBodyErrorAdaBalanceNegative Lovelace
lovelace) =
      [Char]
"The transaction does not balance in its use of ada. The net balance "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"of the transaction is negative: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Lovelace -> [Char]
forall a. Show a => a -> [Char]
show Lovelace
lovelace [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" lovelace. "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"The usual solution is to provide more inputs, or inputs with more ada."

  displayError (TxBodyErrorAdaBalanceTooSmall TxOutInAnyEra
changeOutput Lovelace
minUTxO Lovelace
balance) =
      [Char]
"The transaction does balance in its use of ada, however the net "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"balance does not meet the minimum UTxO threshold. \n"
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Balance: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Lovelace -> [Char]
forall a. Show a => a -> [Char]
show Lovelace
balance [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Offending output (change output): " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Text.unpack (TxOutInAnyEra -> Text
prettyRenderTxOut TxOutInAnyEra
changeOutput) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"Minimum UTxO threshold: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Lovelace -> [Char]
forall a. Show a => a -> [Char]
show Lovelace
minUTxO [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"The usual solution is to provide more inputs, or inputs with more ada to \
      \meet the minimum UTxO threshold"

  displayError TxBodyErrorAutoBalance
TxBodyErrorByronEraNotSupported =
      [Char]
"The Byron era is not yet supported by makeTransactionBodyAutoBalance"

  displayError TxBodyErrorAutoBalance
TxBodyErrorMissingParamMinUTxO =
      [Char]
"The minUTxOValue protocol parameter is required but missing"

  displayError (TxBodyErrorValidityInterval TransactionValidityError
err) =
      TransactionValidityError -> [Char]
forall e. Error e => e -> [Char]
displayError TransactionValidityError
err

  displayError (TxBodyErrorMinUTxONotMet TxOutInAnyEra
txout Lovelace
minUTxO) =
      [Char]
"Minimum UTxO threshold not met for tx output: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack (TxOutInAnyEra -> Text
prettyRenderTxOut TxOutInAnyEra
txout) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\n"
   [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"Minimum required UTxO: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Lovelace -> [Char]
forall a. Show a => a -> [Char]
show Lovelace
minUTxO

  displayError (TxBodyErrorNonAdaAssetsUnbalanced Value
val) =
      [Char]
"Non-Ada assets are unbalanced: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack (Value -> Text
renderValue Value
val)

  displayError (TxBodyErrorMinUTxOMissingPParams MinimumUTxOError
err) = MinimumUTxOError -> [Char]
forall e. Error e => e -> [Char]
displayError MinimumUTxOError
err

  displayError (TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap ScriptWitnessIndex
sIndex Map ScriptWitnessIndex ExecutionUnits
eUnitsMap) =
    [Char]
"ScriptWitnessIndex (redeemer pointer): " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> ScriptWitnessIndex -> [Char]
forall a. Show a => a -> [Char]
show ScriptWitnessIndex
sIndex [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is missing from the execution \
    \units (redeemer pointer) map: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Map ScriptWitnessIndex ExecutionUnits -> [Char]
forall a. Show a => a -> [Char]
show Map ScriptWitnessIndex ExecutionUnits
eUnitsMap

handleExUnitsErrors ::
     ScriptValidity -- ^ Mark script as expected to pass or fail validation
  -> Map ScriptWitnessIndex ScriptExecutionError
  -> Map ScriptWitnessIndex ExecutionUnits
  -> Either TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
handleExUnitsErrors :: ScriptValidity
-> Map ScriptWitnessIndex ScriptExecutionError
-> Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
handleExUnitsErrors ScriptValidity
ScriptValid Map ScriptWitnessIndex ScriptExecutionError
failuresMap Map ScriptWitnessIndex ExecutionUnits
exUnitsMap =
    if [(ScriptWitnessIndex, ScriptExecutionError)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ScriptWitnessIndex, ScriptExecutionError)]
failures
      then Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. b -> Either a b
Right Map ScriptWitnessIndex ExecutionUnits
exUnitsMap
      else TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. a -> Either a b
Left ([(ScriptWitnessIndex, ScriptExecutionError)]
-> TxBodyErrorAutoBalance
TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]
failures)
  where failures :: [(ScriptWitnessIndex, ScriptExecutionError)]
        failures :: [(ScriptWitnessIndex, ScriptExecutionError)]
failures = Map ScriptWitnessIndex ScriptExecutionError
-> [(ScriptWitnessIndex, ScriptExecutionError)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ScriptWitnessIndex ScriptExecutionError
failuresMap
handleExUnitsErrors ScriptValidity
ScriptInvalid Map ScriptWitnessIndex ScriptExecutionError
failuresMap Map ScriptWitnessIndex ExecutionUnits
exUnitsMap
  | Map ScriptWitnessIndex ScriptExecutionError -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map ScriptWitnessIndex ScriptExecutionError
failuresMap = TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
TxBodyScriptBadScriptValidity
  | Bool
otherwise = Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. b -> Either a b
Right (Map ScriptWitnessIndex ExecutionUnits
 -> Either
      TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits))
-> Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. (a -> b) -> a -> b
$ (ScriptExecutionError -> ExecutionUnits)
-> Map ScriptWitnessIndex ScriptExecutionError
-> Map ScriptWitnessIndex ExecutionUnits
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\ScriptExecutionError
_ -> Natural -> Natural -> ExecutionUnits
ExecutionUnits Natural
0 Natural
0) Map ScriptWitnessIndex ScriptExecutionError
failuresMap Map ScriptWitnessIndex ExecutionUnits
-> Map ScriptWitnessIndex ExecutionUnits
-> Map ScriptWitnessIndex ExecutionUnits
forall a. Semigroup a => a -> a -> a
<> Map ScriptWitnessIndex ExecutionUnits
exUnitsMap

data BalancedTxBody era
  = BalancedTxBody
      (TxBody era)
      (TxOut CtxTx era) -- ^ Transaction balance (change output)
      Lovelace    -- ^ Estimated transaction fee

-- | This is much like 'makeTransactionBody' but with greater automation to
-- calculate suitable values for several things.
--
-- In particular:
--
-- * It calculates the correct script 'ExecutionUnits' (ignoring the provided
--   values, which can thus be zero).
--
-- * It calculates the transaction fees, based on the script 'ExecutionUnits',
--   the current 'ProtocolParameters', and an estimate of the number of
--   key witnesses (i.e. signatures). There is an override for the number of
--   key witnesses.
--
-- * It accepts a change address, calculates the balance of the transaction
--   and puts the excess change into the change output.
--
-- * It also checks that the balance is positive and the change is above the
--   minimum threshold.
--
-- To do this it needs more information than 'makeTransactionBody', all of
-- which can be queried from a local node.
--
makeTransactionBodyAutoBalance
  :: forall era mode.
     IsShelleyBasedEra era
  => EraInMode era mode
  -> SystemStart
  -> EraHistory mode
  -> ProtocolParameters
  -> Set PoolId       -- ^ The set of registered stake pools
  -> UTxO era         -- ^ Just the transaction inputs, not the entire 'UTxO'.
  -> TxBodyContent BuildTx era
  -> AddressInEra era -- ^ Change address
  -> Maybe Word       -- ^ Override key witnesses
  -> Either TxBodyErrorAutoBalance (BalancedTxBody era)
makeTransactionBodyAutoBalance :: EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> Set PoolId
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either TxBodyErrorAutoBalance (BalancedTxBody era)
makeTransactionBodyAutoBalance EraInMode era mode
eraInMode SystemStart
systemstart EraHistory mode
history ProtocolParameters
pparams
                            Set PoolId
poolids UTxO era
utxo TxBodyContent BuildTx era
txbodycontent AddressInEra era
changeaddr Maybe Word
mnkeys = do

    -- Our strategy is to:
    -- 1. evaluate all the scripts to get the exec units, update with ex units
    -- 2. figure out the overall min fees
    -- 3. update tx with fees
    -- 4. balance the transaction and update tx change output
    TxBody era
txbody0 <-
      (TxBodyError -> TxBodyErrorAutoBalance)
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TxBodyError -> TxBodyErrorAutoBalance
TxBodyError (Either TxBodyError (TxBody era)
 -> Either TxBodyErrorAutoBalance (TxBody era))
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
txbodycontent
        { txOuts :: [TxOut CtxTx era]
txOuts =
              AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
changeaddr (Lovelace -> TxOutValue era
forall era. IsCardanoEra era => Lovelace -> TxOutValue era
lovelaceToTxOutValue Lovelace
0) TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone
            TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era]
forall a. a -> [a] -> [a]
: TxBodyContent BuildTx era -> [TxOut CtxTx era]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txOuts TxBodyContent BuildTx era
txbodycontent
            --TODO: think about the size of the change output
            -- 1,2,4 or 8 bytes?
        }

    Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
exUnitsMap <- (TransactionValidityError -> TxBodyErrorAutoBalance)
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
-> Either
     TxBodyErrorAutoBalance
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TransactionValidityError -> TxBodyErrorAutoBalance
TxBodyErrorValidityInterval (Either
   TransactionValidityError
   (Map
      ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
 -> Either
      TxBodyErrorAutoBalance
      (Map
         ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)))
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
-> Either
     TxBodyErrorAutoBalance
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. (a -> b) -> a -> b
$
                    EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall era mode.
EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits
                      EraInMode era mode
eraInMode
                      SystemStart
systemstart EraHistory mode
history
                      ProtocolParameters
pparams
                      UTxO era
utxo
                      TxBody era
txbody0

    Map ScriptWitnessIndex ExecutionUnits
exUnitsMap' <-
      case (Either ScriptExecutionError ExecutionUnits
 -> Either ScriptExecutionError ExecutionUnits)
-> Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> (Map ScriptWitnessIndex ScriptExecutionError,
    Map ScriptWitnessIndex ExecutionUnits)
forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither Either ScriptExecutionError ExecutionUnits
-> Either ScriptExecutionError ExecutionUnits
forall a. a -> a
id Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
exUnitsMap of
        (Map ScriptWitnessIndex ScriptExecutionError
failures, Map ScriptWitnessIndex ExecutionUnits
exUnitsMap') ->
          ScriptValidity
-> Map ScriptWitnessIndex ScriptExecutionError
-> Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
handleExUnitsErrors
            (TxScriptValidity era -> ScriptValidity
forall era. TxScriptValidity era -> ScriptValidity
txScriptValidityToScriptValidity (TxBodyContent BuildTx era -> TxScriptValidity era
forall build era. TxBodyContent build era -> TxScriptValidity era
txScriptValidity TxBodyContent BuildTx era
txbodycontent))
            Map ScriptWitnessIndex ScriptExecutionError
failures
            Map ScriptWitnessIndex ExecutionUnits
exUnitsMap'

    TxBodyContent BuildTx era
txbodycontent1 <- Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
forall era.
Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
substituteExecutionUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap' TxBodyContent BuildTx era
txbodycontent

    TxFeesExplicitInEra era
explicitTxFees <- (TxFeesImplicitInEra era -> TxBodyErrorAutoBalance)
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
-> Either TxBodyErrorAutoBalance (TxFeesExplicitInEra era)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TxBodyErrorAutoBalance
-> TxFeesImplicitInEra era -> TxBodyErrorAutoBalance
forall a b. a -> b -> a
const TxBodyErrorAutoBalance
TxBodyErrorByronEraNotSupported) (Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
 -> Either TxBodyErrorAutoBalance (TxFeesExplicitInEra era))
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
-> Either TxBodyErrorAutoBalance (TxFeesExplicitInEra era)
forall a b. (a -> b) -> a -> b
$
                        CardanoEra era
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
forall era.
CardanoEra era
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
txFeesExplicitInEra CardanoEra era
era'

    -- Make a txbody that we will use for calculating the fees. For the purpose
    -- of fees we just need to make a txbody of the right size in bytes. We do
    -- not need the right values for the fee or change output. We use
    -- "big enough" values for the change output and set so that the CBOR
    -- encoding size of the tx will be big enough to cover the size of the final
    -- output and fee. Yes this means this current code will only work for
    -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output
    -- of less than around 18 trillion ada  (2^64-1 lovelace).

    let (TxReturnCollateral CtxTx era
dummyCollRet, TxTotalCollateral era
dummyTotColl) = TxBodyContent BuildTx era
-> AddressInEra era
-> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
maybeDummyTotalCollAndCollReturnOutput TxBodyContent BuildTx era
txbodycontent AddressInEra era
changeaddr
    TxBody era
txbody1 <- (TxBodyError -> TxBodyErrorAutoBalance)
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TxBodyError -> TxBodyErrorAutoBalance
TxBodyError (Either TxBodyError (TxBody era)
 -> Either TxBodyErrorAutoBalance (TxBody era))
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall a b. (a -> b) -> a -> b
$ -- TODO: impossible to fail now
               TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
txbodycontent1 {
                 txFee :: TxFee era
txFee  = TxFeesExplicitInEra era -> Lovelace -> TxFee era
forall era. TxFeesExplicitInEra era -> Lovelace -> TxFee era
TxFeeExplicit TxFeesExplicitInEra era
explicitTxFees (Lovelace -> TxFee era) -> Lovelace -> TxFee era
forall a b. (a -> b) -> a -> b
$ Integer -> Lovelace
Lovelace (Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
32 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1),
                 txOuts :: [TxOut CtxTx era]
txOuts = AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
changeaddr
                                (Lovelace -> TxOutValue era
forall era. IsCardanoEra era => Lovelace -> TxOutValue era
lovelaceToTxOutValue (Lovelace -> TxOutValue era) -> Lovelace -> TxOutValue era
forall a b. (a -> b) -> a -> b
$ Integer -> Lovelace
Lovelace (Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
64 :: Integer)) Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
- Lovelace
1)
                                TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone
                        TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era]
forall a. a -> [a] -> [a]
: TxBodyContent BuildTx era -> [TxOut CtxTx era]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txOuts TxBodyContent BuildTx era
txbodycontent,
                 txReturnCollateral :: TxReturnCollateral CtxTx era
txReturnCollateral = TxReturnCollateral CtxTx era
dummyCollRet,
                 txTotalCollateral :: TxTotalCollateral era
txTotalCollateral = TxTotalCollateral era
dummyTotColl

               }

    let nkeys :: Word
nkeys = Word -> Maybe Word -> Word
forall a. a -> Maybe a -> a
fromMaybe (TxBodyContent BuildTx era -> Word
forall era. TxBodyContent BuildTx era -> Word
estimateTransactionKeyWitnessCount TxBodyContent BuildTx era
txbodycontent1)
                          Maybe Word
mnkeys
        fee :: Lovelace
fee   = ProtocolParameters -> TxBody era -> Word -> Word -> Lovelace
forall era.
IsShelleyBasedEra era =>
ProtocolParameters -> TxBody era -> Word -> Word -> Lovelace
evaluateTransactionFee ProtocolParameters
pparams TxBody era
txbody1 Word
nkeys Word
0 --TODO: byron keys
        (TxReturnCollateral CtxTx era
retColl, TxTotalCollateral era
reqCol) = Lovelace
-> ProtocolParameters
-> TxInsCollateral era
-> TxReturnCollateral CtxTx era
-> TxTotalCollateral era
-> AddressInEra era
-> UTxO era
-> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
calcReturnAndTotalCollateral
                              Lovelace
fee ProtocolParameters
pparams (TxBodyContent BuildTx era -> TxInsCollateral era
forall build era. TxBodyContent build era -> TxInsCollateral era
txInsCollateral TxBodyContent BuildTx era
txbodycontent)
                              (TxBodyContent BuildTx era -> TxReturnCollateral CtxTx era
forall build era.
TxBodyContent build era -> TxReturnCollateral CtxTx era
txReturnCollateral TxBodyContent BuildTx era
txbodycontent)
                              (TxBodyContent BuildTx era -> TxTotalCollateral era
forall build era. TxBodyContent build era -> TxTotalCollateral era
txTotalCollateral TxBodyContent BuildTx era
txbodycontent) AddressInEra era
changeaddr UTxO era
utxo

    -- Make a txbody for calculating the balance. For this the size of the tx
    -- does not matter, instead it's just the values of the fee and outputs.
    -- Here we do not want to start with any change output, since that's what
    -- we need to calculate.
    TxBody era
txbody2 <- (TxBodyError -> TxBodyErrorAutoBalance)
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TxBodyError -> TxBodyErrorAutoBalance
TxBodyError (Either TxBodyError (TxBody era)
 -> Either TxBodyErrorAutoBalance (TxBody era))
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall a b. (a -> b) -> a -> b
$ -- TODO: impossible to fail now
               TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
txbodycontent1 {
                 txFee :: TxFee era
txFee = TxFeesExplicitInEra era -> Lovelace -> TxFee era
forall era. TxFeesExplicitInEra era -> Lovelace -> TxFee era
TxFeeExplicit TxFeesExplicitInEra era
explicitTxFees Lovelace
fee,
                 txReturnCollateral :: TxReturnCollateral CtxTx era
txReturnCollateral = TxReturnCollateral CtxTx era
retColl,
                 txTotalCollateral :: TxTotalCollateral era
txTotalCollateral = TxTotalCollateral era
reqCol
               }
    let balance :: TxOutValue era
balance = ProtocolParameters
-> Set PoolId -> UTxO era -> TxBody era -> TxOutValue era
forall era.
IsShelleyBasedEra era =>
ProtocolParameters
-> Set PoolId -> UTxO era -> TxBody era -> TxOutValue era
evaluateTransactionBalance ProtocolParameters
pparams Set PoolId
poolids UTxO era
utxo TxBody era
txbody2

    (TxOut CtxTx era -> Either TxBodyErrorAutoBalance ())
-> [TxOut CtxTx era] -> Either TxBodyErrorAutoBalance ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TxOut CtxTx era
-> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
`checkMinUTxOValue` ProtocolParameters
pparams) ([TxOut CtxTx era] -> Either TxBodyErrorAutoBalance ())
-> [TxOut CtxTx era] -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era -> [TxOut CtxTx era]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txOuts TxBodyContent BuildTx era
txbodycontent1

    -- check if the balance is positive or negative
    -- in one case we can produce change, in the other the inputs are insufficient
    case TxOutValue era
balance of
      TxOutAdaOnly OnlyAdaSupportedInEra era
_ Lovelace
_ -> TxOutValue era -> Either TxBodyErrorAutoBalance ()
balanceCheck TxOutValue era
balance
      TxOutValue MultiAssetSupportedInEra era
_ Value
v   ->
        case Value -> Maybe Lovelace
valueToLovelace Value
v of
          Maybe Lovelace
Nothing -> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left (TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ())
-> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ Value -> TxBodyErrorAutoBalance
TxBodyErrorNonAdaAssetsUnbalanced Value
v
          Just Lovelace
_ -> TxOutValue era -> Either TxBodyErrorAutoBalance ()
balanceCheck TxOutValue era
balance


    --TODO: we could add the extra fee for the CBOR encoding of the change,
    -- now that we know the magnitude of the change: i.e. 1-8 bytes extra.

    -- The txbody with the final fee and change output. This should work
    -- provided that the fee and change are less than 2^32-1, and so will
    -- fit within the encoding size we picked above when calculating the fee.
    -- Yes this could be an over-estimate by a few bytes if the fee or change
    -- would fit within 2^16-1. That's a possible optimisation.
    TxBody era
txbody3 <-
      (TxBodyError -> TxBodyErrorAutoBalance)
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TxBodyError -> TxBodyErrorAutoBalance
TxBodyError (Either TxBodyError (TxBody era)
 -> Either TxBodyErrorAutoBalance (TxBody era))
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall a b. (a -> b) -> a -> b
$ -- TODO: impossible to fail now
        TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
forall era.
IsCardanoEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
txbodycontent1 {
          txFee :: TxFee era
txFee  = TxFeesExplicitInEra era -> Lovelace -> TxFee era
forall era. TxFeesExplicitInEra era -> Lovelace -> TxFee era
TxFeeExplicit TxFeesExplicitInEra era
explicitTxFees Lovelace
fee,
          txOuts :: [TxOut CtxTx era]
txOuts = TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era]
accountForNoChange
                     (AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
changeaddr TxOutValue era
balance TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone)
                     (TxBodyContent BuildTx era -> [TxOut CtxTx era]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txOuts TxBodyContent BuildTx era
txbodycontent),
          txReturnCollateral :: TxReturnCollateral CtxTx era
txReturnCollateral = TxReturnCollateral CtxTx era
retColl,
          txTotalCollateral :: TxTotalCollateral era
txTotalCollateral = TxTotalCollateral era
reqCol
        }
    BalancedTxBody era
-> Either TxBodyErrorAutoBalance (BalancedTxBody era)
forall (m :: * -> *) a. Monad m => a -> m a
return (TxBody era -> TxOut CtxTx era -> Lovelace -> BalancedTxBody era
forall era.
TxBody era -> TxOut CtxTx era -> Lovelace -> BalancedTxBody era
BalancedTxBody TxBody era
txbody3 (AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
changeaddr TxOutValue era
balance TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone) Lovelace
fee)
 where
   -- Essentially we check for the existence of collateral inputs. If they exist we
   -- create a fictitious collateral return output. Why? Because we need to put dummy values
   -- to get a fee estimate (i.e we overestimate the fee.)
   maybeDummyTotalCollAndCollReturnOutput
     :: TxBodyContent BuildTx era -> AddressInEra era -> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
   maybeDummyTotalCollAndCollReturnOutput :: TxBodyContent BuildTx era
-> AddressInEra era
-> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
maybeDummyTotalCollAndCollReturnOutput TxBodyContent{TxInsCollateral era
txInsCollateral :: TxInsCollateral era
txInsCollateral :: forall build era. TxBodyContent build era -> TxInsCollateral era
txInsCollateral, TxReturnCollateral CtxTx era
txReturnCollateral :: TxReturnCollateral CtxTx era
txReturnCollateral :: forall build era.
TxBodyContent build era -> TxReturnCollateral CtxTx era
txReturnCollateral, TxTotalCollateral era
txTotalCollateral :: TxTotalCollateral era
txTotalCollateral :: forall build era. TxBodyContent build era -> TxTotalCollateral era
txTotalCollateral} AddressInEra era
cAddr =
     case TxInsCollateral era
txInsCollateral of
       TxInsCollateral era
TxInsCollateralNone -> (TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone, TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone)
       TxInsCollateral{} ->
         case CardanoEra era
-> Maybe (TxTotalAndReturnCollateralSupportedInEra era)
forall era.
CardanoEra era
-> Maybe (TxTotalAndReturnCollateralSupportedInEra era)
totalAndReturnCollateralSupportedInEra CardanoEra era
era' of
           Maybe (TxTotalAndReturnCollateralSupportedInEra era)
Nothing -> (TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone, TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone)
           Just TxTotalAndReturnCollateralSupportedInEra era
retColSup ->
             let dummyRetCol :: TxReturnCollateral CtxTx era
dummyRetCol = TxTotalAndReturnCollateralSupportedInEra era
-> TxOut CtxTx era -> TxReturnCollateral CtxTx era
forall era ctx.
TxTotalAndReturnCollateralSupportedInEra era
-> TxOut ctx era -> TxReturnCollateral ctx era
TxReturnCollateral
                                 TxTotalAndReturnCollateralSupportedInEra era
retColSup
                                 (AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
cAddr (Lovelace -> TxOutValue era
forall era. IsCardanoEra era => Lovelace -> TxOutValue era
lovelaceToTxOutValue (Lovelace -> TxOutValue era) -> Lovelace -> TxOutValue era
forall a b. (a -> b) -> a -> b
$ Integer -> Lovelace
Lovelace (Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
64 :: Integer)) Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
- Lovelace
1)
                                 TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone)
                 dummyTotCol :: TxTotalCollateral era
dummyTotCol = TxTotalAndReturnCollateralSupportedInEra era
-> Lovelace -> TxTotalCollateral era
forall era.
TxTotalAndReturnCollateralSupportedInEra era
-> Lovelace -> TxTotalCollateral era
TxTotalCollateral TxTotalAndReturnCollateralSupportedInEra era
retColSup (Integer -> Lovelace
Lovelace (Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
32 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1))
             in case (TxReturnCollateral CtxTx era
txReturnCollateral, TxTotalCollateral era
txTotalCollateral) of
                  (rc :: TxReturnCollateral CtxTx era
rc@TxReturnCollateral{}, tc :: TxTotalCollateral era
tc@TxTotalCollateral{}) -> (TxReturnCollateral CtxTx era
rc, TxTotalCollateral era
tc)
                  (rc :: TxReturnCollateral CtxTx era
rc@TxReturnCollateral{},TxTotalCollateral era
TxTotalCollateralNone) -> (TxReturnCollateral CtxTx era
rc, TxTotalCollateral era
dummyTotCol)
                  (TxReturnCollateral CtxTx era
TxReturnCollateralNone,tc :: TxTotalCollateral era
tc@TxTotalCollateral{}) -> (TxReturnCollateral CtxTx era
dummyRetCol, TxTotalCollateral era
tc)
                  (TxReturnCollateral CtxTx era
TxReturnCollateralNone, TxTotalCollateral era
TxTotalCollateralNone) -> (TxReturnCollateral CtxTx era
dummyRetCol, TxTotalCollateral era
dummyTotCol)
   -- Calculation taken from validateInsufficientCollateral: https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335
   -- TODO: Bug Jared to expose a function from the ledger that returns total and return collateral.
   calcReturnAndTotalCollateral
     :: Lovelace -- ^ Fee
     -> ProtocolParameters
     -> TxInsCollateral era -- ^ From the initial TxBodyContent
     -> TxReturnCollateral CtxTx era -- ^ From the initial TxBodyContent
     -> TxTotalCollateral era -- ^ From the initial TxBodyContent
     -> AddressInEra era -- ^ Change address
     -> UTxO era
     -> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
   calcReturnAndTotalCollateral :: Lovelace
-> ProtocolParameters
-> TxInsCollateral era
-> TxReturnCollateral CtxTx era
-> TxTotalCollateral era
-> AddressInEra era
-> UTxO era
-> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
calcReturnAndTotalCollateral Lovelace
_ ProtocolParameters
_ TxInsCollateral era
TxInsCollateralNone TxReturnCollateral CtxTx era
_ TxTotalCollateral era
_ AddressInEra era
_ UTxO era
_= (TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone, TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone)
   calcReturnAndTotalCollateral Lovelace
_ ProtocolParameters
_ TxInsCollateral era
_ rc :: TxReturnCollateral CtxTx era
rc@TxReturnCollateral{} tc :: TxTotalCollateral era
tc@TxTotalCollateral{} AddressInEra era
_ UTxO era
_ = (TxReturnCollateral CtxTx era
rc,TxTotalCollateral era
tc)
   calcReturnAndTotalCollateral Lovelace
fee ProtocolParameters
pp (TxInsCollateral CollateralSupportedInEra era
_ [TxIn]
collIns) TxReturnCollateral CtxTx era
txReturnCollateral TxTotalCollateral era
txTotalCollateral AddressInEra era
cAddr (UTxO Map TxIn (TxOut CtxUTxO era)
utxo') = do

    case CardanoEra era
-> Maybe (TxTotalAndReturnCollateralSupportedInEra era)
forall era.
CardanoEra era
-> Maybe (TxTotalAndReturnCollateralSupportedInEra era)
totalAndReturnCollateralSupportedInEra CardanoEra era
era' of
      Maybe (TxTotalAndReturnCollateralSupportedInEra era)
Nothing -> (TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone, TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone)
      Just TxTotalAndReturnCollateralSupportedInEra era
retColSup ->
        case ProtocolParameters -> Maybe Natural
protocolParamCollateralPercent ProtocolParameters
pp of
          Maybe Natural
Nothing -> (TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone, TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone)
          Just Natural
colPerc -> do
            -- We must first figure out how much lovelace we have committed
            -- as collateral and we must determine if we have enough lovelace at our
            -- collateral tx inputs to cover the tx
            let txOuts :: [TxOut CtxUTxO era]
txOuts = [Maybe (TxOut CtxUTxO era)] -> [TxOut CtxUTxO era]
forall a. [Maybe a] -> [a]
catMaybes [ TxIn -> Map TxIn (TxOut CtxUTxO era) -> Maybe (TxOut CtxUTxO era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txin Map TxIn (TxOut CtxUTxO era)
utxo' | TxIn
txin <- [TxIn]
collIns]
                totalCollateralLovelace :: Lovelace
totalCollateralLovelace = [Lovelace] -> Lovelace
forall a. Monoid a => [a] -> a
mconcat ([Lovelace] -> Lovelace) -> [Lovelace] -> Lovelace
forall a b. (a -> b) -> a -> b
$ (TxOut CtxUTxO era -> Lovelace)
-> [TxOut CtxUTxO era] -> [Lovelace]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxOut AddressInEra era
_ TxOutValue era
txOutVal TxOutDatum CtxUTxO era
_ ReferenceScript era
_) -> TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
txOutVal) [TxOut CtxUTxO era]
txOuts
                requiredCollateral :: Lovelace
requiredCollateral@(Lovelace Integer
reqAmt) = Natural -> Lovelace
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
colPerc Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
* Lovelace
fee
                totalCollateral :: TxTotalCollateral era
totalCollateral = TxTotalAndReturnCollateralSupportedInEra era
-> Lovelace -> TxTotalCollateral era
forall era.
TxTotalAndReturnCollateralSupportedInEra era
-> Lovelace -> TxTotalCollateral era
TxTotalCollateral TxTotalAndReturnCollateralSupportedInEra era
retColSup (Lovelace -> TxTotalCollateral era)
-> (Rational -> Lovelace) -> Rational -> TxTotalCollateral era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Lovelace
fromShelleyLovelace
                                                              (Coin -> Lovelace) -> (Rational -> Coin) -> Rational -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Coin
Ledger.rationalToCoinViaCeiling
                                                              (Rational -> TxTotalCollateral era)
-> Rational -> TxTotalCollateral era
forall a b. (a -> b) -> a -> b
$ Integer
reqAmt Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
100
                -- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee
                -- We choose to multiply 100 rather than divide by 100 to make the calculation
                -- easier to manage. At the end of the calculation we then use % 100 to perform our division
                -- and round up.
                enoughCollateral :: Bool
enoughCollateral = Lovelace
totalCollateralLovelace Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
* Lovelace
100 Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Lovelace
requiredCollateral
                Lovelace Integer
amt = Lovelace
totalCollateralLovelace Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
* Lovelace
100 Lovelace -> Lovelace -> Lovelace
forall a. Num a => a -> a -> a
- Lovelace
requiredCollateral
                returnCollateral :: Lovelace
returnCollateral = Coin -> Lovelace
fromShelleyLovelace (Coin -> Lovelace) -> (Rational -> Coin) -> Rational -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Coin
Ledger.rationalToCoinViaFloor (Rational -> Lovelace) -> Rational -> Lovelace
forall a b. (a -> b) -> a -> b
$ Integer
amt Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
100

            case (TxReturnCollateral CtxTx era
txReturnCollateral, TxTotalCollateral era
txTotalCollateral) of
              (rc :: TxReturnCollateral CtxTx era
rc@TxReturnCollateral{}, tc :: TxTotalCollateral era
tc@TxTotalCollateral{}) ->
                (TxReturnCollateral CtxTx era
rc, TxTotalCollateral era
tc)
              (rc :: TxReturnCollateral CtxTx era
rc@TxReturnCollateral{}, TxTotalCollateral era
TxTotalCollateralNone) ->
                (TxReturnCollateral CtxTx era
rc, TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone)
              (TxReturnCollateral CtxTx era
TxReturnCollateralNone, tc :: TxTotalCollateral era
tc@TxTotalCollateral{}) ->
                (TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone, TxTotalCollateral era
tc)
              (TxReturnCollateral CtxTx era
TxReturnCollateralNone, TxTotalCollateral era
TxTotalCollateralNone) ->
                if Bool
enoughCollateral
                then
                  ( TxTotalAndReturnCollateralSupportedInEra era
-> TxOut CtxTx era -> TxReturnCollateral CtxTx era
forall era ctx.
TxTotalAndReturnCollateralSupportedInEra era
-> TxOut ctx era -> TxReturnCollateral ctx era
TxReturnCollateral
                      TxTotalAndReturnCollateralSupportedInEra era
retColSup
                      (AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
cAddr (Lovelace -> TxOutValue era
forall era. IsCardanoEra era => Lovelace -> TxOutValue era
lovelaceToTxOutValue Lovelace
returnCollateral) TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone)
                  , TxTotalCollateral era
totalCollateral
                  )
                else (TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone, TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone)

   era :: ShelleyBasedEra era
   era :: ShelleyBasedEra era
era = ShelleyBasedEra era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra

   era' :: CardanoEra era
   era' :: CardanoEra era
era' = CardanoEra era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra

   -- In the event of spending the exact amount of lovelace in
   -- the specified input(s), this function excludes the change
   -- output. Note that this does not save any fees because by default
   -- the fee calculation includes a change address for simplicity and
   -- we make no attempt to recalculate the tx fee without a change address.
   accountForNoChange :: TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era]
   accountForNoChange :: TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era]
accountForNoChange change :: TxOut CtxTx era
change@(TxOut AddressInEra era
_ TxOutValue era
balance TxOutDatum CtxTx era
_ ReferenceScript era
_) [TxOut CtxTx era]
rest =
     case TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
balance of
       Lovelace Integer
0 -> [TxOut CtxTx era]
rest
       -- We append change at the end so a client can predict the indexes
       -- of the outputs
       Lovelace
_ -> [TxOut CtxTx era]
rest [TxOut CtxTx era] -> [TxOut CtxTx era] -> [TxOut CtxTx era]
forall a. [a] -> [a] -> [a]
++ [TxOut CtxTx era
change]

   balanceCheck :: TxOutValue era -> Either TxBodyErrorAutoBalance ()
   balanceCheck :: TxOutValue era -> Either TxBodyErrorAutoBalance ()
balanceCheck TxOutValue era
balance
    | TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
balance Lovelace -> Lovelace -> Bool
forall a. Eq a => a -> a -> Bool
== Lovelace
0 = () -> Either TxBodyErrorAutoBalance ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
balance Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
< Lovelace
0 =
        TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left (TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ())
-> (Lovelace -> TxBodyErrorAutoBalance)
-> Lovelace
-> Either TxBodyErrorAutoBalance ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lovelace -> TxBodyErrorAutoBalance
TxBodyErrorAdaBalanceNegative (Lovelace -> Either TxBodyErrorAutoBalance ())
-> Lovelace -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
balance
    | Bool
otherwise =
        case TxOut CtxTx era
-> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
checkMinUTxOValue (AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
changeaddr TxOutValue era
balance TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone) ProtocolParameters
pparams of
          Left (TxBodyErrorMinUTxONotMet TxOutInAnyEra
txOutAny Lovelace
minUTxO) ->
            TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left (TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ())
-> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ TxOutInAnyEra -> Lovelace -> Lovelace -> TxBodyErrorAutoBalance
TxBodyErrorAdaBalanceTooSmall TxOutInAnyEra
txOutAny Lovelace
minUTxO (TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
balance)
          Left TxBodyErrorAutoBalance
err -> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
err
          Right ()
_ -> () -> Either TxBodyErrorAutoBalance ()
forall a b. b -> Either a b
Right ()

   checkMinUTxOValue
     :: TxOut CtxTx era
     -> ProtocolParameters
     -> Either TxBodyErrorAutoBalance ()
   checkMinUTxOValue :: TxOut CtxTx era
-> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
checkMinUTxOValue txout :: TxOut CtxTx era
txout@(TxOut AddressInEra era
_ TxOutValue era
v TxOutDatum CtxTx era
_ ReferenceScript era
_) ProtocolParameters
pparams' = do
     Value
minUTxO  <- (MinimumUTxOError -> TxBodyErrorAutoBalance)
-> Either MinimumUTxOError Value
-> Either TxBodyErrorAutoBalance Value
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MinimumUTxOError -> TxBodyErrorAutoBalance
TxBodyErrorMinUTxOMissingPParams
                   (Either MinimumUTxOError Value
 -> Either TxBodyErrorAutoBalance Value)
-> Either MinimumUTxOError Value
-> Either TxBodyErrorAutoBalance Value
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> TxOut CtxTx era
-> ProtocolParameters
-> Either MinimumUTxOError Value
forall era.
ShelleyBasedEra era
-> TxOut CtxTx era
-> ProtocolParameters
-> Either MinimumUTxOError Value
calculateMinimumUTxO ShelleyBasedEra era
era TxOut CtxTx era
txout ProtocolParameters
pparams'
     if TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
v Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Value -> Lovelace
selectLovelace Value
minUTxO
     then () -> Either TxBodyErrorAutoBalance ()
forall a b. b -> Either a b
Right ()
     else TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left (TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ())
-> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ TxOutInAnyEra -> Lovelace -> TxBodyErrorAutoBalance
TxBodyErrorMinUTxONotMet
                   (TxOut CtxTx era -> TxOutInAnyEra
forall era. IsCardanoEra era => TxOut CtxTx era -> TxOutInAnyEra
txOutInAnyEra TxOut CtxTx era
txout)
                   (Value -> Lovelace
selectLovelace Value
minUTxO)

substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits
                         -> TxBodyContent BuildTx era
                         -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
substituteExecutionUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap =
    (forall witctx.
 ScriptWitnessIndex
 -> ScriptWitness witctx era
 -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-> TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
forall era.
(forall witctx.
 ScriptWitnessIndex
 -> ScriptWitness witctx era
 -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-> TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
mapTxScriptWitnesses forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
forall witctx era.
ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
f
  where
    f :: ScriptWitnessIndex
      -> ScriptWitness witctx era
      -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
    f :: ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
f ScriptWitnessIndex
_   wit :: ScriptWitness witctx era
wit@SimpleScriptWitness{} = ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
forall a b. b -> Either a b
Right ScriptWitness witctx era
wit
    f ScriptWitnessIndex
idx (PlutusScriptWitness ScriptLanguageInEra lang era
langInEra PlutusScriptVersion lang
version PlutusScriptOrReferenceInput lang
script ScriptDatum witctx
datum ScriptData
redeemer ExecutionUnits
_) =
      case ScriptWitnessIndex
-> Map ScriptWitnessIndex ExecutionUnits -> Maybe ExecutionUnits
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptWitnessIndex
idx Map ScriptWitnessIndex ExecutionUnits
exUnitsMap of
        Maybe ExecutionUnits
Nothing ->
          TxBodyErrorAutoBalance
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
forall a b. a -> Either a b
Left (TxBodyErrorAutoBalance
 -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-> TxBodyErrorAutoBalance
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
forall a b. (a -> b) -> a -> b
$ ScriptWitnessIndex
-> Map ScriptWitnessIndex ExecutionUnits -> TxBodyErrorAutoBalance
TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap ScriptWitnessIndex
idx Map ScriptWitnessIndex ExecutionUnits
exUnitsMap
        Just ExecutionUnits
exunits -> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
forall a b. b -> Either a b
Right (ScriptWitness witctx era
 -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
forall a b. (a -> b) -> a -> b
$ ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> ScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
forall lang era witctx.
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScriptOrReferenceInput lang
-> ScriptDatum witctx
-> ScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
PlutusScriptWitness ScriptLanguageInEra lang era
langInEra PlutusScriptVersion lang
version PlutusScriptOrReferenceInput lang
script
                                            ScriptDatum witctx
datum ScriptData
redeemer ExecutionUnits
exunits
mapTxScriptWitnesses
  :: forall era.
      (forall witctx. ScriptWitnessIndex
                   -> ScriptWitness witctx era
                   -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
  -> TxBodyContent BuildTx era
  -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
mapTxScriptWitnesses :: (forall witctx.
 ScriptWitnessIndex
 -> ScriptWitness witctx era
 -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-> TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
mapTxScriptWitnesses forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
f txbodycontent :: TxBodyContent BuildTx era
txbodycontent@TxBodyContent {
                         TxIns BuildTx era
txIns :: TxIns BuildTx era
txIns :: forall build era. TxBodyContent build era -> TxIns build era
txIns,
                         TxWithdrawals BuildTx era
txWithdrawals :: TxWithdrawals BuildTx era
txWithdrawals :: forall build era.
TxBodyContent build era -> TxWithdrawals build era
txWithdrawals,
                         TxCertificates BuildTx era
txCertificates :: TxCertificates BuildTx era
txCertificates :: forall build era.
TxBodyContent build era -> TxCertificates build era
txCertificates,
                         TxMintValue BuildTx era
txMintValue :: forall build era. TxBodyContent build era -> TxMintValue build era
txMintValue :: TxMintValue BuildTx era
txMintValue
                       } = do
    TxIns BuildTx era
mappedTxIns <- TxIns BuildTx era
-> Either TxBodyErrorAutoBalance (TxIns BuildTx era)
mapScriptWitnessesTxIns TxIns BuildTx era
txIns
    TxWithdrawals BuildTx era
mappedWithdrawals <- TxWithdrawals BuildTx era
-> Either TxBodyErrorAutoBalance (TxWithdrawals BuildTx era)
mapScriptWitnessesWithdrawals TxWithdrawals BuildTx era
txWithdrawals
    TxMintValue BuildTx era
mappedMintedVals <- TxMintValue BuildTx era
-> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era)
mapScriptWitnessesMinting TxMintValue BuildTx era
txMintValue
    TxCertificates BuildTx era
mappedTxCertificates <- TxCertificates BuildTx era
-> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era)
mapScriptWitnessesCertificates TxCertificates BuildTx era
txCertificates

    TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
forall a b. b -> Either a b
Right (TxBodyContent BuildTx era
 -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era))
-> TxBodyContent BuildTx era
-> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era)
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era
txbodycontent
      { txIns :: TxIns BuildTx era
txIns = TxIns BuildTx era
mappedTxIns
      , txMintValue :: TxMintValue BuildTx era
txMintValue = TxMintValue BuildTx era
mappedMintedVals
      , txCertificates :: TxCertificates BuildTx era
txCertificates = TxCertificates BuildTx era
mappedTxCertificates
      , txWithdrawals :: TxWithdrawals BuildTx era
txWithdrawals = TxWithdrawals BuildTx era
mappedWithdrawals
      }
  where
    mapScriptWitnessesTxIns
      :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
      -> Either TxBodyErrorAutoBalance [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
    mapScriptWitnessesTxIns :: TxIns BuildTx era
-> Either TxBodyErrorAutoBalance (TxIns BuildTx era)
mapScriptWitnessesTxIns TxIns BuildTx era
txins  =
      let mappedScriptWitnesses
            :: [ ( TxIn
                 , Either TxBodyErrorAutoBalance (BuildTxWith BuildTx (Witness WitCtxTxIn era))
                 )
               ]
          mappedScriptWitnesses :: [(TxIn,
  Either
    TxBodyErrorAutoBalance
    (BuildTxWith BuildTx (Witness WitCtxTxIn era)))]
mappedScriptWitnesses =
            [ (TxIn
txin, Witness WitCtxTxIn era
-> BuildTxWith BuildTx (Witness WitCtxTxIn era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn era
 -> BuildTxWith BuildTx (Witness WitCtxTxIn era))
-> Either TxBodyErrorAutoBalance (Witness WitCtxTxIn era)
-> Either
     TxBodyErrorAutoBalance
     (BuildTxWith BuildTx (Witness WitCtxTxIn era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either TxBodyErrorAutoBalance (Witness WitCtxTxIn era)
wit')
              -- The tx ins are indexed in the map order by txid
            | (Word
ix, (TxIn
txin, BuildTxWith Witness WitCtxTxIn era
wit)) <- [Word]
-> TxIns BuildTx era
-> [(Word, (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0..] (TxIns BuildTx era -> TxIns BuildTx era
forall v. [(TxIn, v)] -> [(TxIn, v)]
orderTxIns TxIns BuildTx era
txins)
            , let wit' :: Either TxBodyErrorAutoBalance (Witness WitCtxTxIn era)
wit' = case Witness WitCtxTxIn era
wit of
                           KeyWitness{}              -> Witness WitCtxTxIn era
-> Either TxBodyErrorAutoBalance (Witness WitCtxTxIn era)
forall a b. b -> Either a b
Right Witness WitCtxTxIn era
wit
                           ScriptWitness ScriptWitnessInCtx WitCtxTxIn
ctx ScriptWitness WitCtxTxIn era
witness -> ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn era -> Witness WitCtxTxIn era
forall witctx era.
ScriptWitnessInCtx witctx
-> ScriptWitness witctx era -> Witness witctx era
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
ctx (ScriptWitness WitCtxTxIn era -> Witness WitCtxTxIn era)
-> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxTxIn era)
-> Either TxBodyErrorAutoBalance (Witness WitCtxTxIn era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxTxIn era)
witness'
                             where
                               witness' :: Either TxBodyErrorAutoBalance (ScriptWitness WitCtxTxIn era)
witness' = ScriptWitnessIndex
-> ScriptWitness WitCtxTxIn era
-> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxTxIn era)
forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
f (Word -> ScriptWitnessIndex
ScriptWitnessIndexTxIn Word
ix) ScriptWitness WitCtxTxIn era
witness
            ]
      in ((TxIn,
  Either
    TxBodyErrorAutoBalance
    (BuildTxWith BuildTx (Witness WitCtxTxIn era)))
 -> Either
      TxBodyErrorAutoBalance
      (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)))
-> [(TxIn,
     Either
       TxBodyErrorAutoBalance
       (BuildTxWith BuildTx (Witness WitCtxTxIn era)))]
-> Either TxBodyErrorAutoBalance (TxIns BuildTx era)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ( \(TxIn
txIn, Either
  TxBodyErrorAutoBalance
  (BuildTxWith BuildTx (Witness WitCtxTxIn era))
eWitness) ->
                      case Either
  TxBodyErrorAutoBalance
  (BuildTxWith BuildTx (Witness WitCtxTxIn era))
eWitness of
                        Left TxBodyErrorAutoBalance
e -> TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance
     (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
e
                        Right BuildTxWith BuildTx (Witness WitCtxTxIn era)
wit -> (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))
-> Either
     TxBodyErrorAutoBalance
     (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))
forall a b. b -> Either a b
Right (TxIn
txIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)
wit)
                  ) [(TxIn,
  Either
    TxBodyErrorAutoBalance
    (BuildTxWith BuildTx (Witness WitCtxTxIn era)))]
mappedScriptWitnesses

    mapScriptWitnessesWithdrawals
      :: TxWithdrawals BuildTx era
      -> Either TxBodyErrorAutoBalance (TxWithdrawals BuildTx era)
    mapScriptWitnessesWithdrawals :: TxWithdrawals BuildTx era
-> Either TxBodyErrorAutoBalance (TxWithdrawals BuildTx era)
mapScriptWitnessesWithdrawals  TxWithdrawals BuildTx era
TxWithdrawalsNone = TxWithdrawals BuildTx era
-> Either TxBodyErrorAutoBalance (TxWithdrawals BuildTx era)
forall a b. b -> Either a b
Right TxWithdrawals BuildTx era
forall build era. TxWithdrawals build era
TxWithdrawalsNone
    mapScriptWitnessesWithdrawals (TxWithdrawals WithdrawalsSupportedInEra era
supported [(StakeAddress, Lovelace,
  BuildTxWith BuildTx (Witness WitCtxStake era))]
withdrawals) =
      let mappedWithdrawals
            :: [( StakeAddress
                , Lovelace
                , Either TxBodyErrorAutoBalance (BuildTxWith BuildTx (Witness WitCtxStake era))
                )]
          mappedWithdrawals :: [(StakeAddress, Lovelace,
  Either
    TxBodyErrorAutoBalance
    (BuildTxWith BuildTx (Witness WitCtxStake era)))]
mappedWithdrawals =
              [ (StakeAddress
addr, Lovelace
withdrawal, Witness WitCtxStake era
-> BuildTxWith BuildTx (Witness WitCtxStake era)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxStake era
 -> BuildTxWith BuildTx (Witness WitCtxStake era))
-> Either TxBodyErrorAutoBalance (Witness WitCtxStake era)
-> Either
     TxBodyErrorAutoBalance
     (BuildTxWith BuildTx (Witness WitCtxStake era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either TxBodyErrorAutoBalance (Witness WitCtxStake era)
mappedWitness)
                -- The withdrawals are indexed in the map order by stake credential
              | (Word
ix, (StakeAddress
addr, Lovelace
withdrawal, BuildTxWith Witness WitCtxStake era
wit)) <- [Word]
-> [(StakeAddress, Lovelace,
     BuildTxWith BuildTx (Witness WitCtxStake era))]
-> [(Word,
     (StakeAddress, Lovelace,
      BuildTxWith BuildTx (Witness WitCtxStake era)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0..] ([(StakeAddress, Lovelace,
  BuildTxWith BuildTx (Witness WitCtxStake era))]
-> [(StakeAddress, Lovelace,
     BuildTxWith BuildTx (Witness WitCtxStake era))]
forall x v. [(StakeAddress, x, v)] -> [(StakeAddress, x, v)]
orderStakeAddrs [(StakeAddress, Lovelace,
  BuildTxWith BuildTx (Witness WitCtxStake era))]
withdrawals)
              , let mappedWitness :: Either TxBodyErrorAutoBalance (Witness WitCtxStake era)
mappedWitness = (ScriptWitness WitCtxStake era
 -> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxStake era))
-> Witness WitCtxStake era
-> Either TxBodyErrorAutoBalance (Witness WitCtxStake era)
forall witctx.
(ScriptWitness witctx era
 -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-> Witness witctx era
-> Either TxBodyErrorAutoBalance (Witness witctx era)
adjustWitness (ScriptWitnessIndex
-> ScriptWitness WitCtxStake era
-> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxStake era)
forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
f (Word -> ScriptWitnessIndex
ScriptWitnessIndexWithdrawal Word
ix)) Witness WitCtxStake era
wit
              ]
      in WithdrawalsSupportedInEra era
-> [(StakeAddress, Lovelace,
     BuildTxWith BuildTx (Witness WitCtxStake era))]
-> TxWithdrawals BuildTx era
forall era build.
WithdrawalsSupportedInEra era
-> [(StakeAddress, Lovelace,
     BuildTxWith build (Witness WitCtxStake era))]
-> TxWithdrawals build era
TxWithdrawals WithdrawalsSupportedInEra era
supported
           ([(StakeAddress, Lovelace,
   BuildTxWith BuildTx (Witness WitCtxStake era))]
 -> TxWithdrawals BuildTx era)
-> Either
     TxBodyErrorAutoBalance
     [(StakeAddress, Lovelace,
       BuildTxWith BuildTx (Witness WitCtxStake era))]
-> Either TxBodyErrorAutoBalance (TxWithdrawals BuildTx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((StakeAddress, Lovelace,
  Either
    TxBodyErrorAutoBalance
    (BuildTxWith BuildTx (Witness WitCtxStake era)))
 -> Either
      TxBodyErrorAutoBalance
      (StakeAddress, Lovelace,
       BuildTxWith BuildTx (Witness WitCtxStake era)))
-> [(StakeAddress, Lovelace,
     Either
       TxBodyErrorAutoBalance
       (BuildTxWith BuildTx (Witness WitCtxStake era)))]
-> Either
     TxBodyErrorAutoBalance
     [(StakeAddress, Lovelace,
       BuildTxWith BuildTx (Witness WitCtxStake era))]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ( \(StakeAddress
sAddr, Lovelace
ll, Either
  TxBodyErrorAutoBalance
  (BuildTxWith BuildTx (Witness WitCtxStake era))
eWitness) ->
                            case Either
  TxBodyErrorAutoBalance
  (BuildTxWith BuildTx (Witness WitCtxStake era))
eWitness of
                              Left TxBodyErrorAutoBalance
e -> TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance
     (StakeAddress, Lovelace,
      BuildTxWith BuildTx (Witness WitCtxStake era))
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
e
                              Right BuildTxWith BuildTx (Witness WitCtxStake era)
wit -> (StakeAddress, Lovelace,
 BuildTxWith BuildTx (Witness WitCtxStake era))
-> Either
     TxBodyErrorAutoBalance
     (StakeAddress, Lovelace,
      BuildTxWith BuildTx (Witness WitCtxStake era))
forall a b. b -> Either a b
Right (StakeAddress
sAddr, Lovelace
ll, BuildTxWith BuildTx (Witness WitCtxStake era)
wit)
                        ) [(StakeAddress, Lovelace,
  Either
    TxBodyErrorAutoBalance
    (BuildTxWith BuildTx (Witness WitCtxStake era)))]
mappedWithdrawals
      where
        adjustWitness
          :: (ScriptWitness witctx era -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
          -> Witness witctx era
          -> Either TxBodyErrorAutoBalance (Witness witctx era)
        adjustWitness :: (ScriptWitness witctx era
 -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era))
-> Witness witctx era
-> Either TxBodyErrorAutoBalance (Witness witctx era)
adjustWitness ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
_ (KeyWitness KeyWitnessInCtx witctx
ctx) = Witness witctx era
-> Either TxBodyErrorAutoBalance (Witness witctx era)
forall a b. b -> Either a b
Right (Witness witctx era
 -> Either TxBodyErrorAutoBalance (Witness witctx era))
-> Witness witctx era
-> Either TxBodyErrorAutoBalance (Witness witctx era)
forall a b. (a -> b) -> a -> b
$ KeyWitnessInCtx witctx -> Witness witctx era
forall witctx era. KeyWitnessInCtx witctx -> Witness witctx era
KeyWitness KeyWitnessInCtx witctx
ctx
        adjustWitness ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
g (ScriptWitness ScriptWitnessInCtx witctx
ctx ScriptWitness witctx era
witness') = ScriptWitnessInCtx witctx
-> ScriptWitness witctx era -> Witness witctx era
forall witctx era.
ScriptWitnessInCtx witctx
-> ScriptWitness witctx era -> Witness witctx era
ScriptWitness ScriptWitnessInCtx witctx
ctx (ScriptWitness witctx era -> Witness witctx era)
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
-> Either TxBodyErrorAutoBalance (Witness witctx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
g ScriptWitness witctx era
witness'

    mapScriptWitnessesCertificates
      :: TxCertificates BuildTx era
      -> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era)
    mapScriptWitnessesCertificates :: TxCertificates BuildTx era
-> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era)
mapScriptWitnessesCertificates  TxCertificates BuildTx era
TxCertificatesNone = TxCertificates BuildTx era
-> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era)
forall a b. b -> Either a b
Right TxCertificates BuildTx era
forall build era. TxCertificates build era
TxCertificatesNone
    mapScriptWitnessesCertificates (TxCertificates CertificatesSupportedInEra era
supported [Certificate]
certs
                                                   (BuildTxWith Map StakeCredential (Witness WitCtxStake era)
witnesses)) =
      let mappedScriptWitnesses
           :: [(StakeCredential, Either TxBodyErrorAutoBalance (Witness WitCtxStake era))]
          mappedScriptWitnesses :: [(StakeCredential,
  Either TxBodyErrorAutoBalance (Witness WitCtxStake era))]
mappedScriptWitnesses =
              [ (StakeCredential
stakecred, ScriptWitnessInCtx WitCtxStake
-> ScriptWitness WitCtxStake era -> Witness WitCtxStake era
forall witctx era.
ScriptWitnessInCtx witctx
-> ScriptWitness witctx era -> Witness witctx era
ScriptWitness ScriptWitnessInCtx WitCtxStake
ctx (ScriptWitness WitCtxStake era -> Witness WitCtxStake era)
-> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxStake era)
-> Either TxBodyErrorAutoBalance (Witness WitCtxStake era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxStake era)
witness')
                -- The certs are indexed in list order
              | (Word
ix, Certificate
cert) <- [Word] -> [Certificate] -> [(Word, Certificate)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0..] [Certificate]
certs
              , StakeCredential
stakecred  <- Maybe StakeCredential -> [StakeCredential]
forall a. Maybe a -> [a]
maybeToList (Certificate -> Maybe StakeCredential
selectStakeCredential Certificate
cert)
              , ScriptWitness ScriptWitnessInCtx WitCtxStake
ctx ScriptWitness WitCtxStake era
witness
                           <- Maybe (Witness WitCtxStake era) -> [Witness WitCtxStake era]
forall a. Maybe a -> [a]
maybeToList (StakeCredential
-> Map StakeCredential (Witness WitCtxStake era)
-> Maybe (Witness WitCtxStake era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup StakeCredential
stakecred Map StakeCredential (Witness WitCtxStake era)
witnesses)
              , let witness' :: Either TxBodyErrorAutoBalance (ScriptWitness WitCtxStake era)
witness' = ScriptWitnessIndex
-> ScriptWitness WitCtxStake era
-> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxStake era)
forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
f (Word -> ScriptWitnessIndex
ScriptWitnessIndexCertificate Word
ix) ScriptWitness WitCtxStake era
witness
              ]
      in CertificatesSupportedInEra era
-> [Certificate]
-> BuildTxWith
     BuildTx (Map StakeCredential (Witness WitCtxStake era))
-> TxCertificates BuildTx era
forall era build.
CertificatesSupportedInEra era
-> [Certificate]
-> BuildTxWith
     build (Map StakeCredential (Witness WitCtxStake era))
-> TxCertificates build era
TxCertificates CertificatesSupportedInEra era
supported [Certificate]
certs (BuildTxWith
   BuildTx (Map StakeCredential (Witness WitCtxStake era))
 -> TxCertificates BuildTx era)
-> ([(StakeCredential, Witness WitCtxStake era)]
    -> BuildTxWith
         BuildTx (Map StakeCredential (Witness WitCtxStake era)))
-> [(StakeCredential, Witness WitCtxStake era)]
-> TxCertificates BuildTx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map StakeCredential (Witness WitCtxStake era)
-> BuildTxWith
     BuildTx (Map StakeCredential (Witness WitCtxStake era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Map StakeCredential (Witness WitCtxStake era)
 -> BuildTxWith
      BuildTx (Map StakeCredential (Witness WitCtxStake era)))
-> ([(StakeCredential, Witness WitCtxStake era)]
    -> Map StakeCredential (Witness WitCtxStake era))
-> [(StakeCredential, Witness WitCtxStake era)]
-> BuildTxWith
     BuildTx (Map StakeCredential (Witness WitCtxStake era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(StakeCredential, Witness WitCtxStake era)]
-> Map StakeCredential (Witness WitCtxStake era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(StakeCredential, Witness WitCtxStake era)]
 -> TxCertificates BuildTx era)
-> Either
     TxBodyErrorAutoBalance [(StakeCredential, Witness WitCtxStake era)]
-> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
           ((StakeCredential,
  Either TxBodyErrorAutoBalance (Witness WitCtxStake era))
 -> Either
      TxBodyErrorAutoBalance (StakeCredential, Witness WitCtxStake era))
-> [(StakeCredential,
     Either TxBodyErrorAutoBalance (Witness WitCtxStake era))]
-> Either
     TxBodyErrorAutoBalance [(StakeCredential, Witness WitCtxStake era)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ( \(StakeCredential
sCred, Either TxBodyErrorAutoBalance (Witness WitCtxStake era)
eScriptWitness) ->
                        case Either TxBodyErrorAutoBalance (Witness WitCtxStake era)
eScriptWitness of
                          Left TxBodyErrorAutoBalance
e -> TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance (StakeCredential, Witness WitCtxStake era)
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
e
                          Right Witness WitCtxStake era
wit -> (StakeCredential, Witness WitCtxStake era)
-> Either
     TxBodyErrorAutoBalance (StakeCredential, Witness WitCtxStake era)
forall a b. b -> Either a b
Right (StakeCredential
sCred, Witness WitCtxStake era
wit)
                    ) [(StakeCredential,
  Either TxBodyErrorAutoBalance (Witness WitCtxStake era))]
mappedScriptWitnesses

    selectStakeCredential :: Certificate -> Maybe StakeCredential
selectStakeCredential Certificate
cert =
      case Certificate
cert of
        StakeAddressDeregistrationCertificate StakeCredential
stakecred   -> StakeCredential -> Maybe StakeCredential
forall a. a -> Maybe a
Just StakeCredential
stakecred
        StakeAddressDelegationCertificate     StakeCredential
stakecred PoolId
_ -> StakeCredential -> Maybe StakeCredential
forall a. a -> Maybe a
Just StakeCredential
stakecred
        Certificate
_                                                 -> Maybe StakeCredential
forall a. Maybe a
Nothing

    mapScriptWitnessesMinting
      :: TxMintValue BuildTx era
      -> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era)
    mapScriptWitnessesMinting :: TxMintValue BuildTx era
-> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era)
mapScriptWitnessesMinting  TxMintValue BuildTx era
TxMintNone = TxMintValue BuildTx era
-> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era)
forall a b. b -> Either a b
Right TxMintValue BuildTx era
forall build era. TxMintValue build era
TxMintNone
    mapScriptWitnessesMinting (TxMintValue MultiAssetSupportedInEra era
supported Value
value
                                           (BuildTxWith Map PolicyId (ScriptWitness WitCtxMint era)
witnesses)) =
      --TxMintValue supported value $ BuildTxWith $ Map.fromList
      let mappedScriptWitnesses
            :: [(PolicyId, Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era))]
          mappedScriptWitnesses :: [(PolicyId,
  Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era))]
mappedScriptWitnesses =
            [ (PolicyId
policyid, Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era)
witness')
              -- The minting policies are indexed in policy id order in the value
            | let ValueNestedRep [ValueNestedBundle]
bundle = Value -> ValueNestedRep
valueToNestedRep Value
value
            , (Word
ix, ValueNestedBundle PolicyId
policyid Map AssetName Quantity
_) <- [Word] -> [ValueNestedBundle] -> [(Word, ValueNestedBundle)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0..] [ValueNestedBundle]
bundle
            , ScriptWitness WitCtxMint era
witness <- Maybe (ScriptWitness WitCtxMint era)
-> [ScriptWitness WitCtxMint era]
forall a. Maybe a -> [a]
maybeToList (PolicyId
-> Map PolicyId (ScriptWitness WitCtxMint era)
-> Maybe (ScriptWitness WitCtxMint era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PolicyId
policyid Map PolicyId (ScriptWitness WitCtxMint era)
witnesses)
            , let witness' :: Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era)
witness' = ScriptWitnessIndex
-> ScriptWitness WitCtxMint era
-> Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era)
forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)
f (Word -> ScriptWitnessIndex
ScriptWitnessIndexMint Word
ix) ScriptWitness WitCtxMint era
witness
            ]
      in do [(PolicyId, ScriptWitness WitCtxMint era)]
final <- ((PolicyId,
  Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era))
 -> Either
      TxBodyErrorAutoBalance (PolicyId, ScriptWitness WitCtxMint era))
-> [(PolicyId,
     Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era))]
-> Either
     TxBodyErrorAutoBalance [(PolicyId, ScriptWitness WitCtxMint era)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ( \(PolicyId
pid, Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era)
eScriptWitness) ->
                                   case Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era)
eScriptWitness of
                                     Left TxBodyErrorAutoBalance
e -> TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance (PolicyId, ScriptWitness WitCtxMint era)
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
e
                                     Right ScriptWitness WitCtxMint era
wit -> (PolicyId, ScriptWitness WitCtxMint era)
-> Either
     TxBodyErrorAutoBalance (PolicyId, ScriptWitness WitCtxMint era)
forall a b. b -> Either a b
Right (PolicyId
pid, ScriptWitness WitCtxMint era
wit)
                              ) [(PolicyId,
  Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era))]
mappedScriptWitnesses
            TxMintValue BuildTx era
-> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era)
forall a b. b -> Either a b
Right (TxMintValue BuildTx era
 -> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era))
-> (Map PolicyId (ScriptWitness WitCtxMint era)
    -> TxMintValue BuildTx era)
-> Map PolicyId (ScriptWitness WitCtxMint era)
-> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiAssetSupportedInEra era
-> Value
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint era))
-> TxMintValue BuildTx era
forall era build.
MultiAssetSupportedInEra era
-> Value
-> BuildTxWith build (Map PolicyId (ScriptWitness WitCtxMint era))
-> TxMintValue build era
TxMintValue MultiAssetSupportedInEra era
supported Value
value (BuildTxWith BuildTx (Map PolicyId (ScriptWitness WitCtxMint era))
 -> TxMintValue BuildTx era)
-> (Map PolicyId (ScriptWitness WitCtxMint era)
    -> BuildTxWith
         BuildTx (Map PolicyId (ScriptWitness WitCtxMint era)))
-> Map PolicyId (ScriptWitness WitCtxMint era)
-> TxMintValue BuildTx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PolicyId (ScriptWitness WitCtxMint era)
-> BuildTxWith
     BuildTx (Map PolicyId (ScriptWitness WitCtxMint era))
forall a. a -> BuildTxWith BuildTx a
BuildTxWith
              (Map PolicyId (ScriptWitness WitCtxMint era)
 -> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era))
-> Map PolicyId (ScriptWitness WitCtxMint era)
-> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era)
forall a b. (a -> b) -> a -> b
$ [(PolicyId, ScriptWitness WitCtxMint era)]
-> Map PolicyId (ScriptWitness WitCtxMint era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyId, ScriptWitness WitCtxMint era)]
final

calculateMinimumUTxO
  :: ShelleyBasedEra era
  -> TxOut CtxTx era
  -> ProtocolParameters
  -> Either MinimumUTxOError Value
calculateMinimumUTxO :: ShelleyBasedEra era
-> TxOut CtxTx era
-> ProtocolParameters
-> Either MinimumUTxOError Value
calculateMinimumUTxO ShelleyBasedEra era
era txout :: TxOut CtxTx era
txout@(TxOut AddressInEra era
_ TxOutValue era
v TxOutDatum CtxTx era
_ ReferenceScript era
_) ProtocolParameters
pparams' =
  case ShelleyBasedEra era
era of
    ShelleyBasedEra era
ShelleyBasedEraShelley -> Lovelace -> Value
lovelaceToValue (Lovelace -> Value)
-> Either MinimumUTxOError Lovelace
-> Either MinimumUTxOError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolParameters -> Either MinimumUTxOError Lovelace
getMinUTxOPreAlonzo ProtocolParameters
pparams'
    ShelleyBasedEra era
ShelleyBasedEraAllegra -> Either MinimumUTxOError Value
calcMinUTxOAllegraMary
    ShelleyBasedEra era
ShelleyBasedEraMary -> Either MinimumUTxOError Value
calcMinUTxOAllegraMary
    ShelleyBasedEra era
ShelleyBasedEraAlonzo ->
      let lTxOut :: TxOut StandardAlonzo
lTxOut = ShelleyBasedEra era -> TxOut CtxTx era -> TxOut StandardAlonzo
forall ctx era ledgerera.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut ctx era -> TxOut ledgerera
toShelleyTxOutAny ShelleyBasedEra era
era TxOut CtxTx era
txout
          babPParams :: PParams StandardAlonzo
babPParams = ProtocolParameters -> PParams StandardAlonzo
forall ledgerera. ProtocolParameters -> PParams ledgerera
toAlonzoPParams ProtocolParameters
pparams'
          minUTxO :: Coin
minUTxO = PParams StandardAlonzo -> TxOut StandardAlonzo -> Coin
forall era. CLI era => PParams era -> TxOut era -> Coin
Shelley.evaluateMinLovelaceOutput PParams StandardAlonzo
PParams StandardAlonzo
babPParams TxOut StandardAlonzo
lTxOut
          val :: Value
val = Lovelace -> Value
lovelaceToValue (Lovelace -> Value) -> Lovelace -> Value
forall a b. (a -> b) -> a -> b
$ Coin -> Lovelace
fromShelleyLovelace Coin
minUTxO
      in Value -> Either MinimumUTxOError Value
forall a b. b -> Either a b
Right Value
val
    ShelleyBasedEra era
ShelleyBasedEraBabbage ->
      let lTxOut :: TxOut StandardBabbage
lTxOut = ShelleyBasedEra era -> TxOut CtxTx era -> TxOut StandardBabbage
forall ctx era ledgerera.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut ctx era -> TxOut ledgerera
toShelleyTxOutAny ShelleyBasedEra era
era TxOut CtxTx era
txout
          babPParams :: PParams StandardBabbage
babPParams = ProtocolParameters -> PParams StandardBabbage
forall ledgerera. ProtocolParameters -> PParams ledgerera
toBabbagePParams ProtocolParameters
pparams'
          minUTxO :: Coin
minUTxO = PParams StandardBabbage -> TxOut StandardBabbage -> Coin
forall era. CLI era => PParams era -> TxOut era -> Coin
Shelley.evaluateMinLovelaceOutput PParams StandardBabbage
PParams StandardBabbage
babPParams TxOut StandardBabbage
lTxOut
          val :: Value
val = Lovelace -> Value
lovelaceToValue (Lovelace -> Value) -> Lovelace -> Value
forall a b. (a -> b) -> a -> b
$ Coin -> Lovelace
fromShelleyLovelace Coin
minUTxO
      in Value -> Either MinimumUTxOError Value
forall a b. b -> Either a b
Right Value
val
 where
   calcMinUTxOAllegraMary :: Either MinimumUTxOError Value
   calcMinUTxOAllegraMary :: Either MinimumUTxOError Value
calcMinUTxOAllegraMary = do
     let val :: Value
val = TxOutValue era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue era
v
     Lovelace
minUTxO <- ProtocolParameters -> Either MinimumUTxOError Lovelace
getMinUTxOPreAlonzo ProtocolParameters
pparams'
     Value -> Either MinimumUTxOError Value
forall a b. b -> Either a b
Right (Value -> Either MinimumUTxOError Value)
-> (Lovelace -> Value) -> Lovelace -> Either MinimumUTxOError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lovelace -> Value
lovelaceToValue (Lovelace -> Either MinimumUTxOError Value)
-> Lovelace -> Either MinimumUTxOError Value
forall a b. (a -> b) -> a -> b
$ Value -> Lovelace -> Lovelace
calcMinimumDeposit Value
val Lovelace
minUTxO

   getMinUTxOPreAlonzo
     :: ProtocolParameters -> Either MinimumUTxOError Lovelace
   getMinUTxOPreAlonzo :: ProtocolParameters -> Either MinimumUTxOError Lovelace
getMinUTxOPreAlonzo =
     Either MinimumUTxOError Lovelace
-> (Lovelace -> Either MinimumUTxOError Lovelace)
-> Maybe Lovelace
-> Either MinimumUTxOError Lovelace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (MinimumUTxOError -> Either MinimumUTxOError Lovelace
forall a b. a -> Either a b
Left MinimumUTxOError
PParamsMinUTxOMissing) Lovelace -> Either MinimumUTxOError Lovelace
forall a b. b -> Either a b
Right (Maybe Lovelace -> Either MinimumUTxOError Lovelace)
-> (ProtocolParameters -> Maybe Lovelace)
-> ProtocolParameters
-> Either MinimumUTxOError Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProtocolParameters -> Maybe Lovelace
protocolParamMinUTxOValue

data MinimumUTxOError =
    PParamsMinUTxOMissing
  deriving Int -> MinimumUTxOError -> ShowS
[MinimumUTxOError] -> ShowS
MinimumUTxOError -> [Char]
(Int -> MinimumUTxOError -> ShowS)
-> (MinimumUTxOError -> [Char])
-> ([MinimumUTxOError] -> ShowS)
-> Show MinimumUTxOError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MinimumUTxOError] -> ShowS
$cshowList :: [MinimumUTxOError] -> ShowS
show :: MinimumUTxOError -> [Char]
$cshow :: MinimumUTxOError -> [Char]
showsPrec :: Int -> MinimumUTxOError -> ShowS
$cshowsPrec :: Int -> MinimumUTxOError -> ShowS
Show

instance Error MinimumUTxOError where
  displayError :: MinimumUTxOError -> [Char]
displayError MinimumUTxOError
PParamsMinUTxOMissing =
    [Char]
"\"minUtxoValue\" field not present in protocol parameters when \
    \trying to calculate minimum UTxO value."