{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Constrained.Trace.SimpleTx where

import Cardano.Crypto.Signing (SigningKey)
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxWits (TxDats (..))
import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..))
import Cardano.Ledger.BaseTypes (TxIx, inject)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core (
  EraTx (..),
  EraTxBody (..),
  EraTxOut (..),
  Script,
  Tx,
  TxBody,
  Value,
  coinTxOutL,
 )
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Hashes (DataHash, ScriptHash)
import Cardano.Ledger.Keys (GenDelegs (..), KeyHash (..), KeyRole (..))
import Cardano.Ledger.Mary.Value (MaryValue (..), MultiAsset (..), PolicyID (..))
import Cardano.Ledger.Plutus (ExUnits (..))
import Cardano.Ledger.Plutus.Data (Data (..))
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..))
import Cardano.Ledger.Shelley.Rules (LedgerEnv (..))
import Cardano.Ledger.Shelley.UTxO (ShelleyScriptsNeeded (..))
import Cardano.Ledger.State (EraUTxO (..), UTxO (..), getScriptsNeeded)
import Cardano.Ledger.Val (Val (..))
import Data.Foldable (toList)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (StrictSeq (Empty, (:<|)))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Debug.Trace as Debug
import Lens.Micro
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Constrained.Ast (runTarget, runTerm)
import Test.Cardano.Ledger.Constrained.Classes (
  PParamsF (..),
  PlutusPointerF (..),
  PlutusPurposeF (..),
  ScriptF (..),
  TxBodyF (..),
  TxCertF (..),
  TxF (..),
  TxOutF (..),
  liftUTxO,
  unScriptF,
 )
import Test.Cardano.Ledger.Constrained.Env (Env)
import Test.Cardano.Ledger.Constrained.Monad (Typed)
import Test.Cardano.Ledger.Constrained.Preds.Tx (
  adjustNeededByRefScripts,
  allValid,
  bootWitsT,
  computeFinalFee,
  getPlutusDataHashes,
  getRdmrPtrs,
  hashBody,
  makeKeyWitness,
  minusMultiValue,
  necessaryKeyHashes,
  sufficientKeyHashes,
 )
import Test.Cardano.Ledger.Constrained.Trace.TraceMonad (
  TraceM,
  fromSetTerm,
  getTerm,
  liftGen,
  reqSig,
 )
import qualified Test.Cardano.Ledger.Constrained.Trace.TraceMonad as TraceMonad (refInputs)
import Test.Cardano.Ledger.Constrained.Vars
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
import Test.Cardano.Ledger.Generic.Fields (TxBodyField (..), TxField (..), WitnessesField (..))
import Test.Cardano.Ledger.Generic.GenState (mkRedeemers)
import Test.Cardano.Ledger.Generic.Proof (
  Proof (..),
  Reflect (..),
  UTxOWit (..),
  ValueWit (..),
  whichUTxO,
  whichValue,
 )
import Test.Cardano.Ledger.Generic.Updaters (merge, newTx, newTxBody, newWitnesses)
import Test.QuickCheck (discard, shuffle)

-- ===================================================

-- | Given an (Env era) construct the pair the the LendgerEnv and the LedgerState
getSTSLedgerEnv ::
  Reflect era => Proof era -> TxIx -> Env era -> Typed (LedgerEnv era, LedgerState era)
getSTSLedgerEnv :: forall era.
Reflect era =>
Proof era
-> TxIx -> Env era -> Typed (LedgerEnv era, LedgerState era)
getSTSLedgerEnv Proof era
proof TxIx
txIx Env era
env = do
  LedgerState era
ledgerstate <- Env era
-> RootTarget era (LedgerState era) (LedgerState era)
-> Typed (LedgerState era)
forall era x t. Env era -> RootTarget era x t -> Typed t
runTarget Env era
env (Proof era -> RootTarget era (LedgerState era) (LedgerState era)
forall era.
Reflect era =>
Proof era -> RootTarget era (LedgerState era) (LedgerState era)
ledgerStateT Proof era
proof)
  SlotNo
slot <- Env era -> Term era SlotNo -> Typed SlotNo
forall era t. Env era -> Term era t -> Typed t
runTerm Env era
env Term era SlotNo
forall era. Era era => Term era SlotNo
currentSlot
  (PParamsF Proof era
_ PParams era
pp) <- Env era -> Term era (PParamsF era) -> Typed (PParamsF era)
forall era t. Env era -> Term era t -> Typed t
runTerm Env era
env (Proof era -> Term era (PParamsF era)
forall era. EraGov era => Proof era -> Term era (PParamsF era)
pparams Proof era
proof)
  ChainAccountState
accntState <- Env era
-> RootTarget era ChainAccountState ChainAccountState
-> Typed ChainAccountState
forall era x t. Env era -> RootTarget era x t -> Typed t
runTarget Env era
env RootTarget era ChainAccountState ChainAccountState
forall era.
Era era =>
RootTarget era ChainAccountState ChainAccountState
accountStateT
  (LedgerEnv era, LedgerState era)
-> Typed (LedgerEnv era, LedgerState era)
forall a. a -> Typed a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> ChainAccountState
-> LedgerEnv era
forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> ChainAccountState
-> LedgerEnv era
LedgerEnv SlotNo
slot Maybe EpochNo
forall a. Maybe a
Nothing TxIx
txIx PParams era
pp ChainAccountState
accntState, LedgerState era
ledgerstate)

-- ====================================================================
-- Picking things that have no Plutus Scripts inside. To make very
-- simple Transactions we need to avoid plutus scripts as they require
-- Collateral inputs and hashes that ensure prootocl versions match.
-- ====================================================================

-- | Does a TxOut have only Non-Plutus Scripts. Non-Plutus status is measured by non-membership
--   in the Map of script hashes of all Plutus scripts.
plutusFree :: forall era a. Reflect era => Map ScriptHash a -> TxOut era -> Bool
plutusFree :: forall era a. Reflect era => Map ScriptHash a -> TxOut era -> Bool
plutusFree Map ScriptHash a
plutusmap TxOut era
txout =
  Map ScriptHash a -> Addr -> Bool
forall a. Map ScriptHash a -> Addr -> Bool
plutusFreeAddr Map ScriptHash a
plutusmap (TxOut era
txout TxOut era -> Getting Addr (TxOut era) Addr -> Addr
forall s a. s -> Getting a s a -> a
^. Getting Addr (TxOut era) Addr
forall era. EraTxOut era => Lens' (TxOut era) Addr
Lens' (TxOut era) Addr
addrTxOutL)
    Bool -> Bool -> Bool
&& Proof era -> Map ScriptHash a -> Value era -> Bool
forall era a. Proof era -> Map ScriptHash a -> Value era -> Bool
plutusFreeValue (forall era. Reflect era => Proof era
reify @era) Map ScriptHash a
plutusmap (TxOut era
txout TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL)

plutusFreeAddr :: Map ScriptHash a -> Addr -> Bool
plutusFreeAddr :: forall a. Map ScriptHash a -> Addr -> Bool
plutusFreeAddr Map ScriptHash a
plutusmap Addr
addr = case Addr
addr of
  Addr Network
_ (ScriptHashObj ScriptHash
h1) (StakeRefBase (ScriptHashObj ScriptHash
h2)) -> ScriptHash -> Map ScriptHash a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash
h1 Map ScriptHash a
plutusmap Bool -> Bool -> Bool
&& ScriptHash -> Map ScriptHash a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash
h2 Map ScriptHash a
plutusmap
  Addr Network
_ (ScriptHashObj ScriptHash
h1) StakeReference
_ -> ScriptHash -> Map ScriptHash a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash
h1 Map ScriptHash a
plutusmap
  Addr Network
_ Credential 'Payment
_ (StakeRefBase (ScriptHashObj ScriptHash
h2)) -> ScriptHash -> Map ScriptHash a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash
h2 Map ScriptHash a
plutusmap
  Addr
_ -> Bool
True

plutusFreeValue :: Proof era -> Map ScriptHash a -> Value era -> Bool
plutusFreeValue :: forall era a. Proof era -> Map ScriptHash a -> Value era -> Bool
plutusFreeValue Proof era
proof Map ScriptHash a
plutusmap Value era
v = case (Proof era -> ValueWit era
forall era. Proof era -> ValueWit era
whichValue Proof era
proof, Value era
v) of
  (ValueWit era
ValueShelleyToAllegra, Value era
_) -> Bool
True
  (ValueWit era
ValueMaryToConway, MaryValue Coin
_ (MultiAsset Map PolicyID (Map AssetName Integer)
m)) -> (PolicyID -> Bool) -> Set PolicyID -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Map ScriptHash a -> PolicyID -> Bool
forall a. Map ScriptHash a -> PolicyID -> Bool
plutusFreePolicyID Map ScriptHash a
plutusmap) (Map PolicyID (Map AssetName Integer) -> Set PolicyID
forall k a. Map k a -> Set k
Map.keysSet Map PolicyID (Map AssetName Integer)
m)

plutusFreePolicyID :: Map ScriptHash a -> PolicyID -> Bool
plutusFreePolicyID :: forall a. Map ScriptHash a -> PolicyID -> Bool
plutusFreePolicyID Map ScriptHash a
plutusmap (PolicyID ScriptHash
h) = ScriptHash -> Map ScriptHash a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash
h Map ScriptHash a
plutusmap

plutusFreeCredential :: Map ScriptHash a -> Credential kr -> Bool
plutusFreeCredential :: forall a (kr :: KeyRole). Map ScriptHash a -> Credential kr -> Bool
plutusFreeCredential Map ScriptHash a
_ (KeyHashObj KeyHash kr
_) = Bool
True
plutusFreeCredential Map ScriptHash a
plutusmap (ScriptHashObj ScriptHash
h) = ScriptHash -> Map ScriptHash a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash
h Map ScriptHash a
plutusmap

-- ====================================================================
-- Code to generate simple, but valid Transactions
-- ====================================================================

-- | Make a simple TxBody with 1 input and 1 output. We estimate that such a TxBody will lead to a fee
--   of less than 'feeEstimate'. So only pick inputs from the utxo that have at least that much coin. Balance the
--   Coin in the TxOut with the feeEstimate and the actual Coin in the UTxO output that corresponds to the input.
--   Only works if the internal Env of the TraceM monad stores variables capable of creating the LedgerState
--   See 'genLedgerStateEnv' for an example of how to do that.
simpleTxBody :: Reflect era => Proof era -> Coin -> TraceM era [TxBodyField era]
simpleTxBody :: forall era.
Reflect era =>
Proof era -> Coin -> TraceM era [TxBodyField era]
simpleTxBody Proof era
proof Coin
feeEstimate = do
  Map ScriptHash (IsValid, ScriptF era)
plutusmap <- Term era (Map ScriptHash (IsValid, ScriptF era))
-> TraceM era (Map ScriptHash (IsValid, ScriptF era))
forall era a. Term era a -> TraceM era a
getTerm Term era (Map ScriptHash (IsValid, ScriptF era))
forall era.
Reflect era =>
Term era (Map ScriptHash (IsValid, ScriptF era))
plutusUniv
  let ok :: (TxIn, TxOutF era) -> Bool
ok (TxIn
_, TxOutF Proof era
_ TxOut era
v) = (TxOut era
v TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
feeEstimate Bool -> Bool -> Bool
&& Map ScriptHash (IsValid, ScriptF era) -> TxOut era -> Bool
forall era a. Reflect era => Map ScriptHash a -> TxOut era -> Bool
plutusFree Map ScriptHash (IsValid, ScriptF era)
plutusmap TxOut era
v
  [(TxIn, TxOutF era)]
utxopairs <- (((TxIn, TxOutF era) -> Bool)
-> [(TxIn, TxOutF era)] -> [(TxIn, TxOutF era)]
forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn, TxOutF era) -> Bool
ok ([(TxIn, TxOutF era)] -> [(TxIn, TxOutF era)])
-> (Map TxIn (TxOutF era) -> [(TxIn, TxOutF era)])
-> Map TxIn (TxOutF era)
-> [(TxIn, TxOutF era)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOutF era) -> [(TxIn, TxOutF era)]
forall k a. Map k a -> [(k, a)]
Map.toList) (Map TxIn (TxOutF era) -> [(TxIn, TxOutF era)])
-> TraceM era (Map TxIn (TxOutF era))
-> TraceM era [(TxIn, TxOutF era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term era (Map TxIn (TxOutF era))
-> TraceM era (Map TxIn (TxOutF era))
forall era a. Term era a -> TraceM era a
getTerm (Proof era -> Term era (Map TxIn (TxOutF era))
forall era.
Era era =>
Proof era -> Term era (Map TxIn (TxOutF era))
utxo Proof era
proof)
  (TxIn
input, TxOutF Proof era
_ TxOut era
out) <- do
    [(TxIn, TxOutF era)]
zs <- Gen [(TxIn, TxOutF era)] -> TraceM era [(TxIn, TxOutF era)]
forall a era. Gen a -> TraceM era a
liftGen ([(TxIn, TxOutF era)] -> Gen [(TxIn, TxOutF era)]
forall a. [a] -> Gen [a]
shuffle [(TxIn, TxOutF era)]
utxopairs)
    case [(TxIn, TxOutF era)]
zs of
      [] ->
        String
-> TraceM era (TxIn, TxOutF era) -> TraceM era (TxIn, TxOutF era)
forall a. String -> a -> a
Debug.trace
          ( String
"There are no entries in the UTxO that are big enough for the feeEstimate: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Coin -> String
forall a. Show a => a -> String
show Coin
feeEstimate
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Discard"
          )
          TraceM era (TxIn, TxOutF era)
forall a. a
discard
      ((TxIn, TxOutF era)
x : [(TxIn, TxOutF era)]
_) -> (TxIn, TxOutF era) -> TraceM era (TxIn, TxOutF era)
forall a. a -> TraceM era a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOutF era)
x
  let inputCoin :: Coin
inputCoin = TxOut era
out TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL
  Addr
addr <- Term era (Set Addr) -> TraceM era Addr
forall era b. Term era (Set b) -> TraceM era b
fromSetTerm Term era (Set Addr)
forall era. Era era => Term era (Set Addr)
addrUniv
  ValidityInterval
vldt <- Term era ValidityInterval -> TraceM era ValidityInterval
forall era a. Term era a -> TraceM era a
getTerm Term era ValidityInterval
forall era. Era era => Term era ValidityInterval
validityInterval
  let output :: TxOut era
output = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin
inputCoin Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
feeEstimate))
  [TxBodyField era] -> TraceM era [TxBodyField era]
forall a. a -> TraceM era a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ [TxIn] -> TxBodyField era
forall era. [TxIn] -> TxBodyField era
Inputs' [TxIn
input]
    , [TxOut era] -> TxBodyField era
forall era. [TxOut era] -> TxBodyField era
Outputs' [TxOut era
output]
    , Coin -> TxBodyField era
forall era. Coin -> TxBodyField era
Txfee Coin
feeEstimate
    , ValidityInterval -> TxBodyField era
forall era. ValidityInterval -> TxBodyField era
Vldt ValidityInterval
vldt
    , MultiAsset -> TxBodyField era
forall era. MultiAsset -> TxBodyField era
Mint (Map ScriptHash (Map AssetName Integer) -> MultiAsset
liftMultiAsset (Proof era
-> Value era -> Value era -> Map ScriptHash (Map AssetName Integer)
forall era.
Proof era
-> Value era -> Value era -> Map ScriptHash (Map AssetName Integer)
minusMultiValue Proof era
proof (TxOut era
output TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL) (TxOut era
out TxOut era
-> Getting (Value era) (TxOut era) (Value era) -> Value era
forall s a. s -> Getting a s a -> a
^. Getting (Value era) (TxOut era) (Value era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL)))
    ]

-- | Generate a (Tx era) from a simple (TxBody era), with 1 input and 1 output.
--   Apply the "finishing" function 'completeTxBody' to make the result a valid Tx.
--   Only works if the internal Env of the TraceM monad stores variables capable of
--   creating the LedgerState. The parameter 'maxFeeEstimate' has to be chosen by
--   experience. The fee for most simpleTx as less than 60000. But in at least one
--   case we have seen as high as 108407. If that case happens we will discard.
--   A large fee is rare because it is caused by many scripts and fees that need large witnesses,
simpleTx :: Reflect era => Proof era -> Coin -> TraceM era (Tx era)
simpleTx :: forall era. Reflect era => Proof era -> Coin -> TraceM era (Tx era)
simpleTx Proof era
proof Coin
maxFeeEstimate = do
  [TxBodyField era]
fields <- Proof era -> Coin -> TraceM era [TxBodyField era]
forall era.
Reflect era =>
Proof era -> Coin -> TraceM era [TxBodyField era]
simpleTxBody Proof era
proof Coin
maxFeeEstimate
  let txb :: TxBody era
txb = Proof era -> [TxBodyField era] -> TxBody era
forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody Proof era
proof [TxBodyField era]
fields
  Proof era -> Coin -> TxBody era -> TraceM era (Tx era)
forall era.
Reflect era =>
Proof era -> Coin -> TxBody era -> TraceM era (Tx era)
completeTxBody Proof era
proof Coin
maxFeeEstimate TxBody era
txb

-- ====================================================================================
-- Once we have a TxBody, we need to make a complete Tx, By filling in Missing pieces.
-- ====================================================================================

-- | Complete a TxBody, by running a fix-point computation that
--   1) Adds the appropriate witnesses.
--   2) Adjusts the the first output to pay the estimated fee.
--   Run the computation until both the fee and the hash of the TxBody reach a fixpoint.
--   Only works if the internal Env of the TraceM monad stores variables capable of creating the LedgerState
completeTxBody :: Reflect era => Proof era -> Coin -> TxBody era -> TraceM era (Tx era)
completeTxBody :: forall era.
Reflect era =>
Proof era -> Coin -> TxBody era -> TraceM era (Tx era)
completeTxBody Proof era
proof Coin
maxFeeEstimate TxBody era
txBody = do
  Map TxIn (TxOutF era)
u <- Term era (Map TxIn (TxOutF era))
-> TraceM era (Map TxIn (TxOutF era))
forall era a. Term era a -> TraceM era a
getTerm (Proof era -> Term era (Map TxIn (TxOutF era))
forall era.
Era era =>
Proof era -> Term era (Map TxIn (TxOutF era))
utxo Proof era
proof)
  Map ScriptHash (ScriptF era)
scriptuniv <- Term era (Map ScriptHash (ScriptF era))
-> TraceM era (Map ScriptHash (ScriptF era))
forall era a. Term era a -> TraceM era a
getTerm (Proof era -> Term era (Map ScriptHash (ScriptF era))
forall era.
Era era =>
Proof era -> Term era (Map ScriptHash (ScriptF era))
allScriptUniv Proof era
proof)
  Map ScriptHash (IsValid, ScriptF era)
plutusuniv <- Term era (Map ScriptHash (IsValid, ScriptF era))
-> TraceM era (Map ScriptHash (IsValid, ScriptF era))
forall era a. Term era a -> TraceM era a
getTerm Term era (Map ScriptHash (IsValid, ScriptF era))
forall era.
Reflect era =>
Term era (Map ScriptHash (IsValid, ScriptF era))
plutusUniv
  Map (KeyHash 'Payment) (Addr, SigningKey)
byronuniv <- Term era (Map (KeyHash 'Payment) (Addr, SigningKey))
-> TraceM era (Map (KeyHash 'Payment) (Addr, SigningKey))
forall era a. Term era a -> TraceM era a
getTerm Term era (Map (KeyHash 'Payment) (Addr, SigningKey))
forall era.
Era era =>
Term era (Map (KeyHash 'Payment) (Addr, SigningKey))
byronAddrUniv
  Map DataHash (Data era)
datauniv <- Term era (Map DataHash (Data era))
-> TraceM era (Map DataHash (Data era))
forall era a. Term era a -> TraceM era a
getTerm Term era (Map DataHash (Data era))
forall era. Era era => Term era (Map DataHash (Data era))
dataUniv
  Map (KeyHash 'Genesis) GenDelegPair
gd <- Term era (Map (KeyHash 'Genesis) GenDelegPair)
-> TraceM era (Map (KeyHash 'Genesis) GenDelegPair)
forall era a. Term era a -> TraceM era a
getTerm Term era (Map (KeyHash 'Genesis) GenDelegPair)
forall era.
EraCertState era =>
Term era (Map (KeyHash 'Genesis) GenDelegPair)
genDelegs
  PParamsF era
pp <- Term era (PParamsF era) -> TraceM era (PParamsF era)
forall era a. Term era a -> TraceM era a
getTerm (Proof era -> Term era (PParamsF era)
forall era. EraGov era => Proof era -> Term era (PParamsF era)
pparams Proof era
proof)
  Map (KeyHash 'Witness) (KeyPair 'Witness)
keymapuniv <- Term era (Map (KeyHash 'Witness) (KeyPair 'Witness))
-> TraceM era (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall era a. Term era a -> TraceM era a
getTerm Term era (Map (KeyHash 'Witness) (KeyPair 'Witness))
forall era.
Era era =>
Term era (Map (KeyHash 'Witness) (KeyPair 'Witness))
keymapUniv
  -- compute the inital inputs to the fix-point computation
  let hash1 :: Hash HASH EraIndependentTxBody
hash1 = Proof era -> TxBody era -> Hash HASH EraIndependentTxBody
forall era.
Proof era -> TxBody era -> Hash HASH EraIndependentTxBody
hashBody Proof era
proof TxBody era
txBody
      tx :: Tx era
tx =
        Proof era
-> Map ScriptHash (Script era)
-> Map ScriptHash (IsValid, ScriptF era)
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map DataHash (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs
-> Tx era
forall era.
Reflect era =>
Proof era
-> Map ScriptHash (Script era)
-> Map ScriptHash (IsValid, ScriptF era)
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map DataHash (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs
-> Tx era
addWitnesses
          Proof era
proof
          ((ScriptF era -> Script era)
-> Map ScriptHash (ScriptF era) -> Map ScriptHash (Script era)
forall a b. (a -> b) -> Map ScriptHash a -> Map ScriptHash b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptF era -> Script era
forall era. ScriptF era -> Script era
unScriptF Map ScriptHash (ScriptF era)
scriptuniv)
          Map ScriptHash (IsValid, ScriptF era)
plutusuniv
          Map (KeyHash 'Payment) (Addr, SigningKey)
byronuniv
          Map (KeyHash 'Witness) (KeyPair 'Witness)
keymapuniv
          Map DataHash (Data era)
datauniv
          TxBody era
txBody
          (Map TxIn (TxOutF era) -> UTxO era
forall era. Map TxIn (TxOutF era) -> UTxO era
liftUTxO Map TxIn (TxOutF era)
u)
          (Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs Map (KeyHash 'Genesis) GenDelegPair
gd)
      initialfee :: Coin
initialfee = PParamsF era -> TxF era -> Map TxIn (TxOutF era) -> Coin
forall era.
EraUTxO era =>
PParamsF era -> TxF era -> Map TxIn (TxOutF era) -> Coin
computeFinalFee PParamsF era
pp (Proof era -> Tx era -> TxF era
forall era. Proof era -> Tx era -> TxF era
TxF Proof era
proof Tx era
tx) Map TxIn (TxOutF era)
u
  let loop :: Int
-> Tx era
-> Coin
-> Hash HASH EraIndependentTxBody
-> TraceM era (Tx era)
loop Int
_ Tx era
_ Coin
fee Hash HASH EraIndependentTxBody
_ | Coin
fee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
maxFeeEstimate = String -> TraceM era (Tx era) -> TraceM era (Tx era)
forall a. String -> a -> a
Debug.trace (String
"LOOP: fee >= maxFeeEstimate, Discard") (TraceM era (Tx era) -> TraceM era (Tx era))
-> TraceM era (Tx era) -> TraceM era (Tx era)
forall a b. (a -> b) -> a -> b
$ TraceM era (Tx era)
forall a. a
discard
      loop Int
count Tx era
txx Coin
fee Hash HASH EraIndependentTxBody
hash = do
        let adjustedtx :: Tx era
adjustedtx = Proof era -> Coin -> Tx era -> Tx era
forall era. EraTx era => Proof era -> Coin -> Tx era -> Tx era
adjustTxForFee Proof era
proof Coin
fee Tx era
txx
            txb :: TxBody era
txb = Tx era
adjustedtx Tx era -> Getting (TxBody era) (Tx era) (TxBody era) -> TxBody era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody era) (Tx era) (TxBody era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL
            hash2 :: Hash HASH EraIndependentTxBody
hash2 = Proof era -> TxBody era -> Hash HASH EraIndependentTxBody
forall era.
Proof era -> TxBody era -> Hash HASH EraIndependentTxBody
hashBody Proof era
proof TxBody era
txb
            completedtx :: Tx era
completedtx =
              Proof era
-> Map ScriptHash (Script era)
-> Map ScriptHash (IsValid, ScriptF era)
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map DataHash (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs
-> Tx era
forall era.
Reflect era =>
Proof era
-> Map ScriptHash (Script era)
-> Map ScriptHash (IsValid, ScriptF era)
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map DataHash (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs
-> Tx era
addWitnesses
                Proof era
proof
                ((ScriptF era -> Script era)
-> Map ScriptHash (ScriptF era) -> Map ScriptHash (Script era)
forall a b. (a -> b) -> Map ScriptHash a -> Map ScriptHash b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ScriptF era -> Script era
forall era. ScriptF era -> Script era
unScriptF Map ScriptHash (ScriptF era)
scriptuniv)
                Map ScriptHash (IsValid, ScriptF era)
plutusuniv
                Map (KeyHash 'Payment) (Addr, SigningKey)
byronuniv
                Map (KeyHash 'Witness) (KeyPair 'Witness)
keymapuniv
                Map DataHash (Data era)
datauniv
                TxBody era
txb
                (Map TxIn (TxOutF era) -> UTxO era
forall era. Map TxIn (TxOutF era) -> UTxO era
liftUTxO Map TxIn (TxOutF era)
u)
                (Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs Map (KeyHash 'Genesis) GenDelegPair
gd)
            newfee :: Coin
newfee = PParamsF era -> TxF era -> Map TxIn (TxOutF era) -> Coin
forall era.
EraUTxO era =>
PParamsF era -> TxF era -> Map TxIn (TxOutF era) -> Coin
computeFinalFee PParamsF era
pp (Proof era -> Tx era -> TxF era
forall era. Proof era -> Tx era -> TxF era
TxF Proof era
proof Tx era
completedtx) Map TxIn (TxOutF era)
u
        if (Coin
fee Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== Coin
newfee) Bool -> Bool -> Bool
&& (Hash HASH EraIndependentTxBody
hash Hash HASH EraIndependentTxBody
-> Hash HASH EraIndependentTxBody -> Bool
forall a. Eq a => a -> a -> Bool
== Hash HASH EraIndependentTxBody
hash2)
          then Tx era -> TraceM era (Tx era)
forall a. a -> TraceM era a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
completedtx
          else
            if Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (Int
0 :: Int)
              then Int
-> Tx era
-> Coin
-> Hash HASH EraIndependentTxBody
-> TraceM era (Tx era)
loop (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Tx era
completedtx Coin
newfee Hash HASH EraIndependentTxBody
hash2
              else String -> TraceM era (Tx era) -> TraceM era (Tx era)
forall a. String -> a -> a
Debug.trace String
"LOOP: count <= 0, fee is oscillating, Discard" TraceM era (Tx era)
forall a. a
discard
  Int
-> Tx era
-> Coin
-> Hash HASH EraIndependentTxBody
-> TraceM era (Tx era)
loop Int
10 Tx era
tx Coin
initialfee Hash HASH EraIndependentTxBody
hash1

-- ========================================================================================

-- | Add witnesses to the TxBody to construct a Tx with the appropriate witnesses.
--   This is a compilcated function, but it should be applicable to ANY Tx generated using
--   the Universes.
addWitnesses ::
  forall era.
  Reflect era =>
  Proof era ->
  Map ScriptHash (Script era) ->
  Map ScriptHash (IsValid, ScriptF era) ->
  Map (KeyHash 'Payment) (Addr, SigningKey) ->
  Map (KeyHash 'Witness) (KeyPair 'Witness) ->
  Map DataHash (Data era) ->
  TxBody era ->
  UTxO era ->
  GenDelegs ->
  Tx era
addWitnesses :: forall era.
Reflect era =>
Proof era
-> Map ScriptHash (Script era)
-> Map ScriptHash (IsValid, ScriptF era)
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map DataHash (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs
-> Tx era
addWitnesses Proof era
proof Map ScriptHash (Script era)
scriptUniv Map ScriptHash (IsValid, ScriptF era)
plutusuniv Map (KeyHash 'Payment) (Addr, SigningKey)
byronuniv Map (KeyHash 'Witness) (KeyPair 'Witness)
keymapuniv Map DataHash (Data era)
datauniv TxBody era
txb UTxO era
ut GenDelegs
gd = Tx era
tx
  where
    needed :: ScriptsNeeded era
needed = UTxO era -> TxBody era -> ScriptsNeeded era
forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
ut TxBody era
txb
    neededWits, scriptwits :: Map ScriptHash (Script era)
    plutusValids :: [IsValid]
    rptrs :: Set (PlutusPointerF era)
    dataw :: Map DataHash (Data era)
    (Map ScriptHash (Script era)
scriptwits, Map ScriptHash (Script era)
neededWits, [IsValid]
plutusValids, Set (PlutusPointerF era)
rptrs, Map DataHash (Data era)
dataw) = case Proof era -> UTxOWit era
forall era. Proof era -> UTxOWit era
whichUTxO Proof era
proof of
      UTxOWit era
UTxOShelleyToMary -> (Map ScriptHash (Script era)
witss, Map ScriptHash (Script era)
witss, [], Set (PlutusPointerF era)
forall a. Set a
Set.empty, Map DataHash (Data era)
forall k a. Map k a
Map.empty)
        where
          ShelleyScriptsNeeded Set ScriptHash
setneed = ScriptsNeeded era
needed
          witss :: Map ScriptHash (Script era)
witss = Map ScriptHash (Script era)
-> Set ScriptHash -> Map ScriptHash (Script era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (Script era)
scriptUniv Set ScriptHash
setneed
      UTxOWit era
UTxOAlonzoToConway ->
        let AlonzoScriptsNeeded [(PlutusPurpose AsIxItem era, ScriptHash)]
xs = ScriptsNeeded era
needed
            xs' :: [(PlutusPurposeF era, ScriptHash)]
xs' = [(Proof era -> PlutusPurpose AsIxItem era -> PlutusPurposeF era
forall era.
Proof era -> PlutusPurpose AsIxItem era -> PlutusPurposeF era
PlutusPurposeF Proof era
proof PlutusPurpose AsIxItem era
p, ScriptHash
d) | (PlutusPurpose AsIxItem era
p, ScriptHash
d) <- [(PlutusPurpose AsIxItem era, ScriptHash)]
xs]
            neededHashset :: Set ScriptHash
neededHashset = [ScriptHash] -> Set ScriptHash
forall a. Ord a => [a] -> Set a
Set.fromList (((PlutusPurpose AsIxItem era, ScriptHash) -> ScriptHash)
-> [(PlutusPurpose AsIxItem era, ScriptHash)] -> [ScriptHash]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PlutusPurpose AsIxItem era, ScriptHash) -> ScriptHash
forall a b. (a, b) -> b
snd [(PlutusPurpose AsIxItem era, ScriptHash)]
xs)
            refAdjusted :: Set ScriptHash
refAdjusted =
              Proof era
-> Set TxIn
-> Set TxIn
-> Map TxIn (TxOutF era)
-> Set ScriptHash
-> Set ScriptHash
forall era.
Proof era
-> Set TxIn
-> Set TxIn
-> Map TxIn (TxOutF era)
-> Set ScriptHash
-> Set ScriptHash
adjustNeededByRefScripts
                Proof era
proof
                (TxBody era
txb TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)
                (Proof era -> TxBody era -> Set TxIn
forall era. Proof era -> TxBody era -> Set TxIn
TraceMonad.refInputs Proof era
proof TxBody era
txb)
                ((TxOut era -> TxOutF era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOutF era)
forall a b. (a -> b) -> Map TxIn a -> Map TxIn b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proof era -> TxOut era -> TxOutF era
forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut))
                Set ScriptHash
neededHashset
            validities :: [IsValid]
validities = ((IsValid, ScriptF era) -> IsValid)
-> [(IsValid, ScriptF era)] -> [IsValid]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IsValid, ScriptF era) -> IsValid
forall a b. (a, b) -> a
fst (Map ScriptHash (IsValid, ScriptF era) -> [(IsValid, ScriptF era)]
forall k a. Map k a -> [a]
Map.elems (Map ScriptHash (IsValid, ScriptF era)
-> Set ScriptHash -> Map ScriptHash (IsValid, ScriptF era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (IsValid, ScriptF era)
plutusuniv Set ScriptHash
neededHashset))
         in ( Map ScriptHash (AlonzoScript era)
-> Set ScriptHash -> Map ScriptHash (AlonzoScript era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (Script era)
Map ScriptHash (AlonzoScript era)
scriptUniv Set ScriptHash
refAdjusted
            , Map ScriptHash (AlonzoScript era)
-> Set ScriptHash -> Map ScriptHash (AlonzoScript era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (Script era)
Map ScriptHash (AlonzoScript era)
scriptUniv Set ScriptHash
neededHashset
            , [IsValid]
validities
            , [(PlutusPurposeF era, ScriptHash)]
-> Map ScriptHash (IsValid, ScriptF era)
-> Set (PlutusPointerF era)
forall era any.
AlonzoEraScript era =>
[(PlutusPurposeF era, ScriptHash)]
-> Map ScriptHash any -> Set (PlutusPointerF era)
getRdmrPtrs [(PlutusPurposeF era, ScriptHash)]
xs' Map ScriptHash (IsValid, ScriptF era)
plutusuniv
            , Map DataHash (Data era) -> Set DataHash -> Map DataHash (Data era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys
                Map DataHash (Data era)
datauniv
                ( Map TxIn (TxOutF era)
-> TxBodyF era -> Map ScriptHash (ScriptF era) -> Set DataHash
forall era.
(AlonzoEraTxOut era, EraTxBody era, AlonzoEraScript era) =>
Map TxIn (TxOutF era)
-> TxBodyF era -> Map ScriptHash (ScriptF era) -> Set DataHash
getPlutusDataHashes
                    ((TxOut era -> TxOutF era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOutF era)
forall a b. (a -> b) -> Map TxIn a -> Map TxIn b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proof era -> TxOut era -> TxOutF era
forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut))
                    (Proof era -> TxBody era -> TxBodyF era
forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
                    ((AlonzoScript era -> ScriptF era)
-> Map ScriptHash (AlonzoScript era)
-> Map ScriptHash (ScriptF era)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Proof era -> Script era -> ScriptF era
forall era. Proof era -> Script era -> ScriptF era
ScriptF Proof era
proof) Map ScriptHash (Script era)
Map ScriptHash (AlonzoScript era)
scriptUniv)
                )
            )
    sufficient :: Set (KeyHash 'Witness)
sufficient =
      Proof era
-> Map ScriptHash (ScriptF era)
-> [TxCertF era]
-> Map (KeyHash 'Genesis) GenDelegPair
-> Set (KeyHash 'Witness)
forall era.
Reflect era =>
Proof era
-> Map ScriptHash (ScriptF era)
-> [TxCertF era]
-> Map (KeyHash 'Genesis) GenDelegPair
-> Set (KeyHash 'Witness)
sufficientKeyHashes
        Proof era
proof
        ((Script era -> ScriptF era)
-> Map ScriptHash (Script era) -> Map ScriptHash (ScriptF era)
forall a b. (a -> b) -> Map ScriptHash a -> Map ScriptHash b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proof era -> Script era -> ScriptF era
forall era. Proof era -> Script era -> ScriptF era
ScriptF Proof era
proof) Map ScriptHash (Script era)
neededWits)
        (StrictSeq (TxCertF era) -> [TxCertF era]
forall a. StrictSeq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((TxCert era -> TxCertF era)
-> StrictSeq (TxCert era) -> StrictSeq (TxCertF era)
forall a b. (a -> b) -> StrictSeq a -> StrictSeq b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proof era -> TxCert era -> TxCertF era
forall era. Proof era -> TxCert era -> TxCertF era
TxCertF Proof era
proof) (TxBody era
txb TxBody era
-> Getting
     (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
-> StrictSeq (TxCert era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxCert era)) (TxBody era) (StrictSeq (TxCert era))
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)))
        (GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs GenDelegs
gd)
    necessaryKH :: Set (KeyHash 'Witness)
necessaryKH =
      TxBodyF era
-> Map TxIn (TxOutF era)
-> Map (KeyHash 'Genesis) GenDelegPair
-> Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness)
forall era.
Reflect era =>
TxBodyF era
-> Map TxIn (TxOutF era)
-> Map (KeyHash 'Genesis) GenDelegPair
-> Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness)
necessaryKeyHashes
        (Proof era -> TxBody era -> TxBodyF era
forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
        ((TxOut era -> TxOutF era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOutF era)
forall a b. (a -> b) -> Map TxIn a -> Map TxIn b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proof era -> TxOut era -> TxOutF era
forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut))
        (GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs GenDelegs
gd)
        (Proof era -> TxBody era -> Set (KeyHash 'Witness)
forall era. Proof era -> TxBody era -> Set (KeyHash 'Witness)
reqSig Proof era
proof TxBody era
txb)
    keywits :: Set (WitVKey 'Witness)
keywits =
      TxBodyF era
-> Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map ScriptHash (ScriptF era)
-> Map (KeyHash 'Genesis) GenDelegPair
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Set (WitVKey 'Witness)
forall era.
Reflect era =>
TxBodyF era
-> Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness)
-> Map (KeyHash 'Witness) (KeyPair 'Witness)
-> Map ScriptHash (ScriptF era)
-> Map (KeyHash 'Genesis) GenDelegPair
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Set (WitVKey 'Witness)
makeKeyWitness
        (Proof era -> TxBody era -> TxBodyF era
forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
        Set (KeyHash 'Witness)
necessaryKH
        Set (KeyHash 'Witness)
sufficient
        Map (KeyHash 'Witness) (KeyPair 'Witness)
keymapuniv
        ((Script era -> ScriptF era)
-> Map ScriptHash (Script era) -> Map ScriptHash (ScriptF era)
forall a b. (a -> b) -> Map ScriptHash a -> Map ScriptHash b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proof era -> Script era -> ScriptF era
forall era. Proof era -> Script era -> ScriptF era
ScriptF Proof era
proof) Map ScriptHash (Script era)
scriptwits)
        (GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs GenDelegs
gd)
        Map (KeyHash 'Payment) (Addr, SigningKey)
byronuniv
    bootwits :: Set BootstrapWitness
bootwits =
      Proof era
-> Map TxIn (TxOutF era)
-> TxBodyF era
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Set BootstrapWitness
forall era.
Reflect era =>
Proof era
-> Map TxIn (TxOutF era)
-> TxBodyF era
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Set BootstrapWitness
bootWitsT
        Proof era
proof
        (Map TxIn (TxOutF era) -> Set TxIn -> Map TxIn (TxOutF era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys ((TxOut era -> TxOutF era)
-> Map TxIn (TxOut era) -> Map TxIn (TxOutF era)
forall a b. (a -> b) -> Map TxIn a -> Map TxIn b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Proof era -> TxOut era -> TxOutF era
forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (UTxO era -> Map TxIn (TxOut era)
forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut)) (TxBody era
txb TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
        (Proof era -> TxBody era -> TxBodyF era
forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
        Map (KeyHash 'Payment) (Addr, SigningKey)
byronuniv
    redeem :: [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeem =
      ([(PlutusPurpose AsIx era, (Data era, ExUnits))]
 -> PlutusPointerF era
 -> [(PlutusPurpose AsIx era, (Data era, ExUnits))])
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> Set (PlutusPointerF era)
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl'
        (\[(PlutusPurpose AsIx era, (Data era, ExUnits))]
ans (PlutusPointerF Proof era
_ PlutusPurpose AsIx era
x) -> (PlutusPurpose AsIx era
x, (forall era. Era era => Data -> Data era
Data @era (Integer -> Data
PV1.I Integer
1), Natural -> Natural -> ExUnits
ExUnits Natural
3 Natural
3)) (PlutusPurpose AsIx era, (Data era, ExUnits))
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))]
forall a. a -> [a] -> [a]
: [(PlutusPurpose AsIx era, (Data era, ExUnits))]
ans)
        -- It doesn't actuallly matter what the Data is, and the ExUnits only need to be small
        -- as maxTxExUnits is usually something big like (ExUnits mem=1217 data=3257)
        []
        Set (PlutusPointerF era)
rptrs
    wits :: TxWits era
wits =
      Policy -> Proof era -> [WitnessesField era] -> TxWits era
forall era.
Policy -> Proof era -> [WitnessesField era] -> TxWits era
newWitnesses
        t -> t -> t
Policy
merge
        Proof era
proof
        [ Set (WitVKey 'Witness) -> WitnessesField era
forall era. Set (WitVKey 'Witness) -> WitnessesField era
AddrWits Set (WitVKey 'Witness)
keywits
        , Set BootstrapWitness -> WitnessesField era
forall era. Set BootstrapWitness -> WitnessesField era
BootWits Set BootstrapWitness
bootwits
        , Map ScriptHash (Script era) -> WitnessesField era
forall era. Map ScriptHash (Script era) -> WitnessesField era
ScriptWits Map ScriptHash (Script era)
scriptwits
        , TxDats era -> WitnessesField era
forall era. TxDats era -> WitnessesField era
DataWits (Map DataHash (Data era) -> TxDats era
forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats Map DataHash (Data era)
dataw)
        , Redeemers era -> WitnessesField era
forall era. Redeemers era -> WitnessesField era
RdmrWits (Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
forall era.
Proof era
-> [(PlutusPurpose AsIx era, (Data era, ExUnits))] -> Redeemers era
mkRedeemers Proof era
proof [(PlutusPurpose AsIx era, (Data era, ExUnits))]
redeem)
        ]
    tx :: Tx era
tx =
      Proof era -> [TxField era] -> Tx era
forall era. Proof era -> [TxField era] -> Tx era
newTx
        Proof era
proof
        [ TxBody era -> TxField era
forall era. TxBody era -> TxField era
Body TxBody era
txb
        , TxWits era -> TxField era
forall era. TxWits era -> TxField era
TxWits TxWits era
wits
        , --  , AuxData' (fixM auxs)
          IsValid -> TxField era
forall era. IsValid -> TxField era
Valid ([IsValid] -> IsValid
allValid [IsValid]
plutusValids)
        ]

-- =======================================================================

-- | adjust a Tx for the fee, by setting the fee to the correct value then
--   moving the excess to the outputs
adjustTxForFee :: EraTx era => Proof era -> Coin -> Tx era -> Tx era
adjustTxForFee :: forall era. EraTx era => Proof era -> Coin -> Tx era -> Tx era
adjustTxForFee Proof era
_proof Coin
actualfee Tx era
tx =
  Tx era
tx
    Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) Coin
Lens' (Tx era) Coin
feeCoinL
      ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
actualfee
    Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) Coin
Lens' (Tx era) Coin
firstOutputCoinL
      ((Coin -> Identity Coin) -> Tx era -> Identity (Tx era))
-> Coin -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
outputCoin Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Coin
currentfee Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
actualfee))
  where
    currentfee :: Coin
currentfee = Tx era
tx Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (Tx era) Coin
forall era. EraTx era => Lens' (Tx era) Coin
Lens' (Tx era) Coin
feeCoinL
    outputCoin :: Coin
outputCoin = Tx era
tx Tx era -> Getting Coin (Tx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (Tx era) Coin
forall era. EraTx era => Lens' (Tx era) Coin
Lens' (Tx era) Coin
firstOutputCoinL

feeCoinL :: EraTx era => Lens' (Tx era) Coin
feeCoinL :: forall era. EraTx era => Lens' (Tx era) Coin
feeCoinL = (TxBody era -> f (TxBody era)) -> Tx era -> f (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> f (TxBody era)) -> Tx era -> f (Tx era))
-> ((Coin -> f Coin) -> TxBody era -> f (TxBody era))
-> (Coin -> f Coin)
-> Tx era
-> f (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> f Coin) -> TxBody era -> f (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
feeTxBodyL

firstOutputCoinL :: EraTx era => Lens' (Tx era) Coin
firstOutputCoinL :: forall era. EraTx era => Lens' (Tx era) Coin
firstOutputCoinL = (TxBody era -> f (TxBody era)) -> Tx era -> f (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> f (TxBody era)) -> Tx era -> f (Tx era))
-> ((Coin -> f Coin) -> TxBody era -> f (TxBody era))
-> (Coin -> f Coin)
-> Tx era
-> f (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> f (StrictSeq (TxOut era)))
-> TxBody era -> f (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> f (StrictSeq (TxOut era)))
 -> TxBody era -> f (TxBody era))
-> ((Coin -> f Coin)
    -> StrictSeq (TxOut era) -> f (StrictSeq (TxOut era)))
-> (Coin -> f Coin)
-> TxBody era
-> f (TxBody era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut era -> f (TxOut era))
-> StrictSeq (TxOut era) -> f (StrictSeq (TxOut era))
forall a (f :: * -> *).
Functor f =>
(a -> f a) -> StrictSeq a -> f (StrictSeq a)
strictSeqHeadL ((TxOut era -> f (TxOut era))
 -> StrictSeq (TxOut era) -> f (StrictSeq (TxOut era)))
-> ((Coin -> f Coin) -> TxOut era -> f (TxOut era))
-> (Coin -> f Coin)
-> StrictSeq (TxOut era)
-> f (StrictSeq (TxOut era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> f Coin) -> TxOut era -> f (TxOut era)
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL

strictSeqHeadL :: Lens' (StrictSeq a) a
strictSeqHeadL :: forall a (f :: * -> *).
Functor f =>
(a -> f a) -> StrictSeq a -> f (StrictSeq a)
strictSeqHeadL =
  (StrictSeq a -> a)
-> (StrictSeq a -> a -> StrictSeq a)
-> Lens (StrictSeq a) (StrictSeq a) a a
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    StrictSeq a -> a
forall {a}. StrictSeq a -> a
gethead
    ( \StrictSeq a
x a
h -> case StrictSeq a
x of
        (a
_ :<| StrictSeq a
xs) -> a
h a -> StrictSeq a -> StrictSeq a
forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq a
xs
        StrictSeq a
Empty -> a
h a -> StrictSeq a -> StrictSeq a
forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq a
forall a. StrictSeq a
Empty
    )
  where
    gethead :: StrictSeq a -> a
gethead (a
x :<| StrictSeq a
_) = a
x
    gethead StrictSeq a
_ = String -> a
forall a. HasCallStack => String -> a
error String
"Empty sequence in strictSeqHeadL"