{-# 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.UTxO (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 <- forall era x t. Env era -> RootTarget era x t -> Typed t
runTarget Env era
env (forall era.
EraGov era =>
Proof era -> RootTarget era (LedgerState era) (LedgerState era)
ledgerStateT Proof era
proof)
  SlotNo
slot <- forall era t. Env era -> Term era t -> Typed t
runTerm Env era
env forall era. Era era => Term era SlotNo
currentSlot
  (PParamsF Proof era
_ PParams era
pp) <- forall era t. Env era -> Term era t -> Typed t
runTerm Env era
env (forall era. EraGov era => Proof era -> Term era (PParamsF era)
pparams Proof era
proof)
  AccountState
accntState <- forall era x t. Env era -> RootTarget era x t -> Typed t
runTarget Env era
env forall era. Era era => RootTarget era AccountState AccountState
accountStateT
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> AccountState
-> Bool
-> LedgerEnv era
LedgerEnv SlotNo
slot forall a. Maybe a
Nothing TxIx
txIx PParams era
pp AccountState
accntState Bool
False, 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 =
  forall a. Map ScriptHash a -> Addr -> Bool
plutusFreeAddr Map ScriptHash a
plutusmap (TxOut era
txout forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL)
    Bool -> Bool -> 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 forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut 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)) -> forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash
h1 Map ScriptHash a
plutusmap Bool -> Bool -> 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
_ -> 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)) -> 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 (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)) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Map ScriptHash a -> PolicyID -> Bool
plutusFreePolicyID Map ScriptHash a
plutusmap) (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) = 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) = 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 <- forall era a. Term era a -> TraceM era a
getTerm 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 forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL) forall a. Ord a => a -> a -> Bool
>= Coin
feeEstimate Bool -> Bool -> 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 <- (forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn, TxOutF era) -> Bool
ok forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era a. Term era a -> TraceM era a
getTerm (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 <- forall a era. Gen a -> TraceM era a
liftGen (forall a. [a] -> Gen [a]
shuffle [(TxIn, TxOutF era)]
utxopairs)
    case [(TxIn, TxOutF era)]
zs of
      [] ->
        forall a. String -> a -> a
Debug.trace
          ( String
"There are no entries in the UTxO that are big enough for the feeEstimate: "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Coin
feeEstimate
              forall a. [a] -> [a] -> [a]
++ String
" Discard"
          )
          forall a. a
discard
      ((TxIn, TxOutF era)
x : [(TxIn, TxOutF era)]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn, TxOutF era)
x
  let inputCoin :: Coin
inputCoin = TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL
  Addr
addr <- forall era b. Term era (Set b) -> TraceM era b
fromSetTerm forall era. Era era => Term era (Set Addr)
addrUniv
  ValidityInterval
vldt <- forall era a. Term era a -> TraceM era a
getTerm forall era. Era era => Term era ValidityInterval
validityInterval
  let output :: TxOut era
output = forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (forall t s. Inject t s => t -> s
inject (Coin
inputCoin forall t. Val t => t -> t -> t
<-> Coin
feeEstimate))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ forall era. [TxIn] -> TxBodyField era
Inputs' [TxIn
input]
    , forall era. [TxOut era] -> TxBodyField era
Outputs' [TxOut era
output]
    , forall era. Coin -> TxBodyField era
Txfee Coin
feeEstimate
    , forall era. ValidityInterval -> TxBodyField era
Vldt ValidityInterval
vldt
    , forall era. MultiAsset -> TxBodyField era
Mint (Map ScriptHash (Map AssetName Integer) -> MultiAsset
liftMultiAsset (forall era.
Proof era
-> Value era -> Value era -> Map ScriptHash (Map AssetName Integer)
minusMultiValue Proof era
proof (TxOut era
output forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL) (TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut 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 <- forall era.
Reflect era =>
Proof era -> Coin -> TraceM era [TxBodyField era]
simpleTxBody Proof era
proof Coin
maxFeeEstimate
  let txb :: TxBody era
txb = forall era.
EraTxBody era =>
Proof era -> [TxBodyField era] -> TxBody era
newTxBody Proof era
proof [TxBodyField era]
fields
  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 <- forall era a. Term era a -> TraceM era a
getTerm (forall era.
Era era =>
Proof era -> Term era (Map TxIn (TxOutF era))
utxo Proof era
proof)
  Map ScriptHash (ScriptF era)
scriptuniv <- forall era a. Term era a -> TraceM era a
getTerm (forall era.
Era era =>
Proof era -> Term era (Map ScriptHash (ScriptF era))
allScriptUniv Proof era
proof)
  Map ScriptHash (IsValid, ScriptF era)
plutusuniv <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Reflect era =>
Term era (Map ScriptHash (IsValid, ScriptF era))
plutusUniv
  Map (KeyHash 'Payment) (Addr, SigningKey)
byronuniv <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Era era =>
Term era (Map (KeyHash 'Payment) (Addr, SigningKey))
byronAddrUniv
  Map DataHash (Data era)
datauniv <- forall era a. Term era a -> TraceM era a
getTerm forall era. Era era => Term era (Map DataHash (Data era))
dataUniv
  Map (KeyHash 'Genesis) GenDelegPair
gd <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Era era =>
Term era (Map (KeyHash 'Genesis) GenDelegPair)
genDelegs
  PParamsF era
pp <- forall era a. Term era a -> TraceM era a
getTerm (forall era. EraGov era => Proof era -> Term era (PParamsF era)
pparams Proof era
proof)
  Map (KeyHash 'Witness) (KeyPair 'Witness)
keymapuniv <- forall era a. Term era a -> TraceM era a
getTerm 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 = forall era.
Proof era -> TxBody era -> Hash HASH EraIndependentTxBody
hashBody Proof era
proof TxBody era
txBody
      tx :: Tx era
tx =
        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
          (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
          (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 = forall era.
EraUTxO era =>
PParamsF era -> TxF era -> Map TxIn (TxOutF era) -> Coin
computeFinalFee PParamsF era
pp (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 forall a. Ord a => a -> a -> Bool
>= Coin
maxFeeEstimate = forall a. String -> a -> a
Debug.trace (String
"LOOP: fee >= maxFeeEstimate, Discard") forall a b. (a -> b) -> a -> b
$ forall a. a
discard
      loop Int
count Tx era
txx Coin
fee Hash HASH EraIndependentTxBody
hash = do
        let adjustedtx :: Tx era
adjustedtx = 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 forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
            hash2 :: Hash HASH EraIndependentTxBody
hash2 = forall era.
Proof era -> TxBody era -> Hash HASH EraIndependentTxBody
hashBody Proof era
proof TxBody era
txb
            completedtx :: Tx era
completedtx =
              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
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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
                (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 = forall era.
EraUTxO era =>
PParamsF era -> TxF era -> Map TxIn (TxOutF era) -> Coin
computeFinalFee PParamsF era
pp (forall era. Proof era -> Tx era -> TxF era
TxF Proof era
proof Tx era
completedtx) Map TxIn (TxOutF era)
u
        if (Coin
fee forall a. Eq a => a -> a -> Bool
== Coin
newfee) Bool -> Bool -> Bool
&& (Hash HASH EraIndependentTxBody
hash forall a. Eq a => a -> a -> Bool
== Hash HASH EraIndependentTxBody
hash2)
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
completedtx
          else
            if Int
count 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 forall a. Num a => a -> a -> a
- Int
1) Tx era
completedtx Coin
newfee Hash HASH EraIndependentTxBody
hash2
              else forall a. String -> a -> a
Debug.trace String
"LOOP: count <= 0, fee is oscillating, Discard" 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 = 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 forall era. Proof era -> UTxOWit era
whichUTxO Proof era
proof of
      UTxOWit era
UTxOShelleyToMary -> (Map ScriptHash (Script era)
witss, Map ScriptHash (Script era)
witss, [], forall a. Set a
Set.empty, forall k a. Map k a
Map.empty)
        where
          ShelleyScriptsNeeded Set ScriptHash
setneed = ScriptsNeeded era
needed
          witss :: Map ScriptHash (Script era)
witss = 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' = [(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 = forall a. Ord a => [a] -> Set a
Set.fromList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd [(PlutusPurpose AsIxItem era, ScriptHash)]
xs)
            refAdjusted :: Set ScriptHash
refAdjusted =
              forall era.
Proof era
-> Set TxIn
-> Set TxIn
-> Map TxIn (TxOutF era)
-> Set ScriptHash
-> Set ScriptHash
adjustNeededByRefScripts
                Proof era
proof
                (TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)
                (forall era. Proof era -> TxBody era -> Set TxIn
TraceMonad.refInputs Proof era
proof TxBody era
txb)
                (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut))
                Set ScriptHash
neededHashset
            validities :: [IsValid]
validities = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst (forall k a. Map k a -> [a]
Map.elems (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 ( forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (Script era)
scriptUniv Set ScriptHash
refAdjusted
            , forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map ScriptHash (Script era)
scriptUniv Set ScriptHash
neededHashset
            , [IsValid]
validities
            , 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
            , forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys
                Map DataHash (Data era)
datauniv
                ( forall era.
(AlonzoEraTxOut era, EraTxBody era, AlonzoEraScript era) =>
Map TxIn (TxOutF era)
-> TxBodyF era -> Map ScriptHash (ScriptF era) -> Set DataHash
getPlutusDataHashes
                    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut))
                    (forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
                    (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall era. Proof era -> Script era -> ScriptF era
ScriptF Proof era
proof) Map ScriptHash (Script era)
scriptUniv)
                )
            )
    sufficient :: Set (KeyHash 'Witness)
sufficient =
      forall era.
Reflect era =>
Proof era
-> Map ScriptHash (ScriptF era)
-> [TxCertF era]
-> Map (KeyHash 'Genesis) GenDelegPair
-> Set (KeyHash 'Witness)
sufficientKeyHashes
        Proof era
proof
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> Script era -> ScriptF era
ScriptF Proof era
proof) Map ScriptHash (Script era)
neededWits)
        (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> TxCert era -> TxCertF era
TxCertF Proof era
proof) (TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)))
        (GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs GenDelegs
gd)
    necessaryKH :: Set (KeyHash 'Witness)
necessaryKH =
      forall era.
Reflect era =>
TxBodyF era
-> Map TxIn (TxOutF era)
-> Map (KeyHash 'Genesis) GenDelegPair
-> Set (KeyHash 'Witness)
-> Set (KeyHash 'Witness)
necessaryKeyHashes
        (forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut))
        (GenDelegs -> Map (KeyHash 'Genesis) GenDelegPair
unGenDelegs GenDelegs
gd)
        (forall era. Proof era -> TxBody era -> Set (KeyHash 'Witness)
reqSig Proof era
proof TxBody era
txb)
    keywits :: Set (WitVKey 'Witness)
keywits =
      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
        (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
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 =
      forall era.
Reflect era =>
Proof era
-> Map TxIn (TxOutF era)
-> TxBodyF era
-> Map (KeyHash 'Payment) (Addr, SigningKey)
-> Set BootstrapWitness
bootWitsT
        Proof era
proof
        (forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Proof era -> TxOut era -> TxOutF era
TxOutF Proof era
proof) (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
ut)) (TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
        (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 =
      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)) 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 =
      forall era.
Policy -> Proof era -> [WitnessesField era] -> TxWits era
newWitnesses
        Policy
merge
        Proof era
proof
        [ forall era. Set (WitVKey 'Witness) -> WitnessesField era
AddrWits Set (WitVKey 'Witness)
keywits
        , forall era. Set BootstrapWitness -> WitnessesField era
BootWits Set BootstrapWitness
bootwits
        , forall era. Map ScriptHash (Script era) -> WitnessesField era
ScriptWits Map ScriptHash (Script era)
scriptwits
        , forall era. TxDats era -> WitnessesField era
DataWits (forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats Map DataHash (Data era)
dataw)
        , forall era. Redeemers era -> WitnessesField era
RdmrWits (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 =
      forall era. Proof era -> [TxField era] -> Tx era
newTx
        Proof era
proof
        [ forall era. TxBody era -> TxField era
Body TxBody era
txb
        , forall era. TxWits era -> TxField era
TxWits TxWits era
wits
        , --  , AuxData' (fixM auxs)
          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
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) Coin
feeCoinL
      forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
actualfee
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) Coin
firstOutputCoinL
      forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
outputCoin forall t. Val t => t -> t -> t
<+> (Coin
currentfee forall t. Val t => t -> t -> t
<-> Coin
actualfee))
  where
    currentfee :: Coin
currentfee = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) Coin
feeCoinL
    outputCoin :: Coin
outputCoin = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) Coin
firstOutputCoinL

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

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

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