{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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(..),
    TransactionValidityIntervalError(..),

    -- * Transaction balance
    evaluateTransactionBalance,

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

import           Prelude

import qualified Data.Array as Array
import           Data.Bifunctor (bimap, first)
import qualified Data.ByteString as BS
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe)
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 Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.String as PP

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

import qualified Cardano.Chain.Common as Byron

import qualified Cardano.Ledger.Alonzo.Rules.Utxo as Alonzo
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.Keys as Ledger
import qualified Shelley.Spec.Ledger.API as Ledger (CLI, DCert, TxIn, Wdrl)
import qualified Shelley.Spec.Ledger.API.Wallet as Ledger (evaluateTransactionBalance,
                   evaluateTransactionFee)

import           Shelley.Spec.Ledger.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.TxWitness as Alonzo

import qualified Plutus.V1.Ledger.Api as Plutus

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

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

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

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

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

       -- | 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
  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) =
      [Char]
"The Plutus script evaluation failed: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ EvaluationError -> [Char]
forall p. Pretty p => p -> [Char]
pp EvaluationError
evalErr
    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."


-- | 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.
--
newtype TransactionValidityIntervalError =
          TransactionValidityIntervalError Consensus.PastHorizonException
  deriving Int -> TransactionValidityIntervalError -> ShowS
[TransactionValidityIntervalError] -> ShowS
TransactionValidityIntervalError -> [Char]
(Int -> TransactionValidityIntervalError -> ShowS)
-> (TransactionValidityIntervalError -> [Char])
-> ([TransactionValidityIntervalError] -> ShowS)
-> Show TransactionValidityIntervalError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TransactionValidityIntervalError] -> ShowS
$cshowList :: [TransactionValidityIntervalError] -> ShowS
show :: TransactionValidityIntervalError -> [Char]
$cshow :: TransactionValidityIntervalError -> [Char]
showsPrec :: Int -> TransactionValidityIntervalError -> ShowS
$cshowsPrec :: Int -> TransactionValidityIntervalError -> ShowS
Show

instance Error TransactionValidityIntervalError where
  displayError :: TransactionValidityIntervalError -> [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.



-- | 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 TransactionValidityIntervalError
            (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits :: EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityIntervalError
     (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
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
      ShelleyTx ShelleyBasedEra era
era Tx (ShelleyLedgerEra era)
tx' ->
        case ShelleyBasedEra era
era of
          ShelleyBasedEra era
ShelleyBasedEraShelley -> Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
          ShelleyBasedEra era
ShelleyBasedEraAllegra -> Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
          ShelleyBasedEra era
ShelleyBasedEraMary    -> Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo
          ShelleyBasedEra era
ShelleyBasedEraAlonzo  -> ShelleyBasedEra era
-> Tx StandardAlonzo
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall ledgerera.
(ShelleyLedgerEra era ~ ledgerera, ledgerera ~ StandardAlonzo,
 LedgerEraConstraints ledgerera) =>
ShelleyBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalAlonzo ShelleyBasedEra era
era Tx StandardAlonzo
Tx (ShelleyLedgerEra era)
tx'
  where
    -- Pre-Alonzo eras do not support languages with execution unit accounting.
    evalPreAlonzo :: Either TransactionValidityIntervalError
                            (Map ScriptWitnessIndex
                                 (Either ScriptExecutionError ExecutionUnits))
    evalPreAlonzo :: Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo = Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> Either
     TransactionValidityIntervalError
     (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 TransactionValidityIntervalError
                         (Map ScriptWitnessIndex
                              (Either ScriptExecutionError ExecutionUnits))
    evalAlonzo :: ShelleyBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalAlonzo ShelleyBasedEra era
era Tx ledgerera
tx =
      case Tx StandardAlonzo
-> UTxO StandardAlonzo
-> EpochInfo (Either TransactionValidityIntervalError)
-> SystemStart
-> Array Language CostModel
-> Either
     TransactionValidityIntervalError
     (Map RdmrPtr (Either (ScriptFailure StandardCrypto) ExUnits))
forall c (m :: * -> *).
(Crypto c, Monad m) =>
Tx (AlonzoEra c)
-> UTxO (AlonzoEra c)
-> EpochInfo m
-> SystemStart
-> Array Language CostModel
-> m (Map RdmrPtr (Either (ScriptFailure c) ExUnits))
Alonzo.evaluateTransactionExecutionUnits
             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 TransactionValidityIntervalError)
toLedgerEpochInfo EraHistory mode
history)
             SystemStart
systemstart
             (Map AnyPlutusScriptVersion CostModel -> Array Language CostModel
toAlonzoCostModels (ProtocolParameters -> Map AnyPlutusScriptVersion CostModel
protocolParamCostModels ProtocolParameters
pparams))
        of Left  TransactionValidityIntervalError
err   -> TransactionValidityIntervalError
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. a -> Either a b
Left TransactionValidityIntervalError
err
           Right Map RdmrPtr (Either (ScriptFailure StandardCrypto) ExUnits)
exmap -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall a b. b -> Either a b
Right (Map RdmrPtr (Either (ScriptFailure StandardCrypto) ExUnits)
-> Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
fromLedgerScriptExUnitsMap Map RdmrPtr (Either (ScriptFailure StandardCrypto) ExUnits)
exmap)

    toLedgerEpochInfo :: EraHistory mode
                      -> EpochInfo (Either TransactionValidityIntervalError)
    toLedgerEpochInfo :: EraHistory mode
-> EpochInfo (Either TransactionValidityIntervalError)
toLedgerEpochInfo (EraHistory ConsensusMode mode
_ Interpreter xs
interpreter) =
        (forall a.
 Except PastHorizonException a
 -> Either TransactionValidityIntervalError a)
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either TransactionValidityIntervalError)
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> EpochInfo m -> EpochInfo n
hoistEpochInfo ((PastHorizonException -> TransactionValidityIntervalError)
-> Either PastHorizonException a
-> Either TransactionValidityIntervalError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PastHorizonException -> TransactionValidityIntervalError
TransactionValidityIntervalError (Either PastHorizonException a
 -> Either TransactionValidityIntervalError a)
-> (Except PastHorizonException a -> Either PastHorizonException a)
-> Except PastHorizonException a
-> Either TransactionValidityIntervalError 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 TransactionValidityIntervalError))
-> EpochInfo (Except PastHorizonException)
-> EpochInfo (Either TransactionValidityIntervalError)
forall a b. (a -> b) -> a -> b
$
          Interpreter xs -> EpochInfo (Except PastHorizonException)
forall (xs :: [*]).
Interpreter xs -> EpochInfo (Except PastHorizonException)
Consensus.interpreterToEpochInfo Interpreter xs
interpreter

    toAlonzoCostModels :: Map AnyPlutusScriptVersion CostModel
                       -> Array.Array Alonzo.Language Alonzo.CostModel
    toAlonzoCostModels :: Map AnyPlutusScriptVersion CostModel -> Array Language CostModel
toAlonzoCostModels Map AnyPlutusScriptVersion CostModel
costmodels =
      (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)
        [ (AnyPlutusScriptVersion -> Language
toAlonzoLanguage AnyPlutusScriptVersion
lang, CostModel -> CostModel
toAlonzoCostModel CostModel
costmodel)
        | (AnyPlutusScriptVersion
lang, CostModel
costmodel) <- Map AnyPlutusScriptVersion CostModel
-> [(AnyPlutusScriptVersion, CostModel)]
forall k a. Map k a -> [(k, a)]
Map.toList Map AnyPlutusScriptVersion CostModel
costmodels ]

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

    fromAlonzoScriptExecutionError :: Alonzo.ScriptFailure Ledger.StandardCrypto
                                   -> ScriptExecutionError
    fromAlonzoScriptExecutionError :: ScriptFailure StandardCrypto -> ScriptExecutionError
fromAlonzoScriptExecutionError ScriptFailure StandardCrypto
failure =
      case ScriptFailure 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.ValidationFailed EvaluationError
err -> EvaluationError -> ScriptExecutionError
ScriptErrorEvaluationFailed EvaluationError
err
        Alonzo.IncompatibleBudget ExBudget
_ -> ScriptExecutionError
ScriptErrorExecutionUnitsOverflow

        -- Some of the errors are impossible by construction, given the way we
        -- build transactions in the API:
        Alonzo.RedeemerNotNeeded RdmrPtr
rdmrPtr ->
          [Char] -> ScriptExecutionError
forall a. [Char] -> a
impossible ([Char]
"RedeemerNotNeeded " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptWitnessIndex -> [Char]
forall a. Show a => a -> [Char]
show (RdmrPtr -> ScriptWitnessIndex
fromAlonzoRdmrPtr RdmrPtr
rdmrPtr))

        Alonzo.MissingScript RdmrPtr
rdmrPtr ->
          [Char] -> ScriptExecutionError
forall a. [Char] -> a
impossible ([Char]
"MissingScript " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptWitnessIndex -> [Char]
forall a. Show a => a -> [Char]
show (RdmrPtr -> ScriptWitnessIndex
fromAlonzoRdmrPtr RdmrPtr
rdmrPtr))

    impossible :: [Char] -> a
impossible [Char]
detail = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$ [Char]
"evaluateTransactionExecutionUnits: "
                             [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"the impossible happened: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
detail


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

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 'ProtocolParameters' must provide the value for the cost per
       -- word parameter, for eras that use this parameter.
     | TxBodyErrorMissingParamCostPerWord

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

       -- | The minimum spendable UTxO threshold has not been met.
     | TxBodyErrorMinUTxONotMet
         -- ^ Offending TxOut
         TxOutInAnyEra
         -- ^ Minimum UTxO
         Lovelace

     | TxBodyErrorNonAdaAssetsUnbalanced Value
  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]
++ 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 TxBodyErrorAutoBalance
TxBodyErrorMissingParamCostPerWord =
      [Char]
"The utxoCostPerWord protocol parameter is required but missing"

  displayError (TxBodyErrorValidityInterval TransactionValidityIntervalError
err) =
      TransactionValidityIntervalError -> [Char]
forall e. Error e => e -> [Char]
displayError TransactionValidityIntervalError
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)

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
  | [(ScriptWitnessIndex, ScriptExecutionError)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ScriptWitnessIndex, ScriptExecutionError)]
scriptFailures = TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
TxBodyScriptBadScriptValidity
  | [(ScriptWitnessIndex, ScriptExecutionError)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ScriptWitnessIndex, ScriptExecutionError)]
nonScriptFailures = Map ScriptWitnessIndex ExecutionUnits
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. b -> Either a b
Right Map ScriptWitnessIndex ExecutionUnits
exUnitsMap
  | Bool
otherwise = TxBodyErrorAutoBalance
-> Either
     TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
forall a b. a -> Either a b
Left ([(ScriptWitnessIndex, ScriptExecutionError)]
-> TxBodyErrorAutoBalance
TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]
nonScriptFailures)
  where nonScriptFailures :: [(ScriptWitnessIndex, ScriptExecutionError)]
        nonScriptFailures :: [(ScriptWitnessIndex, ScriptExecutionError)]
nonScriptFailures = ((ScriptWitnessIndex, ScriptExecutionError) -> Bool)
-> [(ScriptWitnessIndex, ScriptExecutionError)]
-> [(ScriptWitnessIndex, ScriptExecutionError)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((ScriptWitnessIndex, ScriptExecutionError) -> Bool)
-> (ScriptWitnessIndex, ScriptExecutionError)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptWitnessIndex, ScriptExecutionError) -> Bool
isScriptErrorEvaluationFailed) (Map ScriptWitnessIndex ScriptExecutionError
-> [(ScriptWitnessIndex, ScriptExecutionError)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ScriptWitnessIndex ScriptExecutionError
failuresMap)
        scriptFailures :: [(ScriptWitnessIndex, ScriptExecutionError)]
        scriptFailures :: [(ScriptWitnessIndex, ScriptExecutionError)]
scriptFailures = ((ScriptWitnessIndex, ScriptExecutionError) -> Bool)
-> [(ScriptWitnessIndex, ScriptExecutionError)]
-> [(ScriptWitnessIndex, ScriptExecutionError)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ScriptWitnessIndex, ScriptExecutionError) -> Bool
isScriptErrorEvaluationFailed (Map ScriptWitnessIndex ScriptExecutionError
-> [(ScriptWitnessIndex, ScriptExecutionError)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ScriptWitnessIndex ScriptExecutionError
failuresMap)
        isScriptErrorEvaluationFailed :: (ScriptWitnessIndex, ScriptExecutionError) -> Bool
        isScriptErrorEvaluationFailed :: (ScriptWitnessIndex, ScriptExecutionError) -> Bool
isScriptErrorEvaluationFailed (ScriptWitnessIndex
_, ScriptExecutionError
e) = case ScriptExecutionError
e of
            ScriptErrorEvaluationFailed EvaluationError
_ -> Bool
True
            ScriptExecutionError
_ -> Bool
True


-- | 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 (TxBody era)
makeTransactionBodyAutoBalance :: EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> Set PoolId
-> UTxO era
-> TxBodyContent BuildTx era
-> AddressInEra era
-> Maybe Word
-> Either TxBodyErrorAutoBalance (TxBody 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 era]
txOuts =
              AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
forall era.
AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
TxOut AddressInEra era
changeaddr (Lovelace -> TxOutValue era
forall era. IsCardanoEra era => Lovelace -> TxOutValue era
lovelaceToTxOutValue Lovelace
0) TxOutDatumHash era
forall era. TxOutDatumHash era
TxOutDatumHashNone
            TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: TxBodyContent BuildTx era -> [TxOut era]
forall build era. TxBodyContent build era -> [TxOut 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 <- (TransactionValidityIntervalError -> TxBodyErrorAutoBalance)
-> Either
     TransactionValidityIntervalError
     (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 TransactionValidityIntervalError -> TxBodyErrorAutoBalance
TxBodyErrorValidityInterval (Either
   TransactionValidityIntervalError
   (Map
      ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
 -> Either
      TxBodyErrorAutoBalance
      (Map
         ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)))
-> Either
     TransactionValidityIntervalError
     (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
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall era mode.
EraInMode era mode
-> SystemStart
-> EraHistory mode
-> ProtocolParameters
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits
                      EraInMode era mode
eraInMode
                      SystemStart
systemstart EraHistory mode
history
                      ProtocolParameters
pparams
                      UTxO era
utxo
                      TxBody era
txbody0

    let aScriptValidity :: TxScriptValidity era
aScriptValidity = BuildTxWith BuildTx (TxScriptValidity era) -> TxScriptValidity era
forall a. BuildTxWith BuildTx a -> a
unBuildTxWith (TxBodyContent BuildTx era
-> BuildTxWith BuildTx (TxScriptValidity era)
forall build era.
TxBodyContent build era -> BuildTxWith build (TxScriptValidity era)
txScriptValidity TxBodyContent BuildTx era
txbodycontent)

    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 TxScriptValidity era
aScriptValidity) Map ScriptWitnessIndex ScriptExecutionError
failures Map ScriptWitnessIndex ExecutionUnits
exUnitsMap'

    let txbodycontent1 :: TxBodyContent BuildTx era
txbodycontent1 = Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx era -> TxBodyContent BuildTx era
forall era.
Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx era -> 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).
    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 era]
txOuts = AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
forall era.
AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut 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)
                                TxOutDatumHash era
forall era. TxOutDatumHash era
TxOutDatumHashNone
                        TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: TxBodyContent BuildTx era -> [TxOut era]
forall build era. TxBodyContent build era -> [TxOut era]
txOuts TxBodyContent BuildTx era
txbodycontent
               }

    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

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

    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 era -> Either TxBodyErrorAutoBalance ())
-> [TxOut era] -> Either TxBodyErrorAutoBalance ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TxOut era -> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
`checkMinUTxOValue` ProtocolParameters
pparams) ([TxOut era] -> Either TxBodyErrorAutoBalance ())
-> [TxOut era] -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era -> [TxOut era]
forall build era. TxBodyContent build era -> [TxOut 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 era]
txOuts = AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
forall era.
AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
TxOut AddressInEra era
changeaddr TxOutValue era
balance TxOutDatumHash era
forall era. TxOutDatumHash era
TxOutDatumHashNone TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: TxBodyContent BuildTx era -> [TxOut era]
forall build era. TxBodyContent build era -> [TxOut era]
txOuts TxBodyContent BuildTx era
txbodycontent
        }
    TxBody era -> Either TxBodyErrorAutoBalance (TxBody era)
forall (m :: * -> *) a. Monad m => a -> m a
return TxBody era
txbody3
 where
   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

   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. 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 era -> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
checkMinUTxOValue (AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
forall era.
AddressInEra era
-> TxOutValue era -> TxOutDatumHash era -> TxOut era
TxOut AddressInEra era
changeaddr TxOutValue era
balance TxOutDatumHash era
forall era. TxOutDatumHash era
TxOutDatumHashNone) 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 ()

   -- TODO: Move to top level and expose
   checkMinUTxOValue
     :: TxOut era
     -> ProtocolParameters
     -> Either TxBodyErrorAutoBalance ()
   checkMinUTxOValue :: TxOut era -> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
checkMinUTxOValue txout :: TxOut era
txout@(TxOut AddressInEra era
_ TxOutValue era
v TxOutDatumHash era
_) ProtocolParameters
pparams' =
     case ShelleyBasedEra era
era of
       ShelleyBasedEra era
ShelleyBasedEraAlonzo -> do
         case ProtocolParameters -> Maybe Lovelace
protocolParamUTxOCostPerWord ProtocolParameters
pparams' of
           Just (Lovelace Integer
costPerWord) -> do
             let minUTxO :: Lovelace
minUTxO = Integer -> Lovelace
Lovelace (TxOut StandardAlonzo -> Integer
forall era. Era era => TxOut era -> Integer
Alonzo.utxoEntrySize (ShelleyBasedEra era -> TxOut era -> TxOut StandardAlonzo
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut era -> TxOut ledgerera
toShelleyTxOut ShelleyBasedEra era
era TxOut era
txout) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
costPerWord)
             if TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
v Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Lovelace
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 era -> TxOutInAnyEra
forall era. IsCardanoEra era => TxOut era -> TxOutInAnyEra
txOutInAnyEra TxOut era
txout) Lovelace
minUTxO
           Maybe Lovelace
Nothing -> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
TxBodyErrorMissingParamCostPerWord
       ShelleyBasedEra era
ShelleyBasedEraMary -> TxOut era -> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
checkAllegraMaryMinUTxO TxOut era
txout ProtocolParameters
pparams'
       ShelleyBasedEra era
ShelleyBasedEraAllegra -> TxOut era -> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
checkAllegraMaryMinUTxO TxOut era
txout ProtocolParameters
pparams'
       ShelleyBasedEra era
ShelleyBasedEraShelley -> do
         let l :: Lovelace
l = TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
v
         Lovelace
minUTxO <- ProtocolParameters -> Either TxBodyErrorAutoBalance Lovelace
minUTxOHelper ProtocolParameters
pparams'
         if Lovelace
l Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Lovelace
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 era -> TxOutInAnyEra
forall era. IsCardanoEra era => TxOut era -> TxOutInAnyEra
txOutInAnyEra TxOut era
txout) Lovelace
minUTxO

   checkAllegraMaryMinUTxO
     :: TxOut era
     -> ProtocolParameters
     -> Either TxBodyErrorAutoBalance ()
   checkAllegraMaryMinUTxO :: TxOut era -> ProtocolParameters -> Either TxBodyErrorAutoBalance ()
checkAllegraMaryMinUTxO txOut :: TxOut era
txOut@(TxOut AddressInEra era
_ TxOutValue era
v TxOutDatumHash era
_) ProtocolParameters
pparams' = do
     let l :: Lovelace
l = TxOutValue era -> Lovelace
forall era. TxOutValue era -> Lovelace
txOutValueToLovelace TxOutValue era
v
         val :: Value
val = TxOutValue era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue era
v
     Lovelace
mUtxo <- ProtocolParameters -> Either TxBodyErrorAutoBalance Lovelace
minUTxOHelper ProtocolParameters
pparams'
     let minUTxO :: Lovelace
minUTxO = Value -> Lovelace -> Lovelace
calcMinimumDeposit Value
val Lovelace
mUtxo
     if Lovelace
l Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
>= Lovelace
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 era -> TxOutInAnyEra
forall era. IsCardanoEra era => TxOut era -> TxOutInAnyEra
txOutInAnyEra TxOut era
txOut) Lovelace
minUTxO

   minUTxOHelper :: ProtocolParameters
                 -> Either TxBodyErrorAutoBalance Lovelace
   minUTxOHelper :: ProtocolParameters -> Either TxBodyErrorAutoBalance Lovelace
minUTxOHelper ProtocolParameters
pparams' = case ProtocolParameters -> Maybe Lovelace
protocolParamMinUTxOValue ProtocolParameters
pparams' of
                             Just Lovelace
minUtxo -> Lovelace -> Either TxBodyErrorAutoBalance Lovelace
forall a b. b -> Either a b
Right Lovelace
minUtxo
                             Maybe Lovelace
Nothing -> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance Lovelace
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
TxBodyErrorMissingParamMinUTxO


substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits
                         -> TxBodyContent BuildTx era
                         -> TxBodyContent BuildTx era
substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx era -> TxBodyContent BuildTx era
substituteExecutionUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap =
    (forall witctx.
 ScriptWitnessIndex
 -> ScriptWitness witctx era -> ScriptWitness witctx era)
-> TxBodyContent BuildTx era -> TxBodyContent BuildTx era
forall era.
(forall witctx.
 ScriptWitnessIndex
 -> ScriptWitness witctx era -> ScriptWitness witctx era)
-> TxBodyContent BuildTx era -> TxBodyContent BuildTx era
mapTxScriptWitnesses forall witctx.
ScriptWitnessIndex
-> ScriptWitness witctx era -> ScriptWitness witctx era
forall witctx era.
ScriptWitnessIndex
-> ScriptWitness witctx era -> ScriptWitness witctx era
f
  where
    f :: ScriptWitnessIndex
      -> ScriptWitness witctx era
      -> ScriptWitness witctx era
    f :: ScriptWitnessIndex
-> ScriptWitness witctx era -> ScriptWitness witctx era
f ScriptWitnessIndex
_   wit :: ScriptWitness witctx era
wit@SimpleScriptWitness{} = ScriptWitness witctx era
wit
    f ScriptWitnessIndex
idx wit :: ScriptWitness witctx era
wit@(PlutusScriptWitness ScriptLanguageInEra lang era
langInEra PlutusScriptVersion lang
version PlutusScript 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      -> ScriptWitness witctx era
wit
        Just ExecutionUnits
exunits -> ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScript lang
-> ScriptDatum witctx
-> ScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
forall lang era witctx.
ScriptLanguageInEra lang era
-> PlutusScriptVersion lang
-> PlutusScript lang
-> ScriptDatum witctx
-> ScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
PlutusScriptWitness ScriptLanguageInEra lang era
langInEra PlutusScriptVersion lang
version PlutusScript lang
script
                                            ScriptDatum witctx
datum ScriptData
redeemer ExecutionUnits
exunits