{-# 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 (
  Era (..),
  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
-> TxIx -> PParams era -> AccountState -> Bool -> LedgerEnv era
LedgerEnv SlotNo
slot 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 (EraCrypto era)) a -> TxOut era -> Bool
plutusFree :: forall era a.
Reflect era =>
Map (ScriptHash (EraCrypto era)) a -> TxOut era -> Bool
plutusFree Map (ScriptHash (EraCrypto era)) a
plutusmap TxOut era
txout =
  forall c a. Map (ScriptHash c) a -> Addr c -> Bool
plutusFreeAddr Map (ScriptHash (EraCrypto era)) a
plutusmap (TxOut era
txout forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL)
    Bool -> Bool -> Bool
&& forall era a.
Proof era
-> Map (ScriptHash (EraCrypto era)) a -> Value era -> Bool
plutusFreeValue (forall era. Reflect era => Proof era
reify @era) Map (ScriptHash (EraCrypto era)) 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 c) a -> Addr c -> Bool
plutusFreeAddr :: forall c a. Map (ScriptHash c) a -> Addr c -> Bool
plutusFreeAddr Map (ScriptHash c) a
plutusmap Addr c
addr = case Addr c
addr of
  Addr Network
_ (ScriptHashObj ScriptHash c
h1) (StakeRefBase (ScriptHashObj ScriptHash c
h2)) -> forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash c
h1 Map (ScriptHash c) a
plutusmap Bool -> Bool -> Bool
&& forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash c
h2 Map (ScriptHash c) a
plutusmap
  Addr Network
_ (ScriptHashObj ScriptHash c
h1) StakeReference c
_ -> forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash c
h1 Map (ScriptHash c) a
plutusmap
  Addr Network
_ Credential 'Payment c
_ (StakeRefBase (ScriptHashObj ScriptHash c
h2)) -> forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash c
h2 Map (ScriptHash c) a
plutusmap
  Addr c
_ -> Bool
True

plutusFreeValue :: Proof era -> Map (ScriptHash (EraCrypto era)) a -> Value era -> Bool
plutusFreeValue :: forall era a.
Proof era
-> Map (ScriptHash (EraCrypto era)) a -> Value era -> Bool
plutusFreeValue Proof era
proof Map (ScriptHash (EraCrypto era)) 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 (EraCrypto era)) (Map AssetName Integer)
m)) -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall c a. Map (ScriptHash c) a -> PolicyID c -> Bool
plutusFreePolicyID Map (ScriptHash (EraCrypto era)) a
plutusmap) (forall k a. Map k a -> Set k
Map.keysSet Map (PolicyID (EraCrypto era)) (Map AssetName Integer)
m)

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

plutusFreeCredential :: Map (ScriptHash c) a -> Credential kr c -> Bool
plutusFreeCredential :: forall c a (kr :: KeyRole).
Map (ScriptHash c) a -> Credential kr c -> Bool
plutusFreeCredential Map (ScriptHash c) a
_ (KeyHashObj KeyHash kr c
_) = Bool
True
plutusFreeCredential Map (ScriptHash c) a
plutusmap (ScriptHashObj ScriptHash c
h) = forall k a. Ord k => k -> Map k a -> Bool
Map.notMember ScriptHash c
h Map (ScriptHash c) 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 StandardCrypto) (IsValid, ScriptF era)
plutusmap <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Reflect era =>
Term era (Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era))
plutusUniv
  let ok :: (TxIn StandardCrypto, TxOutF era) -> Bool
ok (TxIn StandardCrypto
_, 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 (EraCrypto era)) a -> TxOut era -> Bool
plutusFree Map (ScriptHash StandardCrypto) (IsValid, ScriptF era)
plutusmap TxOut era
v
  [(TxIn StandardCrypto, TxOutF era)]
utxopairs <- (forall a. (a -> Bool) -> [a] -> [a]
filter (TxIn StandardCrypto, 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 (EraCrypto era)) (TxOutF era))
utxo Proof era
proof)
  (TxIn StandardCrypto
input, TxOutF Proof era
_ TxOut era
out) <- do
    [(TxIn StandardCrypto, TxOutF era)]
zs <- forall a era. Gen a -> TraceM era a
liftGen (forall a. [a] -> Gen [a]
shuffle [(TxIn StandardCrypto, TxOutF era)]
utxopairs)
    case [(TxIn StandardCrypto, 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 StandardCrypto, TxOutF era)
x : [(TxIn StandardCrypto, TxOutF era)]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn StandardCrypto, 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 StandardCrypto
addr <- forall era b. Term era (Set b) -> TraceM era b
fromSetTerm forall era. Era era => Term era (Set (Addr (EraCrypto era)))
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 (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr StandardCrypto
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 (EraCrypto era)] -> TxBodyField era
Inputs' [TxIn StandardCrypto
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 (EraCrypto era) -> TxBodyField era
Mint (forall c.
Map (ScriptHash c) (Map AssetName Integer) -> MultiAsset c
liftMultiAsset (forall era.
Reflect era =>
Proof era
-> Value era
-> Value era
-> Map (ScriptHash (EraCrypto era)) (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 StandardCrypto) (TxOutF era)
u <- forall era a. Term era a -> TraceM era a
getTerm (forall era.
Era era =>
Proof era -> Term era (Map (TxIn (EraCrypto era)) (TxOutF era))
utxo Proof era
proof)
  Map (ScriptHash StandardCrypto) (ScriptF era)
scriptuniv <- forall era a. Term era a -> TraceM era a
getTerm (forall era.
Era era =>
Proof era
-> Term era (Map (ScriptHash (EraCrypto era)) (ScriptF era))
allScriptUniv Proof era
proof)
  Map (ScriptHash StandardCrypto) (IsValid, ScriptF era)
plutusuniv <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Reflect era =>
Term era (Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era))
plutusUniv
  Map
  (KeyHash 'Payment StandardCrypto) (Addr StandardCrypto, SigningKey)
byronuniv <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Era era =>
Term
  era
  (Map
     (KeyHash 'Payment (EraCrypto era))
     (Addr (EraCrypto era), SigningKey))
byronAddrUniv
  Map (DataHash StandardCrypto) (Data era)
datauniv <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Era era =>
Term era (Map (DataHash (EraCrypto era)) (Data era))
dataUniv
  Map (KeyHash 'Genesis StandardCrypto) (GenDelegPair StandardCrypto)
gd <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Era era =>
Term
  era
  (Map
     (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era)))
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 StandardCrypto) (KeyPair 'Witness StandardCrypto)
keymapuniv <- forall era a. Term era a -> TraceM era a
getTerm forall era.
Era era =>
Term
  era
  (Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era)))
keymapUniv
  -- compute the inital inputs to the fix-point computation
  let hash1 :: Hash (EraCrypto era) EraIndependentTxBody
hash1 = forall era.
Proof era
-> TxBody era -> Hash (EraCrypto era) EraIndependentTxBody
hashBody Proof era
proof TxBody era
txBody
      tx :: Tx era
tx =
        forall era.
Reflect era =>
Proof era
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (Addr (EraCrypto era), SigningKey)
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
-> Map (DataHash (EraCrypto era)) (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs (EraCrypto era)
-> 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 StandardCrypto) (ScriptF era)
scriptuniv)
          Map (ScriptHash StandardCrypto) (IsValid, ScriptF era)
plutusuniv
          Map
  (KeyHash 'Payment StandardCrypto) (Addr StandardCrypto, SigningKey)
byronuniv
          Map
  (KeyHash 'Witness StandardCrypto) (KeyPair 'Witness StandardCrypto)
keymapuniv
          Map (DataHash StandardCrypto) (Data era)
datauniv
          TxBody era
txBody
          (forall era. Map (TxIn (EraCrypto era)) (TxOutF era) -> UTxO era
liftUTxO Map (TxIn StandardCrypto) (TxOutF era)
u)
          (forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs Map (KeyHash 'Genesis StandardCrypto) (GenDelegPair StandardCrypto)
gd)
      initialfee :: Coin
initialfee = forall era.
EraUTxO era =>
PParamsF era
-> TxF era -> Map (TxIn (EraCrypto era)) (TxOutF era) -> Coin
computeFinalFee PParamsF era
pp (forall era. Proof era -> Tx era -> TxF era
TxF Proof era
proof Tx era
tx) Map (TxIn StandardCrypto) (TxOutF era)
u
  let loop :: Int
-> Tx era
-> Coin
-> Hash Blake2b_256 EraIndependentTxBody
-> TraceM era (Tx era)
loop Int
_ Tx era
_ Coin
fee Hash Blake2b_256 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 Blake2b_256 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 (EraCrypto era) EraIndependentTxBody
hash2 = forall era.
Proof era
-> TxBody era -> Hash (EraCrypto era) EraIndependentTxBody
hashBody Proof era
proof TxBody era
txb
            completedtx :: Tx era
completedtx =
              forall era.
Reflect era =>
Proof era
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (Addr (EraCrypto era), SigningKey)
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
-> Map (DataHash (EraCrypto era)) (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs (EraCrypto era)
-> 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 StandardCrypto) (ScriptF era)
scriptuniv)
                Map (ScriptHash StandardCrypto) (IsValid, ScriptF era)
plutusuniv
                Map
  (KeyHash 'Payment StandardCrypto) (Addr StandardCrypto, SigningKey)
byronuniv
                Map
  (KeyHash 'Witness StandardCrypto) (KeyPair 'Witness StandardCrypto)
keymapuniv
                Map (DataHash StandardCrypto) (Data era)
datauniv
                TxBody era
txb
                (forall era. Map (TxIn (EraCrypto era)) (TxOutF era) -> UTxO era
liftUTxO Map (TxIn StandardCrypto) (TxOutF era)
u)
                (forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs Map (KeyHash 'Genesis StandardCrypto) (GenDelegPair StandardCrypto)
gd)
            newfee :: Coin
newfee = forall era.
EraUTxO era =>
PParamsF era
-> TxF era -> Map (TxIn (EraCrypto era)) (TxOutF era) -> Coin
computeFinalFee PParamsF era
pp (forall era. Proof era -> Tx era -> TxF era
TxF Proof era
proof Tx era
completedtx) Map (TxIn StandardCrypto) (TxOutF era)
u
        if (Coin
fee forall a. Eq a => a -> a -> Bool
== Coin
newfee) Bool -> Bool -> Bool
&& (Hash Blake2b_256 EraIndependentTxBody
hash forall a. Eq a => a -> a -> Bool
== Hash (EraCrypto era) 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 Blake2b_256 EraIndependentTxBody
-> TraceM era (Tx era)
loop (Int
count forall a. Num a => a -> a -> a
- Int
1) Tx era
completedtx Coin
newfee Hash (EraCrypto era) 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 Blake2b_256 EraIndependentTxBody
-> TraceM era (Tx era)
loop Int
10 Tx era
tx Coin
initialfee Hash (EraCrypto era) 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 (EraCrypto era)) (Script era) ->
  Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era) ->
  Map (KeyHash 'Payment (EraCrypto era)) (Addr (EraCrypto era), SigningKey) ->
  Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)) ->
  Map (DataHash (EraCrypto era)) (Data era) ->
  TxBody era ->
  UTxO era ->
  GenDelegs (EraCrypto era) ->
  Tx era
addWitnesses :: forall era.
Reflect era =>
Proof era
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (Addr (EraCrypto era), SigningKey)
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
-> Map (DataHash (EraCrypto era)) (Data era)
-> TxBody era
-> UTxO era
-> GenDelegs (EraCrypto era)
-> Tx era
addWitnesses Proof era
proof Map (ScriptHash (EraCrypto era)) (Script era)
scriptUniv Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era)
plutusuniv Map
  (KeyHash 'Payment (EraCrypto era))
  (Addr (EraCrypto era), SigningKey)
byronuniv Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
keymapuniv Map (DataHash (EraCrypto era)) (Data era)
datauniv TxBody era
txb UTxO era
ut GenDelegs (EraCrypto era)
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 (EraCrypto era)) (Script era)
    plutusValids :: [IsValid]
    rptrs :: Set (PlutusPointerF era)
    dataw :: Map (DataHash (EraCrypto era)) (Data era)
    (Map (ScriptHash (EraCrypto era)) (Script era)
Map (ScriptHash StandardCrypto) (Script era)
scriptwits, Map (ScriptHash (EraCrypto era)) (Script era)
Map (ScriptHash StandardCrypto) (Script era)
neededWits, [IsValid]
plutusValids, Set (PlutusPointerF era)
rptrs, Map (DataHash (EraCrypto era)) (Data era)
Map (DataHash StandardCrypto) (Data era)
dataw) = case forall era. Proof era -> UTxOWit era
whichUTxO Proof era
proof of
      UTxOWit era
UTxOShelleyToMary -> (Map (ScriptHash StandardCrypto) (Script era)
witss, Map (ScriptHash StandardCrypto) (Script era)
witss, [], forall a. Set a
Set.empty, forall k a. Map k a
Map.empty)
        where
          ShelleyScriptsNeeded Set (ScriptHash (EraCrypto era))
setneed = ScriptsNeeded era
needed
          witss :: Map (ScriptHash StandardCrypto) (Script era)
witss = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (ScriptHash (EraCrypto era)) (Script era)
scriptUniv Set (ScriptHash (EraCrypto era))
setneed
      UTxOWit era
UTxOAlonzoToConway ->
        let AlonzoScriptsNeeded [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era))]
xs = ScriptsNeeded era
needed
            xs' :: [(PlutusPurposeF era, ScriptHash StandardCrypto)]
xs' = [(forall era.
Proof era -> PlutusPurpose AsIxItem era -> PlutusPurposeF era
PlutusPurposeF Proof era
proof PlutusPurpose AsIxItem era
p, ScriptHash StandardCrypto
d) | (PlutusPurpose AsIxItem era
p, ScriptHash StandardCrypto
d) <- [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era))]
xs]
            neededHashset :: Set (ScriptHash StandardCrypto)
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 (EraCrypto era))]
xs)
            refAdjusted :: Set (ScriptHash (EraCrypto era))
refAdjusted =
              forall era.
Proof era
-> Set (TxIn (EraCrypto era))
-> Set (TxIn (EraCrypto era))
-> Map (TxIn (EraCrypto era)) (TxOutF era)
-> Set (ScriptHash (EraCrypto era))
-> Set (ScriptHash (EraCrypto era))
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 (EraCrypto era)))
inputsTxBodyL)
                (forall era. Proof era -> TxBody era -> Set (TxIn (EraCrypto era))
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 (EraCrypto era)) (TxOut era)
unUTxO UTxO era
ut))
                Set (ScriptHash StandardCrypto)
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 (EraCrypto era)) (IsValid, ScriptF era)
plutusuniv Set (ScriptHash StandardCrypto)
neededHashset))
         in ( forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (ScriptHash (EraCrypto era)) (Script era)
scriptUniv Set (ScriptHash (EraCrypto era))
refAdjusted
            , forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map (ScriptHash (EraCrypto era)) (Script era)
scriptUniv Set (ScriptHash StandardCrypto)
neededHashset
            , [IsValid]
validities
            , forall era any.
AlonzoEraScript era =>
[(PlutusPurposeF era, ScriptHash (EraCrypto era))]
-> Map (ScriptHash (EraCrypto era)) any -> Set (PlutusPointerF era)
getRdmrPtrs [(PlutusPurposeF era, ScriptHash StandardCrypto)]
xs' Map (ScriptHash (EraCrypto era)) (IsValid, ScriptF era)
plutusuniv
            , forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys
                Map (DataHash (EraCrypto era)) (Data era)
datauniv
                ( forall era.
(AlonzoEraTxOut era, EraTxBody era, AlonzoEraScript era) =>
Map (TxIn (EraCrypto era)) (TxOutF era)
-> TxBodyF era
-> Map (ScriptHash (EraCrypto era)) (ScriptF era)
-> Set (DataHash (EraCrypto era))
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 (EraCrypto era)) (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 (EraCrypto era)) (Script era)
scriptUniv)
                )
            )
    sufficient :: Set (KeyHash 'Witness (EraCrypto era))
sufficient =
      forall era.
Reflect era =>
Proof era
-> Map (ScriptHash (EraCrypto era)) (ScriptF era)
-> [TxCertF era]
-> Map
     (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
-> Set (KeyHash 'Witness (EraCrypto era))
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 (EraCrypto era)) (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)))
        (forall c. GenDelegs c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
unGenDelegs GenDelegs (EraCrypto era)
gd)
    necessaryKH :: Set (KeyHash 'Witness (EraCrypto era))
necessaryKH =
      forall era.
Reflect era =>
TxBodyF era
-> Map (TxIn (EraCrypto era)) (TxOutF era)
-> Map
     (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
-> Set (KeyHash 'Witness (EraCrypto era))
-> Set (KeyHash 'Witness (EraCrypto era))
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 (EraCrypto era)) (TxOut era)
unUTxO UTxO era
ut))
        (forall c. GenDelegs c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
unGenDelegs GenDelegs (EraCrypto era)
gd)
        (forall era.
Proof era -> TxBody era -> Set (KeyHash 'Witness (EraCrypto era))
reqSig Proof era
proof TxBody era
txb)
    keywits :: Set (WitVKey 'Witness (EraCrypto era))
keywits =
      forall era.
Reflect era =>
TxBodyF era
-> Set (KeyHash 'Witness (EraCrypto era))
-> Set (KeyHash 'Witness (EraCrypto era))
-> Map
     (KeyHash 'Witness (EraCrypto era))
     (KeyPair 'Witness (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (ScriptF era)
-> Map
     (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era))
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (Addr (EraCrypto era), SigningKey)
-> Set (WitVKey 'Witness (EraCrypto era))
makeKeyWitness
        (forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
        Set (KeyHash 'Witness (EraCrypto era))
necessaryKH
        Set (KeyHash 'Witness (EraCrypto era))
sufficient
        Map
  (KeyHash 'Witness (EraCrypto era))
  (KeyPair 'Witness (EraCrypto era))
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 (EraCrypto era)) (Script era)
scriptwits)
        (forall c. GenDelegs c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
unGenDelegs GenDelegs (EraCrypto era)
gd)
        Map
  (KeyHash 'Payment (EraCrypto era))
  (Addr (EraCrypto era), SigningKey)
byronuniv
    bootwits :: Set (BootstrapWitness (EraCrypto era))
bootwits =
      forall era.
Reflect era =>
Proof era
-> Map (TxIn (EraCrypto era)) (TxOutF era)
-> TxBodyF era
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (Addr (EraCrypto era), SigningKey)
-> Set (BootstrapWitness (EraCrypto era))
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 (EraCrypto era)) (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 (EraCrypto era)))
inputsTxBodyL))
        (forall era. Proof era -> TxBody era -> TxBodyF era
TxBodyF Proof era
proof TxBody era
txb)
        Map
  (KeyHash 'Payment (EraCrypto era))
  (Addr (EraCrypto era), 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.
Era era =>
Policy -> Proof era -> [WitnessesField era] -> TxWits era
newWitnesses
        Policy
merge
        Proof era
proof
        [ forall era.
Set (WitVKey 'Witness (EraCrypto era)) -> WitnessesField era
AddrWits Set (WitVKey 'Witness (EraCrypto era))
keywits
        , forall era.
Set (BootstrapWitness (EraCrypto era)) -> WitnessesField era
BootWits Set (BootstrapWitness (EraCrypto era))
bootwits
        , forall era.
Map (ScriptHash (EraCrypto era)) (Script era) -> WitnessesField era
ScriptWits Map (ScriptHash (EraCrypto era)) (Script era)
scriptwits
        , forall era. TxDats era -> WitnessesField era
DataWits (forall era.
Era era =>
Map (DataHash (EraCrypto era)) (Data era) -> TxDats era
TxDats Map (DataHash (EraCrypto era)) (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"