{-# 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 Bcc.Api.Fees (

    -- * Transaction fees
    transactionFee,
    estimateTransactionFee,
    evaluateTransactionFee,
    estimateTransactionKeyWitnessCount,

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

    -- * Transaction balance
    evaluateTransactionBalance,

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

    -- * Minimum UTxO calculation
    calculateMinimumUTxO,
    MinimumUTxOError(..),
  ) 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 Prettyprinter as PP
import qualified Prettyprinter.Render.String as PP

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

import qualified Bcc.Chain.Common as Cole

import qualified Bcc.Ledger.Aurum.Rules.Utxo as Aurum
import qualified Bcc.Ledger.Coin as Ledger
import qualified Bcc.Ledger.Core as Ledger
import qualified Bcc.Ledger.Crypto as Ledger
import qualified Bcc.Ledger.Era as Ledger.Era (Crypto)
import qualified Bcc.Ledger.Keys as Ledger
import qualified Sophie.Spec.Ledger.API as Ledger (CLI, DCert, TxIn, Wdrl)
import qualified Sophie.Spec.Ledger.API.Wallet as Ledger (evaluateTransactionBalance,
                   evaluateTransactionFee)

import           Sophie.Spec.Ledger.PParams (PParams' (..))

import qualified Bcc.Ledger.Jen.Value as Jen

import qualified Bcc.Ledger.Aurum as Aurum
import qualified Bcc.Ledger.Aurum.Language as Aurum
import           Bcc.Ledger.Aurum.PParams (PParams' (..))
import qualified Bcc.Ledger.Aurum.Scripts as Aurum
import qualified Bcc.Ledger.Aurum.Tools as Aurum
import qualified Bcc.Ledger.Aurum.TxWitness as Aurum

import qualified Zerepoch.V1.Ledger.Api as Zerepoch

import qualified Shardagnostic.Consensus.HardFork.History as Consensus

import           Bcc.Api.Address
import           Bcc.Api.Certificate
import           Bcc.Api.Eras
import           Bcc.Api.Error
import           Bcc.Api.Modes
import           Bcc.Api.NetworkId
import           Bcc.Api.ProtocolParameters
import           Bcc.Api.Query
import           Bcc.Api.Script
import           Bcc.Api.Tx
import           Bcc.Api.TxBody
import           Bcc.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.
                  IsSophieBasedEra era
               => Natural -- ^ The fixed tx fee
               -> Natural -- ^ The tx fee per byte
               -> Tx era
               -> Entropic
transactionFee :: Natural -> Natural -> Tx era -> Entropic
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
       SophieTx SophieBasedEra era
_ Tx (SophieLedgerEra era)
tx' -> let x :: Integer
x = SophieBasedEra era
-> (HasField "txsize" (Tx (SophieLedgerEra era)) Integer =>
    Integer)
-> Integer
forall ledgerera a.
(SophieLedgerEra era ~ ledgerera) =>
SophieBasedEra era
-> (HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a) -> a
obtainHasField SophieBasedEra era
forall era. IsSophieBasedEra era => SophieBasedEra era
sophieBasedEra ((HasField "txsize" (Tx (SophieLedgerEra era)) Integer => Integer)
 -> Integer)
-> (HasField "txsize" (Tx (SophieLedgerEra era)) Integer =>
    Integer)
-> Integer
forall a b. (a -> b) -> a -> b
$ Tx (SophieLedgerEra era) -> Integer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"txsize" Tx (SophieLedgerEra era)
tx'
                          in Integer -> Entropic
Entropic (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 Cole txs too. Do that: fill in this case
       -- and remove the IsSophieBasedEra constraint.
       ColeTx ATxAux ByteString
_ -> case SophieBasedEra ColeEra
forall era. IsSophieBasedEra era => SophieBasedEra era
sophieBasedEra :: SophieBasedEra ColeEra of {}
 where
  obtainHasField
    :: SophieLedgerEra era ~ ledgerera
    => SophieBasedEra era
    -> ( HasField "txsize" (Ledger.Tx (SophieLedgerEra era)) Integer
        => a)
    -> a
  obtainHasField :: SophieBasedEra era
-> (HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a) -> a
obtainHasField SophieBasedEra era
SophieBasedEraSophie HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f
  obtainHasField SophieBasedEra era
SophieBasedEraEvie HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f
  obtainHasField SophieBasedEra era
SophieBasedEraJen    HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f
  obtainHasField SophieBasedEra era
SophieBasedEraAurum  HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f = a
HasField "txsize" (Tx (SophieLedgerEra era)) Integer => a
f

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


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

-- | 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.
                          IsSophieBasedEra 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 Sophie key witnesses
                       -> Int -- ^ The number of extra Cole key witnesses
                       -> Entropic
estimateTransactionFee :: NetworkId
-> Natural
-> Natural
-> Tx era
-> Int
-> Int
-> Int
-> Int
-> Entropic
estimateTransactionFee NetworkId
nw Natural
txFeeFixed Natural
txFeePerByte (SophieTx SophieBasedEra era
era Tx (SophieLedgerEra era)
tx) =
    let Entropic Integer
baseFee = Natural -> Natural -> Tx era -> Entropic
forall era.
IsSophieBasedEra era =>
Natural -> Natural -> Tx era -> Entropic
transactionFee Natural
txFeeFixed Natural
txFeePerByte (SophieBasedEra era -> Tx (SophieLedgerEra era) -> Tx era
forall era.
SophieBasedEra era -> Tx (SophieLedgerEra era) -> Tx era
SophieTx SophieBasedEra era
era Tx (SophieLedgerEra era)
tx)
     in \Int
nInputs Int
nOutputs Int
nSophieKeyWitnesses Int
nColeKeyWitnesses ->

        --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
nColeKeyWitnesses    Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeColeKeyWitnesses
                       Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nSophieKeyWitnesses  Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sizeSophieKeyWitnesses

         in Integer -> Entropic
Entropic (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
    sizeColeKeyWitnesses :: Int
sizeColeKeyWitnesses   = 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
    sizeSophieKeyWitnesses :: Int
sizeSophieKeyWitnesses = 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
Cole.mkAttributes AddrAttributes :: Maybe HDAddressPayload -> NetworkMagic -> AddrAttributes
Cole.AddrAttributes {
                      aaVKDerivationPath :: Maybe HDAddressPayload
Cole.aaVKDerivationPath = Maybe HDAddressPayload
forall a. Maybe a
Nothing,
                      aaNetworkMagic :: NetworkMagic
Cole.aaNetworkMagic     = NetworkId -> NetworkMagic
toColeNetworkMagic NetworkId
nw
                    }

--TODO: This can be made to work for Cole txs too. Do that: fill in this case
-- and remove the IsSophieBasedEra constraint.
estimateTransactionFee NetworkId
_ Natural
_ Natural
_ (ColeTx ATxAux ByteString
_) =
    case SophieBasedEra era
forall era. IsSophieBasedEra era => SophieBasedEra era
sophieBasedEra :: SophieBasedEra 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 Sophie vs Cole key sigs
--
evaluateTransactionFee :: forall era.
                          IsSophieBasedEra era
                       => ProtocolParameters
                       -> TxBody era
                       -> Word  -- ^ The number of Sophie key witnesses
                       -> Word  -- ^ The number of Cole key witnesses
                       -> Entropic
evaluateTransactionFee :: ProtocolParameters -> TxBody era -> Word -> Word -> Entropic
evaluateTransactionFee ProtocolParameters
_ TxBody era
_ Word
_ Word
colewitcount | Word
colewitcount Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
0 =
  [Char] -> Entropic
forall a. HasCallStack => [Char] -> a
error [Char]
"evaluateTransactionFee: TODO support Cole key witnesses"

evaluateTransactionFee ProtocolParameters
pparams TxBody era
txbody Word
keywitcount Word
_colewitcount =
    case [KeyWitness era] -> TxBody era -> Tx era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody era
txbody of
      ColeTx{} -> case SophieBasedEra era
forall era. IsSophieBasedEra era => SophieBasedEra era
sophieBasedEra :: SophieBasedEra era of {}
      --TODO: we could actually support Cole here, it'd be different but simpler

      SophieTx SophieBasedEra era
era Tx (SophieLedgerEra era)
tx -> SophieBasedEra era
-> (CLI (SophieLedgerEra era) => Entropic) -> Entropic
forall ledgerera a.
(SophieLedgerEra era ~ ledgerera) =>
SophieBasedEra era -> (CLI ledgerera => a) -> a
withLedgerConstraints SophieBasedEra era
era (SophieBasedEra era -> Tx (SophieLedgerEra era) -> Entropic
forall ledgerera.
(SophieLedgerEra era ~ ledgerera, CLI ledgerera) =>
SophieBasedEra era -> Tx ledgerera -> Entropic
evalSophieBasedEra SophieBasedEra era
era Tx (SophieLedgerEra era)
tx)
  where
    evalSophieBasedEra :: forall ledgerera.
                           SophieLedgerEra era ~ ledgerera
                        => Ledger.CLI ledgerera
                        => SophieBasedEra era
                        -> Ledger.Tx ledgerera
                        -> Entropic
    evalSophieBasedEra :: SophieBasedEra era -> Tx ledgerera -> Entropic
evalSophieBasedEra SophieBasedEra era
era Tx ledgerera
tx =
      Coin -> Entropic
fromSophieEntropic (Coin -> Entropic) -> Coin -> Entropic
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
          (SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
forall era.
SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
toLedgerPParams SophieBasedEra era
era ProtocolParameters
pparams)
          Tx ledgerera
tx
          Word
keywitcount

    -- Conjur up all the necessary class instances and evidence
    withLedgerConstraints
      :: SophieLedgerEra era ~ ledgerera
      => SophieBasedEra era
      -> (   Ledger.CLI ledgerera
          => a)
      -> a
    withLedgerConstraints :: SophieBasedEra era -> (CLI ledgerera => a) -> a
withLedgerConstraints SophieBasedEra era
SophieBasedEraSophie CLI ledgerera => a
f = a
CLI ledgerera => a
f
    withLedgerConstraints SophieBasedEra era
SophieBasedEraEvie CLI ledgerera => a
f = a
CLI ledgerera => a
f
    withLedgerConstraints SophieBasedEra era
SophieBasedEraJen    CLI ledgerera => a
f = a
CLI ledgerera => a
f
    withLedgerConstraints SophieBasedEra era
SophieBasedEraAurum  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 Sophie vs Cole 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, Entropic,
  BuildTxWith BuildTx (Witness WitCtxStake era))]
withdrawals
        -> [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ () | (StakeAddress
_, Entropic
_, BuildTxWith KeyWitness{}) <- [(StakeAddress, Entropic,
  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 Zerepoch 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 Zerepoch.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

       -- | An attempt was made to spend a key witnessed tx input
       -- with a script witness.
     | ScriptErrorNotZerepochWitnessedTxIn ScriptWitnessIndex
  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 Zerepoch 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 Zerepoch 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 Zerepoch 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 Zerepoch script overflows a 64bit "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"word. In a properly configured chain this should be practically "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"impossible. So this probably indicates a chain configuration problem, "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"perhaps with the values in the cost model."

  displayError (ScriptErrorNotZerepochWitnessedTxIn ScriptWitnessIndex
scriptWitness) =
      ScriptWitnessIndex -> [Char]
renderScriptWitnessIndex ScriptWitnessIndex
scriptWitness [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" is not a Zerepoch script \
      \witnessed tx input and cannot be spent using a Zerepoch script witness."

-- | The transaction validity interval is too far into the future.
--
-- Transactions with Zerepoch 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 Zerepoch 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 Bcc mainnet the time horizon is 36
-- hours beyond the current time. This effectively means we cannot submit
-- check or submit transactions that use Zerepoch 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 Zerepoch 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
      ColeTx {}                 -> Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAurum
      SophieTx SophieBasedEra era
era Tx (SophieLedgerEra era)
tx' ->
        case SophieBasedEra era
era of
          SophieBasedEra era
SophieBasedEraSophie -> Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAurum
          SophieBasedEra era
SophieBasedEraEvie -> Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAurum
          SophieBasedEra era
SophieBasedEraJen    -> Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAurum
          SophieBasedEra era
SophieBasedEraAurum  -> SophieBasedEra era
-> Tx StandardAurum
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
forall ledgerera.
(SophieLedgerEra era ~ ledgerera, ledgerera ~ StandardAurum,
 LedgerEraConstraints ledgerera) =>
SophieBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalAurum SophieBasedEra era
era Tx StandardAurum
Tx (SophieLedgerEra era)
tx'
  where
    -- Pre-Aurum eras do not support languages with execution unit accounting.
    evalPreAurum :: Either TransactionValidityIntervalError
                            (Map ScriptWitnessIndex
                                 (Either ScriptExecutionError ExecutionUnits))
    evalPreAurum :: Either
  TransactionValidityIntervalError
  (Map
     ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalPreAurum = 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

    evalAurum :: forall ledgerera.
                  SophieLedgerEra era ~ ledgerera
               => ledgerera ~ Aurum.AurumEra Ledger.StandardCrypto
               => LedgerEraConstraints ledgerera
               => SophieBasedEra era
               -> Ledger.Tx ledgerera
               -> Either TransactionValidityIntervalError
                         (Map ScriptWitnessIndex
                              (Either ScriptExecutionError ExecutionUnits))
    evalAurum :: SophieBasedEra era
-> Tx ledgerera
-> Either
     TransactionValidityIntervalError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evalAurum SophieBasedEra era
era Tx ledgerera
tx =
      case PParams StandardAurum
-> Tx StandardAurum
-> UTxO StandardAurum
-> EpochInfo (Either TransactionValidityIntervalError)
-> SystemStart
-> Array Language CostModel
-> Either
     TransactionValidityIntervalError
     (Map RdmrPtr (Either (ScriptFailure StandardCrypto) ExUnits))
forall c (m :: * -> *).
(Crypto c, Monad m) =>
PParams (AurumEra c)
-> Tx (AurumEra c)
-> UTxO (AurumEra c)
-> EpochInfo m
-> SystemStart
-> Array Language CostModel
-> m (Map RdmrPtr (Either (ScriptFailure c) ExUnits))
Aurum.evaluateTransactionExecutionUnits
             (SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
forall era.
SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
toLedgerPParams SophieBasedEra era
era ProtocolParameters
pparams)
             Tx ledgerera
Tx StandardAurum
tx
             (SophieBasedEra era -> UTxO era -> UTxO StandardAurum
forall era ledgerera.
(SophieLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
SophieBasedEra era -> UTxO era -> UTxO ledgerera
toLedgerUTxO SophieBasedEra era
era UTxO era
utxo)
             (EraHistory mode
-> EpochInfo (Either TransactionValidityIntervalError)
toLedgerEpochInfo EraHistory mode
history)
             SystemStart
systemstart
             (Map AnyZerepochScriptVersion CostModel -> Array Language CostModel
toAurumCostModels (ProtocolParameters -> Map AnyZerepochScriptVersion 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

    toAurumCostModels :: Map AnyZerepochScriptVersion CostModel
                       -> Array.Array Aurum.Language Aurum.CostModel
    toAurumCostModels :: Map AnyZerepochScriptVersion CostModel -> Array Language CostModel
toAurumCostModels Map AnyZerepochScriptVersion 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)
        [ (AnyZerepochScriptVersion -> Language
toAurumLanguage AnyZerepochScriptVersion
lang, CostModel -> CostModel
toAurumCostModel CostModel
costmodel)
        | (AnyZerepochScriptVersion
lang, CostModel
costmodel) <- Map AnyZerepochScriptVersion CostModel
-> [(AnyZerepochScriptVersion, CostModel)]
forall k a. Map k a -> [(k, a)]
Map.toList Map AnyZerepochScriptVersion CostModel
costmodels ]

    fromLedgerScriptExUnitsMap
      :: Map Aurum.RdmrPtr (Either (Aurum.ScriptFailure Ledger.StandardCrypto)
                                    Aurum.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
fromAurumRdmrPtr 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
fromAurumScriptExecutionError ExUnits -> ExecutionUnits
fromAurumExUnits 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 ]

    fromAurumScriptExecutionError :: Aurum.ScriptFailure Ledger.StandardCrypto
                                   -> ScriptExecutionError
    fromAurumScriptExecutionError :: ScriptFailure StandardCrypto -> ScriptExecutionError
fromAurumScriptExecutionError ScriptFailure StandardCrypto
failure =
      case ScriptFailure StandardCrypto
failure of
        Aurum.UnknownTxIn     TxIn StandardCrypto
txin -> TxIn -> ScriptExecutionError
ScriptErrorMissingTxIn TxIn
txin'
                                         where txin' :: TxIn
txin' = TxIn StandardCrypto -> TxIn
fromSophieTxIn TxIn StandardCrypto
txin
        Aurum.InvalidTxIn     TxIn StandardCrypto
txin -> TxIn -> ScriptExecutionError
ScriptErrorTxInWithoutDatum TxIn
txin'
                                         where txin' :: TxIn
txin' = TxIn StandardCrypto -> TxIn
fromSophieTxIn TxIn StandardCrypto
txin
        Aurum.MissingDatum      DataHash StandardCrypto
dh -> Hash ScriptData -> ScriptExecutionError
ScriptErrorWrongDatum (DataHash StandardCrypto -> Hash ScriptData
ScriptDataHash DataHash StandardCrypto
dh)
        Aurum.ValidationFailed EvaluationError
err -> EvaluationError -> ScriptExecutionError
ScriptErrorEvaluationFailed EvaluationError
err
        Aurum.IncompatibleBudget ExBudget
_ -> ScriptExecutionError
ScriptErrorExecutionUnitsOverflow

        -- This is only possible for spending scripts and occurs when
        -- we attempt to spend a key witnessed tx input with a Zerepoch
        -- script witness.
        Aurum.RedeemerNotNeeded RdmrPtr
rdmrPtr ->
          ScriptWitnessIndex -> ScriptExecutionError
ScriptErrorNotZerepochWitnessedTxIn (ScriptWitnessIndex -> ScriptExecutionError)
-> ScriptWitnessIndex -> ScriptExecutionError
forall a b. (a -> b) -> a -> b
$ RdmrPtr -> ScriptWitnessIndex
fromAurumRdmrPtr RdmrPtr
rdmrPtr
        -- Some of the errors are impossible by construction, given the way we
        -- build transactions in the API:
        Aurum.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
fromAurumRdmrPtr 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.
                              IsSophieBasedEra 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
_ (ColeTxBody Annotated Tx ByteString
_) =
    case SophieBasedEra era
forall era. IsSophieBasedEra era => SophieBasedEra era
sophieBasedEra :: SophieBasedEra era of {}
    --TODO: we could actually support Cole here, it'd be different but simpler

evaluateTransactionBalance ProtocolParameters
pparams Set PoolId
poolids UTxO era
utxo
                           (SophieTxBody SophieBasedEra era
era TxBody (SophieLedgerEra era)
txbody [Script (SophieLedgerEra era)]
_ TxBodyScriptData era
_ Maybe (AuxiliaryData (SophieLedgerEra era))
_ TxScriptValidity era
_) =
    SophieBasedEra era
-> ((LedgerEraConstraints (SophieLedgerEra era),
     LedgerBccOnlyConstraints (SophieLedgerEra era),
     LedgerPParamsConstraints (SophieLedgerEra era),
     LedgerTxBodyConstraints (SophieLedgerEra era)) =>
    OnlyBccSupportedInEra era -> TxOutValue era)
-> ((LedgerEraConstraints (SophieLedgerEra era),
     LedgerMultiAssetConstraints (SophieLedgerEra era),
     LedgerPParamsConstraints (SophieLedgerEra era),
     LedgerTxBodyConstraints (SophieLedgerEra era)) =>
    MultiAssetSupportedInEra era -> TxOutValue era)
-> TxOutValue era
forall ledgerera a.
(SophieLedgerEra era ~ ledgerera) =>
SophieBasedEra era
-> ((LedgerEraConstraints ledgerera,
     LedgerBccOnlyConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    OnlyBccSupportedInEra era -> a)
-> ((LedgerEraConstraints ledgerera,
     LedgerMultiAssetConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    MultiAssetSupportedInEra era -> a)
-> a
withLedgerConstraints SophieBasedEra era
era (LedgerEraConstraints (SophieLedgerEra era),
 LedgerBccOnlyConstraints (SophieLedgerEra era),
 LedgerPParamsConstraints (SophieLedgerEra era),
 LedgerTxBodyConstraints (SophieLedgerEra era)) =>
OnlyBccSupportedInEra era -> TxOutValue era
forall ledgerera.
(SophieLedgerEra era ~ ledgerera, LedgerEraConstraints ledgerera,
 LedgerBccOnlyConstraints ledgerera) =>
OnlyBccSupportedInEra era -> TxOutValue era
evalBccOnly (LedgerEraConstraints (SophieLedgerEra era),
 LedgerMultiAssetConstraints (SophieLedgerEra era),
 LedgerPParamsConstraints (SophieLedgerEra era),
 LedgerTxBodyConstraints (SophieLedgerEra era)) =>
MultiAssetSupportedInEra era -> TxOutValue era
forall ledgerera.
(SophieLedgerEra 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.
                      SophieLedgerEra 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
fromJenValue (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
           (SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
forall era.
SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
toLedgerPParams SophieBasedEra era
era ProtocolParameters
pparams)
           (SophieBasedEra era -> UTxO era -> UTxO ledgerera
forall era ledgerera.
(SophieLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
SophieBasedEra era -> UTxO era -> UTxO ledgerera
toLedgerUTxO SophieBasedEra era
era UTxO era
utxo)
           KeyHash 'StakePool StandardCrypto -> Bool
KeyHash 'StakePool (Crypto ledgerera) -> Bool
isNewPool
           TxBody ledgerera
TxBody (SophieLedgerEra era)
txbody

    evalBccOnly :: forall ledgerera.
                   SophieLedgerEra era ~ ledgerera
                => LedgerEraConstraints ledgerera
                => LedgerBccOnlyConstraints ledgerera
                => OnlyBccSupportedInEra era
                -> TxOutValue era
    evalBccOnly :: OnlyBccSupportedInEra era -> TxOutValue era
evalBccOnly OnlyBccSupportedInEra era
evidence =
     OnlyBccSupportedInEra era -> Entropic -> TxOutValue era
forall era. OnlyBccSupportedInEra era -> Entropic -> TxOutValue era
TxOutBccOnly OnlyBccSupportedInEra era
evidence (Entropic -> TxOutValue era)
-> (Coin -> Entropic) -> Coin -> TxOutValue era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Entropic
fromSophieEntropic
       (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
           (SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
forall era.
SophieBasedEra era
-> ProtocolParameters -> PParams (SophieLedgerEra era)
toLedgerPParams SophieBasedEra era
era ProtocolParameters
pparams)
           (SophieBasedEra era -> UTxO era -> UTxO ledgerera
forall era ledgerera.
(SophieLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
SophieBasedEra era -> UTxO era -> UTxO ledgerera
toLedgerUTxO SophieBasedEra era
era UTxO era
utxo)
           KeyHash 'StakePool StandardCrypto -> Bool
KeyHash 'StakePool (Crypto ledgerera) -> Bool
isNewPool
           TxBody ledgerera
TxBody (SophieLedgerEra era)
txbody

    -- Conjur up all the necessary class instances and evidence
    withLedgerConstraints
      :: SophieLedgerEra era ~ ledgerera
      => SophieBasedEra era
      -> (   LedgerEraConstraints ledgerera
          => LedgerBccOnlyConstraints ledgerera
          => LedgerPParamsConstraints ledgerera
          => LedgerTxBodyConstraints ledgerera
          => OnlyBccSupportedInEra era
          -> a)
      -> (   LedgerEraConstraints ledgerera
          => LedgerMultiAssetConstraints ledgerera
          => LedgerPParamsConstraints ledgerera
          => LedgerTxBodyConstraints ledgerera
          => MultiAssetSupportedInEra era
          -> a)
      -> a
    withLedgerConstraints :: SophieBasedEra era
-> ((LedgerEraConstraints ledgerera,
     LedgerBccOnlyConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    OnlyBccSupportedInEra era -> a)
-> ((LedgerEraConstraints ledgerera,
     LedgerMultiAssetConstraints ledgerera,
     LedgerPParamsConstraints ledgerera,
     LedgerTxBodyConstraints ledgerera) =>
    MultiAssetSupportedInEra era -> a)
-> a
withLedgerConstraints SophieBasedEra era
SophieBasedEraSophie (LedgerEraConstraints ledgerera,
 LedgerBccOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyBccSupportedInEra era -> a
f (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
_ = (LedgerEraConstraints ledgerera,
 LedgerBccOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyBccSupportedInEra era -> a
OnlyBccSupportedInEra era -> a
f OnlyBccSupportedInEra era
OnlyBccSupportedInEra SophieEra
BccOnlyInSophieEra
    withLedgerConstraints SophieBasedEra era
SophieBasedEraEvie (LedgerEraConstraints ledgerera,
 LedgerBccOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyBccSupportedInEra era -> a
f (LedgerEraConstraints ledgerera,
 LedgerMultiAssetConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
MultiAssetSupportedInEra era -> a
_ = (LedgerEraConstraints ledgerera,
 LedgerBccOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyBccSupportedInEra era -> a
OnlyBccSupportedInEra era -> a
f OnlyBccSupportedInEra era
OnlyBccSupportedInEra EvieEra
BccOnlyInEvieEra
    withLedgerConstraints SophieBasedEra era
SophieBasedEraJen    (LedgerEraConstraints ledgerera,
 LedgerBccOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyBccSupportedInEra 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 JenEra
MultiAssetInJenEra
    withLedgerConstraints SophieBasedEra era
SophieBasedEraAurum  (LedgerEraConstraints ledgerera,
 LedgerBccOnlyConstraints ledgerera,
 LedgerPParamsConstraints ledgerera,
 LedgerTxBodyConstraints ledgerera) =>
OnlyBccSupportedInEra 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 AurumEra
MultiAssetInAurumEra

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

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

type LedgerMultiAssetConstraints ledgerera =
       ( Ledger.Value ledgerera ~ Jen.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-bcc assets is not zero. The 'Value' here is
       -- that residual non-zero balance. The 'makeTransactionBodyAutoBalance'
       -- function only automatically balances bcc, not other assets.
     | TxBodyErrorAssetBalanceWrong Value

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

       -- | There is enough bcc 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 bcc.
       --
     | TxBodyErrorBccBalanceTooSmall
         -- ^ Offending TxOut
         TxOutInAnyEra
         -- ^ Minimum UTxO
         Entropic
         -- ^ Tx balance
         Entropic

       -- | 'makeTransactionBodyAutoBalance' does not yet support the Cole era.
     | TxBodyErrorColeEraNotSupported

       -- | 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
         Entropic
     | TxBodyErrorMinUTxOMissingPParams MinimumUTxOError
     | TxBodyErrorNonBccAssetsUnbalanced 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]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptExecutionError -> [Char]
forall e. Error e => e -> [Char]
displayError ScriptExecutionError
failure
              | (ScriptWitnessIndex
index, ScriptExecutionError
failure) <- [(ScriptWitnessIndex, ScriptExecutionError)]
failures ]

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

  displayError (TxBodyErrorAssetBalanceWrong Value
_value) =
      [Char]
"The transaction does not correctly balance in its non-bcc 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 (TxBodyErrorBccBalanceNegative Entropic
entropic) =
      [Char]
"The transaction does not balance in its use of bcc. The net balance "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"of the transaction is negative: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Entropic -> [Char]
forall a. Show a => a -> [Char]
show Entropic
entropic [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" entropic. "
   [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"The usual solution is to provide more inputs, or inputs with more bcc."

  displayError (TxBodyErrorBccBalanceTooSmall TxOutInAnyEra
changeOutput Entropic
minUTxO Entropic
balance) =
      [Char]
"The transaction does balance in its use of bcc, 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]
++ Entropic -> [Char]
forall a. Show a => a -> [Char]
show Entropic
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]
++ Entropic -> [Char]
forall a. Show a => a -> [Char]
show Entropic
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 bcc to \
      \meet the minimum UTxO threshold"

  displayError TxBodyErrorAutoBalance
TxBodyErrorColeEraNotSupported =
      [Char]
"The Cole 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 Entropic
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
<> Entropic -> [Char]
forall a. Show a => a -> [Char]
show Entropic
minUTxO

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

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

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

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

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

    -- Our strategy is to:
    -- 1. evaluate all the scripts to get the exec units, update with ex units
    -- 2. figure out the overall min fees
    -- 3. update tx with fees
    -- 4. balance the transaction and update tx change output

    TxBody era
txbody0 <-
      (TxBodyError -> TxBodyErrorAutoBalance)
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TxBodyError -> TxBodyErrorAutoBalance
TxBodyError (Either TxBodyError (TxBody era)
 -> Either TxBodyErrorAutoBalance (TxBody era))
-> Either TxBodyError (TxBody era)
-> Either TxBodyErrorAutoBalance (TxBody era)
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
forall era.
IsBccEra 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 (Entropic -> TxOutValue era
forall era. IsBccEra era => Entropic -> TxOutValue era
entropicToTxOutValue Entropic
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

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

    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
TxBodyErrorColeEraNotSupported) (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
$
                        BccEra era
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
forall era.
BccEra era
-> Either (TxFeesImplicitInEra era) (TxFeesExplicitInEra era)
txFeesExplicitInEra BccEra 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 bcc (2^32-1 entropic) and change output
    -- of less than around 18 trillion bcc  (2^64-1 entropic).
    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.
IsBccEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
txbodycontent1 {
                 txFee :: TxFee era
txFee  = TxFeesExplicitInEra era -> Entropic -> TxFee era
forall era. TxFeesExplicitInEra era -> Entropic -> TxFee era
TxFeeExplicit TxFeesExplicitInEra era
explicitTxFees (Entropic -> TxFee era) -> Entropic -> TxFee era
forall a b. (a -> b) -> a -> b
$ Integer -> Entropic
Entropic (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
                                (Entropic -> TxOutValue era
forall era. IsBccEra era => Entropic -> TxOutValue era
entropicToTxOutValue (Entropic -> TxOutValue era) -> Entropic -> TxOutValue era
forall a b. (a -> b) -> a -> b
$ Integer -> Entropic
Entropic (Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Integer
64 :: Integer)) Entropic -> Entropic -> Entropic
forall a. Num a => a -> a -> a
- Entropic
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 :: Entropic
fee   = ProtocolParameters -> TxBody era -> Word -> Word -> Entropic
forall era.
IsSophieBasedEra era =>
ProtocolParameters -> TxBody era -> Word -> Word -> Entropic
evaluateTransactionFee ProtocolParameters
pparams TxBody era
txbody1 Word
nkeys Word
0 --TODO: cole 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.
IsBccEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
txbodycontent1 {
                 txFee :: TxFee era
txFee = TxFeesExplicitInEra era -> Entropic -> TxFee era
forall era. TxFeesExplicitInEra era -> Entropic -> TxFee era
TxFeeExplicit TxFeesExplicitInEra era
explicitTxFees Entropic
fee
               }

    let balance :: TxOutValue era
balance = ProtocolParameters
-> Set PoolId -> UTxO era -> TxBody era -> TxOutValue era
forall era.
IsSophieBasedEra 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
      TxOutBccOnly OnlyBccSupportedInEra era
_ Entropic
_ -> TxOutValue era -> Either TxBodyErrorAutoBalance ()
balanceCheck TxOutValue era
balance
      TxOutValue MultiAssetSupportedInEra era
_ Value
v   ->
        case Value -> Maybe Entropic
valueToEntropic Value
v of
          Maybe Entropic
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
TxBodyErrorNonBccAssetsUnbalanced Value
v
          Just Entropic
_ -> 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.
IsBccEra era =>
TxBodyContent BuildTx era -> Either TxBodyError (TxBody era)
makeTransactionBody TxBodyContent BuildTx era
txbodycontent1 {
          txFee :: TxFee era
txFee  = TxFeesExplicitInEra era -> Entropic -> TxFee era
forall era. TxFeesExplicitInEra era -> Entropic -> TxFee era
TxFeeExplicit TxFeesExplicitInEra era
explicitTxFees Entropic
fee,
          txOuts :: [TxOut era]
txOuts = TxOut era -> [TxOut era] -> [TxOut era]
accountForNoChange
                     (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)
                     (TxBodyContent BuildTx era -> [TxOut era]
forall build era. TxBodyContent build era -> [TxOut era]
txOuts TxBodyContent BuildTx era
txbodycontent)
        }
    BalancedTxBody era
-> Either TxBodyErrorAutoBalance (BalancedTxBody era)
forall (m :: * -> *) a. Monad m => a -> m a
return (TxBody era -> TxOut era -> Entropic -> BalancedTxBody era
forall era.
TxBody era -> TxOut era -> Entropic -> BalancedTxBody era
BalancedTxBody TxBody era
txbody3 (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) Entropic
fee)
 where
   era :: SophieBasedEra era
   era :: SophieBasedEra era
era = SophieBasedEra era
forall era. IsSophieBasedEra era => SophieBasedEra era
sophieBasedEra

   era' :: BccEra era
   era' :: BccEra era
era' = BccEra era
forall era. IsBccEra era => BccEra era
bccEra

   -- In the event of spending the exact amount of entropic in
   -- the specified input(s), this function excludes the change
   -- output. Note that this does not save any fees because by default
   -- the fee calculation includes a change address for simplicity and
   -- we make no attempt to recalculate the tx fee without a change address.
   accountForNoChange :: TxOut era -> [TxOut era] -> [TxOut era]
   accountForNoChange :: TxOut era -> [TxOut era] -> [TxOut era]
accountForNoChange change :: TxOut era
change@(TxOut AddressInEra era
_ TxOutValue era
balance TxOutDatumHash era
_) [TxOut era]
rest =
     case TxOutValue era -> Entropic
forall era. TxOutValue era -> Entropic
txOutValueToEntropic TxOutValue era
balance of
       Entropic Integer
0 -> [TxOut era]
rest
       Entropic
_ -> TxOut era
change TxOut era -> [TxOut era] -> [TxOut era]
forall a. a -> [a] -> [a]
: [TxOut era]
rest

   balanceCheck :: TxOutValue era -> Either TxBodyErrorAutoBalance ()
   balanceCheck :: TxOutValue era -> Either TxBodyErrorAutoBalance ()
balanceCheck TxOutValue era
balance
    | TxOutValue era -> Entropic
forall era. TxOutValue era -> Entropic
txOutValueToEntropic TxOutValue era
balance Entropic -> Entropic -> Bool
forall a. Eq a => a -> a -> Bool
== Entropic
0 = () -> Either TxBodyErrorAutoBalance ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | TxOutValue era -> Entropic
forall era. TxOutValue era -> Entropic
txOutValueToEntropic TxOutValue era
balance Entropic -> Entropic -> Bool
forall a. Ord a => a -> a -> Bool
< Entropic
0 =
        TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left (TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ())
-> (Entropic -> TxBodyErrorAutoBalance)
-> Entropic
-> Either TxBodyErrorAutoBalance ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entropic -> TxBodyErrorAutoBalance
TxBodyErrorBccBalanceNegative (Entropic -> Either TxBodyErrorAutoBalance ())
-> Entropic -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ TxOutValue era -> Entropic
forall era. TxOutValue era -> Entropic
txOutValueToEntropic 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 Entropic
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 -> Entropic -> Entropic -> TxBodyErrorAutoBalance
TxBodyErrorBccBalanceTooSmall TxOutInAnyEra
txOutAny Entropic
minUTxO (TxOutValue era -> Entropic
forall era. TxOutValue era -> Entropic
txOutValueToEntropic TxOutValue era
balance)
          Left TxBodyErrorAutoBalance
err -> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left TxBodyErrorAutoBalance
err
          Right ()
_ -> () -> Either TxBodyErrorAutoBalance ()
forall a b. b -> Either a b
Right ()

   checkMinUTxOValue
     :: TxOut 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' = do
     Value
minUTxO  <- (MinimumUTxOError -> TxBodyErrorAutoBalance)
-> Either MinimumUTxOError Value
-> Either TxBodyErrorAutoBalance Value
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first MinimumUTxOError -> TxBodyErrorAutoBalance
TxBodyErrorMinUTxOMissingPParams
                   (Either MinimumUTxOError Value
 -> Either TxBodyErrorAutoBalance Value)
-> Either MinimumUTxOError Value
-> Either TxBodyErrorAutoBalance Value
forall a b. (a -> b) -> a -> b
$ SophieBasedEra era
-> TxOut era -> ProtocolParameters -> Either MinimumUTxOError Value
forall era.
SophieBasedEra era
-> TxOut era -> ProtocolParameters -> Either MinimumUTxOError Value
calculateMinimumUTxO SophieBasedEra era
era TxOut era
txout ProtocolParameters
pparams'
     if TxOutValue era -> Entropic
forall era. TxOutValue era -> Entropic
txOutValueToEntropic TxOutValue era
v Entropic -> Entropic -> Bool
forall a. Ord a => a -> a -> Bool
>= Value -> Entropic
selectEntropic Value
minUTxO
     then () -> Either TxBodyErrorAutoBalance ()
forall a b. b -> Either a b
Right ()
     else TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. a -> Either a b
Left (TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ())
-> TxBodyErrorAutoBalance -> Either TxBodyErrorAutoBalance ()
forall a b. (a -> b) -> a -> b
$ TxOutInAnyEra -> Entropic -> TxBodyErrorAutoBalance
TxBodyErrorMinUTxONotMet
                   (TxOut era -> TxOutInAnyEra
forall era. IsBccEra era => TxOut era -> TxOutInAnyEra
txOutInAnyEra TxOut era
txout)
                   (Value -> Entropic
selectEntropic Value
minUTxO)

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@(ZerepochScriptWitness ScriptLanguageInEra lang era
langInEra ZerepochScriptVersion lang
version ZerepochScript 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
-> ZerepochScriptVersion lang
-> ZerepochScript lang
-> ScriptDatum witctx
-> ScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
forall lang era witctx.
ScriptLanguageInEra lang era
-> ZerepochScriptVersion lang
-> ZerepochScript lang
-> ScriptDatum witctx
-> ScriptData
-> ExecutionUnits
-> ScriptWitness witctx era
ZerepochScriptWitness ScriptLanguageInEra lang era
langInEra ZerepochScriptVersion lang
version ZerepochScript lang
script
                                            ScriptDatum witctx
datum ScriptData
redeemer ExecutionUnits
exunits

calculateMinimumUTxO
  :: SophieBasedEra era
  -> TxOut era
  -> ProtocolParameters
  -> Either MinimumUTxOError Value
calculateMinimumUTxO :: SophieBasedEra era
-> TxOut era -> ProtocolParameters -> Either MinimumUTxOError Value
calculateMinimumUTxO SophieBasedEra era
era txout :: TxOut era
txout@(TxOut AddressInEra era
_ TxOutValue era
v TxOutDatumHash era
_) ProtocolParameters
pparams' =
  case SophieBasedEra era
era of
    SophieBasedEra era
SophieBasedEraSophie -> Entropic -> Value
entropicToValue (Entropic -> Value)
-> Either MinimumUTxOError Entropic
-> Either MinimumUTxOError Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolParameters -> Either MinimumUTxOError Entropic
getMinUTxOPreAurum ProtocolParameters
pparams'
    SophieBasedEra era
SophieBasedEraEvie -> Either MinimumUTxOError Value
calcMinUTxOEvieJen
    SophieBasedEra era
SophieBasedEraJen -> Either MinimumUTxOError Value
calcMinUTxOEvieJen
    SophieBasedEra era
SophieBasedEraAurum ->
      case ProtocolParameters -> Maybe Entropic
protocolParamUTxOCostPerWord ProtocolParameters
pparams' of
        Just (Entropic Integer
costPerWord) -> do
          Value -> Either MinimumUTxOError Value
forall a b. b -> Either a b
Right (Value -> Either MinimumUTxOError Value)
-> (Entropic -> Value) -> Entropic -> Either MinimumUTxOError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entropic -> Value
entropicToValue
            (Entropic -> Either MinimumUTxOError Value)
-> Entropic -> Either MinimumUTxOError Value
forall a b. (a -> b) -> a -> b
$ Integer -> Entropic
Entropic (TxOut StandardAurum -> Integer
forall era. Era era => TxOut era -> Integer
Aurum.utxoEntrySize (SophieBasedEra era -> TxOut era -> TxOut StandardAurum
forall era ledgerera.
(SophieLedgerEra era ~ ledgerera) =>
SophieBasedEra era -> TxOut era -> TxOut ledgerera
toSophieTxOut SophieBasedEra era
era TxOut era
txout) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
costPerWord)
        Maybe Entropic
Nothing -> MinimumUTxOError -> Either MinimumUTxOError Value
forall a b. a -> Either a b
Left MinimumUTxOError
PParamsUTxOCostPerWordMissing
 where
   calcMinUTxOEvieJen :: Either MinimumUTxOError Value
   calcMinUTxOEvieJen :: Either MinimumUTxOError Value
calcMinUTxOEvieJen = do
     let val :: Value
val = TxOutValue era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue era
v
     Entropic
minUTxO <- ProtocolParameters -> Either MinimumUTxOError Entropic
getMinUTxOPreAurum ProtocolParameters
pparams'
     Value -> Either MinimumUTxOError Value
forall a b. b -> Either a b
Right (Value -> Either MinimumUTxOError Value)
-> (Entropic -> Value) -> Entropic -> Either MinimumUTxOError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entropic -> Value
entropicToValue (Entropic -> Either MinimumUTxOError Value)
-> Entropic -> Either MinimumUTxOError Value
forall a b. (a -> b) -> a -> b
$ Value -> Entropic -> Entropic
calcMinimumDeposit Value
val Entropic
minUTxO

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

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

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