{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Convex.ThreatModel.Cardano.Api (
  -- * Types
  Era,
  LedgerEra,
  IsPlutusScriptInEra,

  -- * TxOut accessors
  addressOfTxOut,
  valueOfTxOut,
  datumOfTxOut,
  txBodyContentOf,
  bodyContentInputs,
  bodyContentReferenceInputs,
  bodyContentOutputs,
  referenceScriptOfTxOut,

  -- * Redeemer and script data
  redeemerOfTxIn,
  mintedPlutusPolicies,
  recomputeScriptData,
  emptyTxBodyScriptData,
  addScriptData,
  updateRedeemer,
  addMintingRedeemer,
  recomputeScriptDataForMint,
  addDatum,
  toMaryAssetName,

  -- * Address utilities
  paymentCredentialToAddressAny,
  scriptAddressAny,
  keyAddressAny,
  isKeyAddressAny,

  -- * Datum/Redeemer conversion
  toCtxUTxODatum,
  txOutDatum,
  toScriptData,

  -- * Transaction utilities
  dummyTxId,
  makeTxOut,
  txSigners,
  mockWalletHashes,
  detectSigningWallet,
  txRequiredSigners,
  txOutputs,
  txRunsPlutusScript,
  runningPlutusScriptHashes,
  scriptHashOfAddressAny,

  -- * Value utilities
  leqValue,
  projectAda,

  -- * Validation
  ValidityReport (..),
  TxValidity (..),
  validateTx,
  validateTxM,
  buildMockState,
  chainStateUTxO,
  chainStateLedgerUTxO,
  chainStatePParams,

  -- * Rebalancing
  rebalanceAndSign,
  updateExecutionUnits,
  updateTxRedeemersWithExUnits,
  updateScriptDataExUnits,
  recalculateScriptIntegrityHash,
  recalculateTotalCollateral,
  getScriptLanguage,
  setTxFeeCoin,
  setTxOutputsList,
  mkSizedShelleyTxOut,
  adjustChangeOutput,
  adjustOriginalChangeOutput,
  replaceAt,

  -- * Validity interval
  convValidityInterval,

  -- * UTxO utilities
  restrictUTxO,

  -- * Coverage
  extractCoverageFromValidationError,
  unescapeHaskellString,
  extractCoverageAnnotations,
) where

import Cardano.Api

import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..))
import Cardano.Ledger.Alonzo.PParams (ppCollateralPercentageL)
import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
import Cardano.Ledger.Alonzo.Tx (hashScriptIntegrity, mkScriptIntegrity)
import Cardano.Ledger.Alonzo.TxBody qualified as Ledger
import Cardano.Ledger.Alonzo.TxWits qualified as Ledger
import Cardano.Ledger.Api.Era qualified as Ledger (eraProtVerLow)
import Cardano.Ledger.Api.Tx.Body qualified as Ledger
import Cardano.Ledger.Binary qualified as CBOR
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.Rules (ConwayLedgerPredFailure (..), ConwayUtxoPredFailure (..), ConwayUtxosPredFailure (..), ConwayUtxowPredFailure (..))
import Cardano.Ledger.Conway.Scripts qualified as Conway
import Cardano.Ledger.Conway.State qualified as Conway (certVStateL, vsDReps)
import Cardano.Ledger.Conway.TxBody qualified as Conway
import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj))
import Cardano.Ledger.DRep (drepDeposit)
import Cardano.Ledger.Keys (WitVKey (..), coerceKeyRole, hashKey)
import Cardano.Ledger.Mary.Value qualified as Mary
import Cardano.Ledger.Plutus.Language qualified as Plutus
import Cardano.Ledger.Shelley.API.Mempool (ApplyTxError (..))
import Cardano.Ledger.Shelley.LedgerState (lsCertState)
import Cardano.Ledger.State (ScriptsProvided (..), accountsL, accountsMapL, certDStateL, certPStateL, depositAccountStateL, getScriptsHashesNeeded, getScriptsNeeded, getScriptsProvided, psStakePools)
import Cardano.Ledger.State qualified as Ledger (UTxO)
import Cardano.Ledger.TxIn qualified as Ledger (TxIn)
import Cardano.Slotting.Slot ()
import Cardano.Slotting.Time (SlotLength, mkSlotLength)
import Control.Lens (Prism', over, preview, prism', (&), (.~), (^.), _1)
import Data.List (isPrefixOf, sortOn)

import Cardano.Ledger.Shelley.Rules (LedgerEnv (ledgerPp))
import Convex.CardanoApi.Lenses qualified as L
import Convex.Class (
  ExUnitsError (..),
  MockChainState,
  MonadBlockchain (..),
  MonadMockchain (..),
  SendTxError (..),
  ValidationError (VExUnits),
  coverageData,
  env,
  getSlot,
  poolState,
  setTimeToValidRange,
 )
import Convex.MockChain (applyTransaction)
import Convex.NodeParams (NodeParams (..))
import Convex.Wallet (Wallet)
import Convex.Wallet qualified as Wallet
import Convex.Wallet.MockWallet (mockWallets)
import Data.ByteString.Short qualified as SBS
import Data.Either (isRight)
import Data.Foldable (foldrM)
import Data.Map qualified as Map
import Data.Maybe (isJust, isNothing, listToMaybe, mapMaybe)
import Data.Maybe.Strict
import Data.Ord (Down (..))
import Data.SOP.NonEmpty (NonEmpty (NonEmptyOne))
import Data.Sequence.Strict qualified as Seq
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word
import GHC.Exts (fromList, toList)
import Ouroboros.Consensus.Block (GenesisWindow (..))
import Ouroboros.Consensus.Cardano.Block (CardanoEras, StandardCrypto)
import Ouroboros.Consensus.HardFork.History qualified as History
import PlutusTx (ToData, toData)
import PlutusTx.Coverage (CoverageData, coverageDataFromLogMsg)

type Era = ConwayEra
type LedgerEra = ShelleyLedgerEra Era
type IsPlutusScriptInEra lang = (HasScriptLanguageInEra lang Era, IsPlutusScriptLanguage lang)

addressOfTxOut :: TxOut ctx Era -> AddressAny
addressOfTxOut :: forall ctx. TxOut ctx Era -> AddressAny
addressOfTxOut (TxOut (AddressInEra ShelleyAddressInEra{} Address addrtype
addr) TxOutValue Era
_ TxOutDatum ctx Era
_ ReferenceScript Era
_) = Address ShelleyAddr -> AddressAny
AddressShelley Address addrtype
Address ShelleyAddr
addr
addressOfTxOut (TxOut (AddressInEra ByronAddressInAnyEra{} Address addrtype
addr) TxOutValue Era
_ TxOutDatum ctx Era
_ ReferenceScript Era
_) = Address ByronAddr -> AddressAny
AddressByron Address addrtype
Address ByronAddr
addr

valueOfTxOut :: TxOut ctx Era -> Value
valueOfTxOut :: forall ctx. TxOut ctx Era -> Value
valueOfTxOut (TxOut AddressInEra Era
_ TxOutValue Era
v TxOutDatum ctx Era
_ ReferenceScript Era
_) = TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
v

-- | Get the datum from a transaction output.
datumOfTxOut :: TxOut ctx Era -> TxOutDatum ctx Era
datumOfTxOut :: forall ctx. TxOut ctx Era -> TxOutDatum ctx Era
datumOfTxOut (TxOut AddressInEra Era
_ TxOutValue Era
_ TxOutDatum ctx Era
datum ReferenceScript Era
_) = TxOutDatum ctx Era
datum

referenceScriptOfTxOut :: TxOut ctx Era -> ReferenceScript Era
referenceScriptOfTxOut :: forall ctx. TxOut ctx Era -> ReferenceScript Era
referenceScriptOfTxOut (TxOut AddressInEra Era
_ TxOutValue Era
_ TxOutDatum ctx Era
_ ReferenceScript Era
rscript) = ReferenceScript Era
rscript

redeemerOfTxIn :: Tx Era -> TxIn -> Maybe ScriptData
redeemerOfTxIn :: Tx Era -> TxIn -> Maybe ScriptData
redeemerOfTxIn Tx Era
tx TxIn
txIn = Maybe ScriptData
redeemer
 where
  Tx (ShelleyTxBody ShelleyBasedEra Era
_ Conway.ConwayTxBody{ctbSpendInputs :: TxBody ConwayEra -> Set TxIn
Conway.ctbSpendInputs = Set TxIn
inputs} [Script (ShelleyLedgerEra Era)]
_ TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_ = Tx Era
tx

  redeemer :: Maybe ScriptData
redeemer = case TxBodyScriptData Era
scriptData of
    TxBodyScriptData Era
TxBodyNoScriptData -> Maybe ScriptData
forall a. Maybe a
Nothing
    TxBodyScriptData AlonzoEraOnwards Era
_ TxDats (ShelleyLedgerEra Era)
_ (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs) ->
      HashableScriptData -> ScriptData
getScriptData (HashableScriptData -> ScriptData)
-> ((Data ConwayEra, ExUnits) -> HashableScriptData)
-> (Data ConwayEra, ExUnits)
-> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data ConwayEra -> HashableScriptData
forall ledgerera. Data ledgerera -> HashableScriptData
fromAlonzoData (Data ConwayEra -> HashableScriptData)
-> ((Data ConwayEra, ExUnits) -> Data ConwayEra)
-> (Data ConwayEra, ExUnits)
-> HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Data ConwayEra, ExUnits) -> Data ConwayEra
forall a b. (a, b) -> a
fst ((Data ConwayEra, ExUnits) -> ScriptData)
-> Maybe (Data ConwayEra, ExUnits) -> Maybe ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConwayPlutusPurpose AsIx ConwayEra
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Maybe (Data ConwayEra, ExUnits)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
Conway.ConwaySpending AsIx Word32 TxIn
idx) Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs

  idx :: AsIx Word32 TxIn
idx = case AsItem Word32 TxIn -> Set TxIn -> StrictMaybe (AsIx Word32 TxIn)
forall elem container.
Indexable elem container =>
AsItem Word32 elem -> container -> StrictMaybe (AsIx Word32 elem)
Ledger.indexOf (TxIn -> AsItem Word32 TxIn
forall ix it. it -> AsItem ix it
Ledger.AsItem (TxIn -> TxIn
toShelleyTxIn TxIn
txIn)) Set TxIn
inputs of
    SJust AsIx Word32 TxIn
idx' -> AsIx Word32 TxIn
idx'
    StrictMaybe (AsIx Word32 TxIn)
_ -> String -> AsIx Word32 TxIn
forall a. HasCallStack => String -> a
error String
"The impossible happened!"

{- | Plutus minting policies (with their minted/burned assets and the redeemer used) that
the given transaction already exercises. Each policy's script is resolved either from the
transaction's own witness set or, for reference-script mints, from a UTxO among the
chain state passed in. Native-script policies, and policies whose script can't be
resolved, are omitted.
-}
mintedPlutusPolicies :: Tx Era -> UTxO Era -> [(PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)]
mintedPlutusPolicies :: Tx Era
-> UTxO Era
-> [(PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)]
mintedPlutusPolicies Tx Era
tx (UTxO Map TxIn (TxOut CtxUTxO Era)
utxoMap) =
  ((Word32, (PolicyID, Map AssetName Integer))
 -> Maybe (PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData))
-> [(Word32, (PolicyID, Map AssetName Integer))]
-> [(PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Word32, (PolicyID, Map AssetName Integer))
-> Maybe (PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)
resolve ([Word32]
-> [(PolicyID, Map AssetName Integer)]
-> [(Word32, (PolicyID, Map AssetName Integer))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] (Map PolicyID (Map AssetName Integer)
-> [(PolicyID, Map AssetName Integer)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map PolicyID (Map AssetName Integer)
policyMap))
 where
  Tx (ShelleyTxBody ShelleyBasedEra Era
_ Conway.ConwayTxBody{ctbMint :: TxBody ConwayEra -> MultiAsset
Conway.ctbMint = Mary.MultiAsset Map PolicyID (Map AssetName Integer)
policyMap} [Script (ShelleyLedgerEra Era)]
witnessScripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_ = Tx Era
tx

  redeemerAt :: Word32 -> Maybe ScriptData
  redeemerAt :: Word32 -> Maybe ScriptData
redeemerAt Word32
idx = case TxBodyScriptData Era
scriptData of
    TxBodyScriptData Era
TxBodyNoScriptData -> Maybe ScriptData
forall a. Maybe a
Nothing
    TxBodyScriptData AlonzoEraOnwards Era
_ TxDats (ShelleyLedgerEra Era)
_ (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs) ->
      HashableScriptData -> ScriptData
getScriptData (HashableScriptData -> ScriptData)
-> ((Data ConwayEra, ExUnits) -> HashableScriptData)
-> (Data ConwayEra, ExUnits)
-> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data ConwayEra -> HashableScriptData
forall ledgerera. Data ledgerera -> HashableScriptData
fromAlonzoData (Data ConwayEra -> HashableScriptData)
-> ((Data ConwayEra, ExUnits) -> Data ConwayEra)
-> (Data ConwayEra, ExUnits)
-> HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Data ConwayEra, ExUnits) -> Data ConwayEra
forall a b. (a, b) -> a
fst ((Data ConwayEra, ExUnits) -> ScriptData)
-> Maybe (Data ConwayEra, ExUnits) -> Maybe ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConwayPlutusPurpose AsIx ConwayEra
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Maybe (Data ConwayEra, ExUnits)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 PolicyID -> ConwayPlutusPurpose f era
Conway.ConwayMinting (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
Ledger.AsIx Word32
idx)) Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs

  fromAlonzoScript :: Ledger.Script LedgerEra -> Maybe ScriptInAnyLang
  fromAlonzoScript :: Script (ShelleyLedgerEra Era) -> Maybe ScriptInAnyLang
fromAlonzoScript = \case
    Ledger.NativeScript NativeScript ConwayEra
_ -> Maybe ScriptInAnyLang
forall a. Maybe a
Nothing
    Ledger.PlutusScript PlutusScript ConwayEra
ps -> ScriptInAnyLang -> Maybe ScriptInAnyLang
forall a. a -> Maybe a
Just (ScriptInAnyLang -> Maybe ScriptInAnyLang)
-> ScriptInAnyLang -> Maybe ScriptInAnyLang
forall a b. (a -> b) -> a -> b
$ case PlutusScript ConwayEra
ps of
      Conway.ConwayPlutusV1 (Plutus.Plutus (Plutus.PlutusBinary ShortByteString
bs)) ->
        Script PlutusScriptV1 -> ScriptInAnyLang
forall lang. Script lang -> ScriptInAnyLang
toScriptInAnyLang (Script PlutusScriptV1 -> ScriptInAnyLang)
-> Script PlutusScriptV1 -> ScriptInAnyLang
forall a b. (a -> b) -> a -> b
$ PlutusScriptVersion PlutusScriptV1
-> PlutusScript PlutusScriptV1 -> Script PlutusScriptV1
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
PlutusScript PlutusScriptVersion PlutusScriptV1
PlutusScriptV1 (ShortByteString -> PlutusScript PlutusScriptV1
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised ShortByteString
bs)
      Conway.ConwayPlutusV2 (Plutus.Plutus (Plutus.PlutusBinary ShortByteString
bs)) ->
        Script PlutusScriptV2 -> ScriptInAnyLang
forall lang. Script lang -> ScriptInAnyLang
toScriptInAnyLang (Script PlutusScriptV2 -> ScriptInAnyLang)
-> Script PlutusScriptV2 -> ScriptInAnyLang
forall a b. (a -> b) -> a -> b
$ PlutusScriptVersion PlutusScriptV2
-> PlutusScript PlutusScriptV2 -> Script PlutusScriptV2
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
PlutusScript PlutusScriptVersion PlutusScriptV2
PlutusScriptV2 (ShortByteString -> PlutusScript PlutusScriptV2
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised ShortByteString
bs)
      Conway.ConwayPlutusV3 (Plutus.Plutus (Plutus.PlutusBinary ShortByteString
bs)) ->
        Script PlutusScriptV3 -> ScriptInAnyLang
forall lang. Script lang -> ScriptInAnyLang
toScriptInAnyLang (Script PlutusScriptV3 -> ScriptInAnyLang)
-> Script PlutusScriptV3 -> ScriptInAnyLang
forall a b. (a -> b) -> a -> b
$ PlutusScriptVersion PlutusScriptV3
-> PlutusScript PlutusScriptV3 -> Script PlutusScriptV3
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
PlutusScript PlutusScriptVersion PlutusScriptV3
PlutusScriptV3 (ShortByteString -> PlutusScript PlutusScriptV3
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised ShortByteString
bs)

  candidateScripts :: [ScriptInAnyLang]
  candidateScripts :: [ScriptInAnyLang]
candidateScripts =
    (AlonzoScript ConwayEra -> Maybe ScriptInAnyLang)
-> [AlonzoScript ConwayEra] -> [ScriptInAnyLang]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Script (ShelleyLedgerEra Era) -> Maybe ScriptInAnyLang
AlonzoScript ConwayEra -> Maybe ScriptInAnyLang
fromAlonzoScript [Script (ShelleyLedgerEra Era)]
[AlonzoScript ConwayEra]
witnessScripts
      [ScriptInAnyLang] -> [ScriptInAnyLang] -> [ScriptInAnyLang]
forall a. Semigroup a => a -> a -> a
<> [ ScriptInAnyLang
script
         | TxOut CtxUTxO Era
txout <- Map TxIn (TxOut CtxUTxO Era) -> [TxOut CtxUTxO Era]
forall k a. Map k a -> [a]
Map.elems Map TxIn (TxOut CtxUTxO Era)
utxoMap
         , ReferenceScript BabbageEraOnwards Era
_ ScriptInAnyLang
script <- [TxOut CtxUTxO Era -> ReferenceScript Era
forall ctx. TxOut ctx Era -> ReferenceScript Era
referenceScriptOfTxOut TxOut CtxUTxO Era
txout]
         ]

  hashOf :: ScriptInAnyLang -> ScriptHash
  hashOf :: ScriptInAnyLang -> ScriptHash
hashOf (ScriptInAnyLang ScriptLanguage lang
_ Script lang
s) = Script lang -> ScriptHash
forall lang. Script lang -> ScriptHash
hashScript Script lang
s

  resolve :: (Word32, (Mary.PolicyID, Map.Map Mary.AssetName Integer)) -> Maybe (PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)
  resolve :: (Word32, (PolicyID, Map AssetName Integer))
-> Maybe (PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)
resolve (Word32
idx, (Mary.PolicyID ScriptHash
ledgerScriptHash, Map AssetName Integer
assetMap)) = do
    -- fromMaryPolicyID isn't re-exported from Cardano.Api in every version we support
    -- (it's an internal helper that only became public later), so convert manually.
    let scriptHash :: ScriptHash
scriptHash = ScriptHash -> ScriptHash
fromShelleyScriptHash ScriptHash
ledgerScriptHash
        policyId :: PolicyId
policyId = ScriptHash -> PolicyId
PolicyId ScriptHash
scriptHash
    ScriptData
redeemer <- Word32 -> Maybe ScriptData
redeemerAt Word32
idx
    ScriptInAnyLang
scriptInAnyLang <- [ScriptInAnyLang] -> Maybe ScriptInAnyLang
forall a. [a] -> Maybe a
listToMaybe [ScriptInAnyLang
s | ScriptInAnyLang
s <- [ScriptInAnyLang]
candidateScripts, ScriptInAnyLang -> ScriptHash
hashOf ScriptInAnyLang
s ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptHash
scriptHash]
    let assets :: PolicyAssets
assets = Map AssetName Quantity -> PolicyAssets
PolicyAssets (Map AssetName Quantity -> PolicyAssets)
-> Map AssetName Quantity -> PolicyAssets
forall a b. (a -> b) -> a -> b
$ [(AssetName, Quantity)] -> Map AssetName Quantity
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ByteString -> AssetName
UnsafeAssetName (ShortByteString -> ByteString
SBS.fromShort ShortByteString
n), Integer -> Quantity
Quantity Integer
q) | (Mary.AssetName ShortByteString
n, Integer
q) <- Map AssetName Integer -> [(AssetName, Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList Map AssetName Integer
assetMap]
    (PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)
-> Maybe (PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PolicyId
policyId, PolicyAssets
assets, ScriptInAnyLang
scriptInAnyLang, ScriptData
redeemer)

paymentCredentialToAddressAny :: PaymentCredential -> AddressAny
paymentCredentialToAddressAny :: PaymentCredential -> AddressAny
paymentCredentialToAddressAny PaymentCredential
t =
  Address ShelleyAddr -> AddressAny
AddressShelley (Address ShelleyAddr -> AddressAny)
-> Address ShelleyAddr -> AddressAny
forall a b. (a -> b) -> a -> b
$ NetworkId
-> PaymentCredential
-> StakeAddressReference
-> Address ShelleyAddr
makeShelleyAddress (NetworkMagic -> NetworkId
Testnet (NetworkMagic -> NetworkId) -> NetworkMagic -> NetworkId
forall a b. (a -> b) -> a -> b
$ Word32 -> NetworkMagic
NetworkMagic Word32
1) PaymentCredential
t StakeAddressReference
NoStakeAddress

-- | Construct a script address.
scriptAddressAny :: ScriptHash -> AddressAny
scriptAddressAny :: ScriptHash -> AddressAny
scriptAddressAny = PaymentCredential -> AddressAny
paymentCredentialToAddressAny (PaymentCredential -> AddressAny)
-> (ScriptHash -> PaymentCredential) -> ScriptHash -> AddressAny
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> PaymentCredential
PaymentCredentialByScript

-- | Construct a public key address.
keyAddressAny :: Hash PaymentKey -> AddressAny
keyAddressAny :: Hash PaymentKey -> AddressAny
keyAddressAny = PaymentCredential -> AddressAny
paymentCredentialToAddressAny (PaymentCredential -> AddressAny)
-> (Hash PaymentKey -> PaymentCredential)
-> Hash PaymentKey
-> AddressAny
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash PaymentKey -> PaymentCredential
PaymentCredentialByKey

{- | Check if an address is a public key address — i.e. has no script
payment credential. Byron addresses count as key addresses, as they have no
script credentials at all.
-}
isKeyAddressAny :: AddressAny -> Bool
isKeyAddressAny :: AddressAny -> Bool
isKeyAddressAny = Maybe ScriptHash -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ScriptHash -> Bool)
-> (AddressAny -> Maybe ScriptHash) -> AddressAny -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressAny -> Maybe ScriptHash
scriptHashOfAddressAny

{- | Re-key the Spending redeemers after the set of spend inputs changed:
optionally drop the redeemer of a removed input, then apply the index shift
to the remaining ones. Redeemers of every other purpose are indexed against
their own item sets, which this change does not touch, so they pass through
unchanged - shifting them would leave e.g. a withdrawal's redeemer pointing
at the wrong (or a missing) reward account, and the ledger would reject the
transaction in phase 1 with MissingRedeemer/ExtraRedeemers.
-}
recomputeScriptData
  :: Maybe Word32 -- Index to remove
  -> (Word32 -> Word32)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
recomputeScriptData :: Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeScriptData = Prism'
  (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 TxIn)
-> Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
forall it.
Prism' (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 it)
-> Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeRedeemerIndices p (AsIx Word32 TxIn) (f (AsIx Word32 TxIn))
-> p (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (f (PlutusPurpose AsIx (ShelleyLedgerEra Era)))
Prism'
  (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 TxIn)
spendingPurpose

-- | Re-key the Minting redeemers after the set of minted policies changed.
recomputeScriptDataForMint
  :: Maybe Word32 -- Index to remove
  -> (Word32 -> Word32)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
recomputeScriptDataForMint :: Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeScriptDataForMint = Prism'
  (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 PolicyID)
-> Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
forall it.
Prism' (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 it)
-> Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeRedeemerIndices p (AsIx Word32 PolicyID) (f (AsIx Word32 PolicyID))
-> p (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (f (PlutusPurpose AsIx (ShelleyLedgerEra Era)))
Prism'
  (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 PolicyID)
mintingPurpose

{- | Shared core of 'recomputeScriptData' and 'recomputeScriptDataForMint':
re-key the redeemers of the purpose selected by the prism and leave all
other purposes untouched.
-}
recomputeRedeemerIndices
  :: Prism' (Ledger.PlutusPurpose Ledger.AsIx LedgerEra) (Ledger.AsIx Word32 it)
  -> Maybe Word32 -- Index to remove
  -> (Word32 -> Word32)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
recomputeRedeemerIndices :: forall it.
Prism' (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 it)
-> Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeRedeemerIndices Prism' (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 it)
_ Maybe Word32
_ Word32 -> Word32
_ TxBodyScriptData Era
TxBodyNoScriptData = TxBodyScriptData Era
forall era. TxBodyScriptData era
TxBodyNoScriptData
recomputeRedeemerIndices Prism' (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 it)
purpose Maybe Word32
i Word32 -> Word32
f (TxBodyScriptData AlonzoEraOnwards Era
era TxDats (ShelleyLedgerEra Era)
dats (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)) =
  AlonzoEraOnwards Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData
    AlonzoEraOnwards Era
era
    TxDats (ShelleyLedgerEra Era)
dats
    (Map
  (PlutusPurpose AsIx (ShelleyLedgerEra Era))
  (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers (Map
   (PlutusPurpose AsIx (ShelleyLedgerEra Era))
   (Data (ShelleyLedgerEra Era), ExUnits)
 -> Redeemers (ShelleyLedgerEra Era))
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$ (ConwayPlutusPurpose AsIx ConwayEra
 -> PlutusPurpose AsIx (ShelleyLedgerEra Era))
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra)
     (Data (ShelleyLedgerEra Era), ExUnits)
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (Data (ShelleyLedgerEra Era), ExUnits)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys ConwayPlutusPurpose AsIx ConwayEra
-> PlutusPurpose AsIx (ShelleyLedgerEra Era)
ConwayPlutusPurpose AsIx ConwayEra
-> ConwayPlutusPurpose AsIx ConwayEra
updatePtr (Map
   (ConwayPlutusPurpose AsIx ConwayEra)
   (Data (ShelleyLedgerEra Era), ExUnits)
 -> Map
      (PlutusPurpose AsIx (ShelleyLedgerEra Era))
      (Data (ShelleyLedgerEra Era), ExUnits))
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra)
     (Data (ShelleyLedgerEra Era), ExUnits)
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (Data (ShelleyLedgerEra Era), ExUnits)
forall a b. (a -> b) -> a -> b
$ (ConwayPlutusPurpose AsIx ConwayEra
 -> (Data ConwayEra, ExUnits) -> Bool)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits) -> Bool
idxFilter Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)
 where
  updatePtr :: ConwayPlutusPurpose AsIx ConwayEra
-> ConwayPlutusPurpose AsIx ConwayEra
updatePtr = ASetter
  (ConwayPlutusPurpose AsIx ConwayEra)
  (ConwayPlutusPurpose AsIx ConwayEra)
  (AsIx Word32 it)
  (AsIx Word32 it)
-> (AsIx Word32 it -> AsIx Word32 it)
-> ConwayPlutusPurpose AsIx ConwayEra
-> ConwayPlutusPurpose AsIx ConwayEra
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (AsIx Word32 it -> Identity (AsIx Word32 it))
-> PlutusPurpose AsIx (ShelleyLedgerEra Era)
-> Identity (PlutusPurpose AsIx (ShelleyLedgerEra Era))
ASetter
  (ConwayPlutusPurpose AsIx ConwayEra)
  (ConwayPlutusPurpose AsIx ConwayEra)
  (AsIx Word32 it)
  (AsIx Word32 it)
Prism' (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 it)
purpose (\(Ledger.AsIx Word32
ix) -> Word32 -> AsIx Word32 it
forall ix it. ix -> AsIx ix it
Ledger.AsIx (Word32 -> Word32
f Word32
ix))
  idxFilter :: ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits) -> Bool
idxFilter ConwayPlutusPurpose AsIx ConwayEra
k (Data ConwayEra, ExUnits)
_ = case Getting
  (First (AsIx Word32 it))
  (ConwayPlutusPurpose AsIx ConwayEra)
  (AsIx Word32 it)
-> ConwayPlutusPurpose AsIx ConwayEra -> Maybe (AsIx Word32 it)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (AsIx Word32 it -> Const (First (AsIx Word32 it)) (AsIx Word32 it))
-> PlutusPurpose AsIx (ShelleyLedgerEra Era)
-> Const
     (First (AsIx Word32 it))
     (PlutusPurpose AsIx (ShelleyLedgerEra Era))
Getting
  (First (AsIx Word32 it))
  (ConwayPlutusPurpose AsIx ConwayEra)
  (AsIx Word32 it)
Prism' (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 it)
purpose ConwayPlutusPurpose AsIx ConwayEra
k of
    Just (Ledger.AsIx Word32
ix) -> Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
ix Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i
    Maybe (AsIx Word32 it)
Nothing -> Bool
True

-- | The ledger offers only constructor/projection pairs for script purposes; these are their prisms.
spendingPurpose :: Prism' (Ledger.PlutusPurpose Ledger.AsIx LedgerEra) (Ledger.AsIx Word32 Ledger.TxIn)
spendingPurpose :: Prism'
  (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 TxIn)
spendingPurpose = (AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra)
-> (ConwayPlutusPurpose AsIx ConwayEra -> Maybe (AsIx Word32 TxIn))
-> Prism
     (ConwayPlutusPurpose AsIx ConwayEra)
     (ConwayPlutusPurpose AsIx ConwayEra)
     (AsIx Word32 TxIn)
     (AsIx Word32 TxIn)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' AsIx Word32 TxIn -> PlutusPurpose AsIx ConwayEra
AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *).
f Word32 TxIn -> PlutusPurpose f ConwayEra
Ledger.mkSpendingPurpose PlutusPurpose AsIx ConwayEra -> Maybe (AsIx Word32 TxIn)
ConwayPlutusPurpose AsIx ConwayEra -> Maybe (AsIx Word32 TxIn)
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 TxIn)
forall (f :: * -> * -> *).
PlutusPurpose f ConwayEra -> Maybe (f Word32 TxIn)
Ledger.toSpendingPurpose

mintingPurpose :: Prism' (Ledger.PlutusPurpose Ledger.AsIx LedgerEra) (Ledger.AsIx Word32 Mary.PolicyID)
mintingPurpose :: Prism'
  (PlutusPurpose AsIx (ShelleyLedgerEra Era)) (AsIx Word32 PolicyID)
mintingPurpose = (AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx ConwayEra)
-> (ConwayPlutusPurpose AsIx ConwayEra
    -> Maybe (AsIx Word32 PolicyID))
-> Prism
     (ConwayPlutusPurpose AsIx ConwayEra)
     (ConwayPlutusPurpose AsIx ConwayEra)
     (AsIx Word32 PolicyID)
     (AsIx Word32 PolicyID)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' AsIx Word32 PolicyID -> PlutusPurpose AsIx ConwayEra
AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx ConwayEra
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
forall (f :: * -> * -> *).
f Word32 PolicyID -> PlutusPurpose f ConwayEra
Ledger.mkMintingPurpose PlutusPurpose AsIx ConwayEra -> Maybe (AsIx Word32 PolicyID)
ConwayPlutusPurpose AsIx ConwayEra -> Maybe (AsIx Word32 PolicyID)
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 PolicyID)
forall (f :: * -> * -> *).
PlutusPurpose f ConwayEra -> Maybe (f Word32 PolicyID)
Ledger.toMintingPurpose

emptyTxBodyScriptData :: TxBodyScriptData Era
emptyTxBodyScriptData :: TxBodyScriptData Era
emptyTxBodyScriptData = AlonzoEraOnwards Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData AlonzoEraOnwards Era
AlonzoEraOnwardsConway (Map DataHash (Data ConwayEra) -> TxDats ConwayEra
forall era. Era era => Map DataHash (Data era) -> TxDats era
Ledger.TxDats Map DataHash (Data ConwayEra)
forall a. Monoid a => a
mempty) (Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall a. Monoid a => a
mempty)

addScriptData
  :: Word32
  -> Ledger.Data (ShelleyLedgerEra Era)
  -> (Ledger.Data (ShelleyLedgerEra Era), Ledger.ExUnits)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
addScriptData :: Word32
-> Data (ShelleyLedgerEra Era)
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
addScriptData Word32
ix Data (ShelleyLedgerEra Era)
dat (Data (ShelleyLedgerEra Era), ExUnits)
rdmr TxBodyScriptData Era
TxBodyNoScriptData = Word32
-> Data (ShelleyLedgerEra Era)
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
addScriptData Word32
ix Data (ShelleyLedgerEra Era)
dat (Data (ShelleyLedgerEra Era), ExUnits)
rdmr TxBodyScriptData Era
emptyTxBodyScriptData
addScriptData Word32
ix Data (ShelleyLedgerEra Era)
dat (Data (ShelleyLedgerEra Era), ExUnits)
rdmr (TxBodyScriptData AlonzoEraOnwards Era
era (Ledger.TxDats Map DataHash (Data ConwayEra)
dats) (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)) =
  AlonzoEraOnwards Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData
    AlonzoEraOnwards Era
era
    (Map DataHash (Data (ShelleyLedgerEra Era))
-> TxDats (ShelleyLedgerEra Era)
forall era. Era era => Map DataHash (Data era) -> TxDats era
Ledger.TxDats (Map DataHash (Data (ShelleyLedgerEra Era))
 -> TxDats (ShelleyLedgerEra Era))
-> Map DataHash (Data (ShelleyLedgerEra Era))
-> TxDats (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$ DataHash
-> Data ConwayEra
-> Map DataHash (Data ConwayEra)
-> Map DataHash (Data ConwayEra)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Data ConwayEra -> DataHash
forall era. Data era -> DataHash
Ledger.hashData Data (ShelleyLedgerEra Era)
Data ConwayEra
dat) Data (ShelleyLedgerEra Era)
Data ConwayEra
dat Map DataHash (Data ConwayEra)
dats)
    (Map
  (PlutusPurpose AsIx (ShelleyLedgerEra Era))
  (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers (Map
   (PlutusPurpose AsIx (ShelleyLedgerEra Era))
   (Data (ShelleyLedgerEra Era), ExUnits)
 -> Redeemers (ShelleyLedgerEra Era))
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$ ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
Conway.ConwaySpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
Ledger.AsIx Word32
ix)) (Data (ShelleyLedgerEra Era), ExUnits)
(Data ConwayEra, ExUnits)
rdmr Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)

{- | Update only the redeemer for a spending input (does not modify TxDats)
Use this when the original UTxO has an inline datum to avoid adding orphaned datums
-}
updateRedeemer
  :: Word32
  -> (Ledger.Data (ShelleyLedgerEra Era), Ledger.ExUnits)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
updateRedeemer :: Word32
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
updateRedeemer Word32
ix (Data (ShelleyLedgerEra Era), ExUnits)
rdmr TxBodyScriptData Era
TxBodyNoScriptData = Word32
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
updateRedeemer Word32
ix (Data (ShelleyLedgerEra Era), ExUnits)
rdmr TxBodyScriptData Era
emptyTxBodyScriptData
updateRedeemer Word32
ix (Data (ShelleyLedgerEra Era), ExUnits)
rdmr (TxBodyScriptData AlonzoEraOnwards Era
era TxDats (ShelleyLedgerEra Era)
dats (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)) =
  AlonzoEraOnwards Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData
    AlonzoEraOnwards Era
era
    TxDats (ShelleyLedgerEra Era)
dats
    (Map
  (PlutusPurpose AsIx (ShelleyLedgerEra Era))
  (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers (Map
   (PlutusPurpose AsIx (ShelleyLedgerEra Era))
   (Data (ShelleyLedgerEra Era), ExUnits)
 -> Redeemers (ShelleyLedgerEra Era))
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$ ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AsIx Word32 TxIn -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 TxIn -> ConwayPlutusPurpose f era
Conway.ConwaySpending (Word32 -> AsIx Word32 TxIn
forall ix it. ix -> AsIx ix it
Ledger.AsIx Word32
ix)) (Data (ShelleyLedgerEra Era), ExUnits)
(Data ConwayEra, ExUnits)
rdmr Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)

-- | Add a minting redeemer to the script data (no datum needed for minting)
addMintingRedeemer
  :: Word32
  -> (Ledger.Data (ShelleyLedgerEra Era), Ledger.ExUnits)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
addMintingRedeemer :: Word32
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
addMintingRedeemer Word32
_ (Data (ShelleyLedgerEra Era), ExUnits)
_ TxBodyScriptData Era
TxBodyNoScriptData = Word32
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
addMintingRedeemer Word32
0 (String -> Data ConwayEra
forall a. HasCallStack => String -> a
error String
"no redeemer", Natural -> Natural -> ExUnits
Ledger.ExUnits Natural
0 Natural
0) TxBodyScriptData Era
emptyTxBodyScriptData
addMintingRedeemer Word32
ix (Data (ShelleyLedgerEra Era), ExUnits)
rdmr (TxBodyScriptData AlonzoEraOnwards Era
era TxDats (ShelleyLedgerEra Era)
dats (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)) =
  AlonzoEraOnwards Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData
    AlonzoEraOnwards Era
era
    TxDats (ShelleyLedgerEra Era)
dats
    (Map
  (PlutusPurpose AsIx (ShelleyLedgerEra Era))
  (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers (Map
   (PlutusPurpose AsIx (ShelleyLedgerEra Era))
   (Data (ShelleyLedgerEra Era), ExUnits)
 -> Redeemers (ShelleyLedgerEra Era))
-> Map
     (PlutusPurpose AsIx (ShelleyLedgerEra Era))
     (Data (ShelleyLedgerEra Era), ExUnits)
-> Redeemers (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$ ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (AsIx Word32 PolicyID -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 PolicyID -> ConwayPlutusPurpose f era
Conway.ConwayMinting (Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
Ledger.AsIx Word32
ix)) (Data (ShelleyLedgerEra Era), ExUnits)
(Data ConwayEra, ExUnits)
rdmr Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)

-- | Convert cardano-api AssetName to ledger Mary.AssetName
toMaryAssetName :: AssetName -> Mary.AssetName
toMaryAssetName :: AssetName -> AssetName
toMaryAssetName AssetName
an = ShortByteString -> AssetName
Mary.AssetName (ShortByteString -> AssetName) -> ShortByteString -> AssetName
forall a b. (a -> b) -> a -> b
$ ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ AssetName -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes AssetName
an

addDatum
  :: Ledger.Data (ShelleyLedgerEra Era)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
addDatum :: Data (ShelleyLedgerEra Era)
-> TxBodyScriptData Era -> TxBodyScriptData Era
addDatum Data (ShelleyLedgerEra Era)
dat TxBodyScriptData Era
TxBodyNoScriptData = Data (ShelleyLedgerEra Era)
-> TxBodyScriptData Era -> TxBodyScriptData Era
addDatum Data (ShelleyLedgerEra Era)
dat TxBodyScriptData Era
emptyTxBodyScriptData
addDatum Data (ShelleyLedgerEra Era)
dat (TxBodyScriptData AlonzoEraOnwards Era
era (Ledger.TxDats Map DataHash (Data ConwayEra)
dats) Redeemers (ShelleyLedgerEra Era)
rdmrs) =
  AlonzoEraOnwards Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData
    AlonzoEraOnwards Era
era
    (Map DataHash (Data (ShelleyLedgerEra Era))
-> TxDats (ShelleyLedgerEra Era)
forall era. Era era => Map DataHash (Data era) -> TxDats era
Ledger.TxDats (Map DataHash (Data (ShelleyLedgerEra Era))
 -> TxDats (ShelleyLedgerEra Era))
-> Map DataHash (Data (ShelleyLedgerEra Era))
-> TxDats (ShelleyLedgerEra Era)
forall a b. (a -> b) -> a -> b
$ DataHash
-> Data ConwayEra
-> Map DataHash (Data ConwayEra)
-> Map DataHash (Data ConwayEra)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Data ConwayEra -> DataHash
forall era. Data era -> DataHash
Ledger.hashData Data (ShelleyLedgerEra Era)
Data ConwayEra
dat) Data (ShelleyLedgerEra Era)
Data ConwayEra
dat Map DataHash (Data ConwayEra)
dats)
    Redeemers (ShelleyLedgerEra Era)
rdmrs

toCtxUTxODatum :: TxOutDatum CtxTx Era -> TxOutDatum CtxUTxO Era
toCtxUTxODatum :: TxOutDatum CtxTx Era -> TxOutDatum CtxUTxO Era
toCtxUTxODatum TxOutDatum CtxTx Era
d = case TxOutDatum CtxTx Era
d of
  TxOutDatum CtxTx Era
TxOutDatumNone -> TxOutDatum CtxUTxO Era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone
  TxOutDatumHash AlonzoEraOnwards Era
s Hash ScriptData
h -> AlonzoEraOnwards Era -> Hash ScriptData -> TxOutDatum CtxUTxO Era
forall era ctx.
AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum ctx era
TxOutDatumHash AlonzoEraOnwards Era
s Hash ScriptData
h
  TxOutDatumInline BabbageEraOnwards Era
s HashableScriptData
sd -> BabbageEraOnwards Era
-> HashableScriptData -> TxOutDatum CtxUTxO Era
forall era ctx.
BabbageEraOnwards era -> HashableScriptData -> TxOutDatum ctx era
TxOutDatumInline BabbageEraOnwards Era
s HashableScriptData
sd
  TxOutSupplementalDatum AlonzoEraOnwards Era
s HashableScriptData
_sd -> AlonzoEraOnwards Era -> Hash ScriptData -> TxOutDatum CtxUTxO Era
forall era ctx.
AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum ctx era
TxOutDatumHash AlonzoEraOnwards Era
s (HashableScriptData -> Hash ScriptData
hashScriptDataBytes HashableScriptData
_sd)

-- | Convert ScriptData to a `Test.QuickCheck.ContractModel.ThreatModel.Datum`.
txOutDatum :: ScriptData -> TxOutDatum CtxTx Era
txOutDatum :: ScriptData -> TxOutDatum CtxTx Era
txOutDatum ScriptData
d = BabbageEraOnwards Era -> HashableScriptData -> TxOutDatum CtxTx Era
forall era ctx.
BabbageEraOnwards era -> HashableScriptData -> TxOutDatum ctx era
TxOutDatumInline BabbageEraOnwards Era
BabbageEraOnwardsConway (ScriptData -> HashableScriptData
unsafeHashableScriptData ScriptData
d)

{- | Convert a Haskell value to ScriptData for use as a
`Test.QuickCheck.ContractModel.ThreatModel.Redeemer` or convert to a
`Test.QuickCheck.ContractModel.ThreatModel.Datum` with `txOutDatum`.
-}
toScriptData :: (ToData a) => a -> ScriptData
toScriptData :: forall a. ToData a => a -> ScriptData
toScriptData = Data -> ScriptData
fromPlutusData (Data -> ScriptData) -> (a -> Data) -> a -> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Data
forall a. ToData a => a -> Data
toData

-- | Used for new inputs.
dummyTxId :: TxId
dummyTxId :: TxId
dummyTxId =
  TxId -> TxId
fromShelleyTxId (TxId -> TxId) -> TxId -> TxId
forall a b. (a -> b) -> a -> b
$
    forall era. EraTxBody era => TxBody era -> TxId
Ledger.txIdTxBody @LedgerEra (TxBody (ShelleyLedgerEra Era) -> TxId)
-> TxBody (ShelleyLedgerEra Era) -> TxId
forall a b. (a -> b) -> a -> b
$
      TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
forall era. EraTxBody era => TxBody era
Ledger.mkBasicTxBody

makeTxOut :: AddressAny -> Value -> TxOutDatum CtxTx Era -> ReferenceScript Era -> TxOut CtxUTxO Era
makeTxOut :: AddressAny
-> Value
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxUTxO Era
makeTxOut AddressAny
addr Value
value TxOutDatum CtxTx Era
datum ReferenceScript Era
refScript =
  TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut (TxOut CtxTx Era -> TxOut CtxUTxO Era)
-> TxOut CtxTx Era -> TxOut CtxUTxO Era
forall a b. (a -> b) -> a -> b
$
    AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut
      (ShelleyBasedEra Era -> AddressAny -> AddressInEra Era
forall era. ShelleyBasedEra era -> AddressAny -> AddressInEra era
anyAddressInShelleyBasedEra ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra AddressAny
addr)
      (ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Value -> MaryValue
toMaryValue Value
value))
      TxOutDatum CtxTx Era
datum
      ReferenceScript Era
refScript

txSigners :: Tx Era -> [Hash PaymentKey]
txSigners :: Tx Era -> [Hash PaymentKey]
txSigners (Tx TxBody Era
_ [KeyWitness Era]
wits) = [VKey 'Witness -> Hash PaymentKey
forall {r :: KeyRole}. VKey r -> Hash PaymentKey
toHash VKey 'Witness
wit | ShelleyKeyWitness ShelleyBasedEra Era
_ (WitVKey VKey 'Witness
wit SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
_) <- [KeyWitness Era]
wits]
 where
  toHash :: VKey r -> Hash PaymentKey
toHash =
    KeyHash 'Payment -> Hash PaymentKey
PaymentKeyHash
      (KeyHash 'Payment -> Hash PaymentKey)
-> (VKey r -> KeyHash 'Payment) -> VKey r -> Hash PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey 'Payment -> KeyHash 'Payment
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey
      (VKey 'Payment -> KeyHash 'Payment)
-> (VKey r -> VKey 'Payment) -> VKey r -> KeyHash 'Payment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VKey r -> VKey 'Payment
forall (r :: KeyRole) (r' :: KeyRole). VKey r -> VKey r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole

mockWalletHashes :: [(Hash PaymentKey, Wallet)]
mockWalletHashes :: [(Hash PaymentKey, Wallet)]
mockWalletHashes = (Wallet -> (Hash PaymentKey, Wallet))
-> [Wallet] -> [(Hash PaymentKey, Wallet)]
forall a b. (a -> b) -> [a] -> [b]
map (\Wallet
w -> (Wallet -> Hash PaymentKey
Wallet.verificationKeyHash Wallet
w, Wallet
w)) [Wallet]
mockWallets

{- | Detect which mock wallet signed a transaction by examining its witnesses.
Returns an error message if no known mock wallet is found among the signers.
-}
detectSigningWallet :: Tx Era -> Either String Wallet
detectSigningWallet :: Tx Era -> Either String Wallet
detectSigningWallet Tx Era
tx =
  case Tx Era -> [Hash PaymentKey]
txSigners Tx Era
tx of
    [] -> String -> Either String Wallet
forall a b. a -> Either a b
Left String
"Transaction has no signers — cannot determine wallet for threat model"
    [Hash PaymentKey]
signers ->
      case (Hash PaymentKey -> Maybe Wallet) -> [Hash PaymentKey] -> [Wallet]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Hash PaymentKey
h -> Hash PaymentKey -> [(Hash PaymentKey, Wallet)] -> Maybe Wallet
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Hash PaymentKey
h [(Hash PaymentKey, Wallet)]
mockWalletHashes) [Hash PaymentKey]
signers of
        (Wallet
w : [Wallet]
_) -> Wallet -> Either String Wallet
forall a b. b -> Either a b
Right Wallet
w
        [] -> String -> Either String Wallet
forall a b. a -> Either a b
Left String
"Transaction signers do not match any known mock wallet"

-- | Get the required signers from the transaction body (not witnesses).
txRequiredSigners :: Tx Era -> [Hash PaymentKey]
txRequiredSigners :: Tx Era -> [Hash PaymentKey]
txRequiredSigners (Tx (ShelleyTxBody ShelleyBasedEra Era
_ TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
_ TxBodyScriptData Era
_ Maybe (TxAuxData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_) =
  (KeyHash 'Witness -> Hash PaymentKey)
-> [KeyHash 'Witness] -> [Hash PaymentKey]
forall a b. (a -> b) -> [a] -> [b]
map (KeyHash 'Payment -> Hash PaymentKey
PaymentKeyHash (KeyHash 'Payment -> Hash PaymentKey)
-> (KeyHash 'Witness -> KeyHash 'Payment)
-> KeyHash 'Witness
-> Hash PaymentKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash 'Witness -> KeyHash 'Payment
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole) ([KeyHash 'Witness] -> [Hash PaymentKey])
-> (Set (KeyHash 'Witness) -> [KeyHash 'Witness])
-> Set (KeyHash 'Witness)
-> [Hash PaymentKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (KeyHash 'Witness) -> [KeyHash 'Witness]
forall a. Set a -> [a]
Set.toList (Set (KeyHash 'Witness) -> [Hash PaymentKey])
-> Set (KeyHash 'Witness) -> [Hash PaymentKey]
forall a b. (a -> b) -> a -> b
$ TxBody ConwayEra -> Set (KeyHash 'Witness)
Conway.ctbReqSignerHashes TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body

{- | The transaction's body content. Rebuilding this deserialises every
output's datum and reference script, so a caller that needs more than one
projection of the same transaction should take the body content once and
use the @bodyContent*@ accessors (see 'Convex.ThreatModel.ThreatModelEnv',
which caches it per env).
-}
txBodyContentOf :: Tx Era -> TxBodyContent ViewTx Era
txBodyContentOf :: Tx Era -> TxBodyContent ViewTx Era
txBodyContentOf = TxBody Era -> TxBodyContent ViewTx Era
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent (TxBody Era -> TxBodyContent ViewTx Era)
-> (Tx Era -> TxBody Era) -> Tx Era -> TxBodyContent ViewTx Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx Era -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody

bodyContentInputs :: TxBodyContent ViewTx Era -> [TxIn]
bodyContentInputs :: TxBodyContent ViewTx Era -> [TxIn]
bodyContentInputs = ((TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn)
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn
forall a b. (a, b) -> a
fst ([(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn])
-> (TxBodyContent ViewTx Era
    -> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))])
-> TxBodyContent ViewTx Era
-> [TxIn]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBodyContent ViewTx Era
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))]
forall build era. TxBodyContent build era -> TxIns build era
txIns

bodyContentReferenceInputs :: TxBodyContent ViewTx Era -> [TxIn]
bodyContentReferenceInputs :: TxBodyContent ViewTx Era -> [TxIn]
bodyContentReferenceInputs TxBodyContent ViewTx Era
body =
  case TxBodyContent ViewTx Era -> TxInsReference ViewTx Era
forall build era.
TxBodyContent build era -> TxInsReference build era
txInsReference TxBodyContent ViewTx Era
body of
    TxInsReference ViewTx Era
TxInsReferenceNone -> []
    TxInsReference BabbageEraOnwards Era
_ [TxIn]
txins TxInsReferenceDatums ViewTx
_ -> [TxIn]
txins

bodyContentOutputs :: TxBodyContent ViewTx Era -> [TxOut CtxTx Era]
bodyContentOutputs :: TxBodyContent ViewTx Era -> [TxOut CtxTx Era]
bodyContentOutputs = TxBodyContent ViewTx Era -> [TxOut CtxTx Era]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txOuts

txOutputs :: Tx Era -> [TxOut CtxTx Era]
txOutputs :: Tx Era -> [TxOut CtxTx Era]
txOutputs = TxBodyContent ViewTx Era -> [TxOut CtxTx Era]
bodyContentOutputs (TxBodyContent ViewTx Era -> [TxOut CtxTx Era])
-> (Tx Era -> TxBodyContent ViewTx Era)
-> Tx Era
-> [TxOut CtxTx Era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx Era -> TxBodyContent ViewTx Era
txBodyContentOf

-- | Check if a value is less or equal than another value.
leqValue :: Value -> Value -> Bool
leqValue :: Value -> Value -> Bool
leqValue Value
v Value
v' = ((AssetId, Quantity) -> Bool) -> [(AssetId, Quantity)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
<= Quantity
0) (Quantity -> Bool)
-> ((AssetId, Quantity) -> Quantity) -> (AssetId, Quantity) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AssetId, Quantity) -> Quantity
forall a b. (a, b) -> b
snd) (Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [Item Value]) -> Value -> [Item Value]
forall a b. (a -> b) -> a -> b
$ Value
v Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue Value
v')

-- | Keep only the Ada part of a value.
projectAda :: Value -> Value
projectAda :: Value -> Value
projectAda = Coin -> Value
lovelaceToValue (Coin -> Value) -> (Value -> Coin) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Coin
selectLovelace

{- | The outcome of validating a transaction, mirroring the ledger's two-phase
validation: Phase 2 (script execution) only runs when Phase 1 (structural
ledger rules) passes, so no other combinations exist.
-}
data TxValidity
  = -- | Phase 1 and Phase 2 both passed
    Valid
  | -- | Rejected by Phase 1 ledger rules; scripts were never executed
    Phase1Invalid
  | -- | Phase 1 passed, but a script rejected the transaction
    Phase2Invalid
  deriving stock (Eq TxValidity
Eq TxValidity =>
(TxValidity -> TxValidity -> Ordering)
-> (TxValidity -> TxValidity -> Bool)
-> (TxValidity -> TxValidity -> Bool)
-> (TxValidity -> TxValidity -> Bool)
-> (TxValidity -> TxValidity -> Bool)
-> (TxValidity -> TxValidity -> TxValidity)
-> (TxValidity -> TxValidity -> TxValidity)
-> Ord TxValidity
TxValidity -> TxValidity -> Bool
TxValidity -> TxValidity -> Ordering
TxValidity -> TxValidity -> TxValidity
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TxValidity -> TxValidity -> Ordering
compare :: TxValidity -> TxValidity -> Ordering
$c< :: TxValidity -> TxValidity -> Bool
< :: TxValidity -> TxValidity -> Bool
$c<= :: TxValidity -> TxValidity -> Bool
<= :: TxValidity -> TxValidity -> Bool
$c> :: TxValidity -> TxValidity -> Bool
> :: TxValidity -> TxValidity -> Bool
$c>= :: TxValidity -> TxValidity -> Bool
>= :: TxValidity -> TxValidity -> Bool
$cmax :: TxValidity -> TxValidity -> TxValidity
max :: TxValidity -> TxValidity -> TxValidity
$cmin :: TxValidity -> TxValidity -> TxValidity
min :: TxValidity -> TxValidity -> TxValidity
Ord, TxValidity -> TxValidity -> Bool
(TxValidity -> TxValidity -> Bool)
-> (TxValidity -> TxValidity -> Bool) -> Eq TxValidity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxValidity -> TxValidity -> Bool
== :: TxValidity -> TxValidity -> Bool
$c/= :: TxValidity -> TxValidity -> Bool
/= :: TxValidity -> TxValidity -> Bool
Eq, Int -> TxValidity -> ShowS
[TxValidity] -> ShowS
TxValidity -> String
(Int -> TxValidity -> ShowS)
-> (TxValidity -> String)
-> ([TxValidity] -> ShowS)
-> Show TxValidity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxValidity -> ShowS
showsPrec :: Int -> TxValidity -> ShowS
$cshow :: TxValidity -> String
show :: TxValidity -> String
$cshowList :: [TxValidity] -> ShowS
showList :: [TxValidity] -> ShowS
Show)

{- | The result of validating a transaction. In case of failure, it includes a list
  of reasons.
-}
data ValidityReport = ValidityReport
  { ValidityReport -> [String]
errors :: [String]
  , ValidityReport -> TxValidity
validity :: TxValidity
  }
  deriving stock (Eq ValidityReport
Eq ValidityReport =>
(ValidityReport -> ValidityReport -> Ordering)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> ValidityReport)
-> (ValidityReport -> ValidityReport -> ValidityReport)
-> Ord ValidityReport
ValidityReport -> ValidityReport -> Bool
ValidityReport -> ValidityReport -> Ordering
ValidityReport -> ValidityReport -> ValidityReport
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ValidityReport -> ValidityReport -> Ordering
compare :: ValidityReport -> ValidityReport -> Ordering
$c< :: ValidityReport -> ValidityReport -> Bool
< :: ValidityReport -> ValidityReport -> Bool
$c<= :: ValidityReport -> ValidityReport -> Bool
<= :: ValidityReport -> ValidityReport -> Bool
$c> :: ValidityReport -> ValidityReport -> Bool
> :: ValidityReport -> ValidityReport -> Bool
$c>= :: ValidityReport -> ValidityReport -> Bool
>= :: ValidityReport -> ValidityReport -> Bool
$cmax :: ValidityReport -> ValidityReport -> ValidityReport
max :: ValidityReport -> ValidityReport -> ValidityReport
$cmin :: ValidityReport -> ValidityReport -> ValidityReport
min :: ValidityReport -> ValidityReport -> ValidityReport
Ord, ValidityReport -> ValidityReport -> Bool
(ValidityReport -> ValidityReport -> Bool)
-> (ValidityReport -> ValidityReport -> Bool) -> Eq ValidityReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidityReport -> ValidityReport -> Bool
== :: ValidityReport -> ValidityReport -> Bool
$c/= :: ValidityReport -> ValidityReport -> Bool
/= :: ValidityReport -> ValidityReport -> Bool
Eq, Int -> ValidityReport -> ShowS
[ValidityReport] -> ShowS
ValidityReport -> String
(Int -> ValidityReport -> ShowS)
-> (ValidityReport -> String)
-> ([ValidityReport] -> ShowS)
-> Show ValidityReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidityReport -> ShowS
showsPrec :: Int -> ValidityReport -> ShowS
$cshow :: ValidityReport -> String
show :: ValidityReport -> String
$cshowList :: [ValidityReport] -> ShowS
showList :: [ValidityReport] -> ShowS
Show)

{- | Validate a transaction using Phase 2 (script execution) validation only.

This uses evaluateTransactionExecutionUnits to check if Plutus scripts would
accept or reject the transaction. It does NOT validate Phase 1 ledger rules
(fees, signatures, value preservation, etc.) because threat model modifications
alter the transaction body, invalidating signatures and fee calculations.

The purpose of threat models is to test script logic, not transaction construction.
-}
validateTx :: LedgerProtocolParameters Era -> Tx Era -> UTxO Era -> ValidityReport
validateTx :: LedgerProtocolParameters Era
-> Tx Era -> UTxO Era -> ValidityReport
validateTx LedgerProtocolParameters Era
pparams Tx Era
tx UTxO Era
utxos =
  ValidityReport
    { errors :: [String]
errors = [ScriptExecutionError -> String
forall a. Show a => a -> String
show ScriptExecutionError
e | Left ScriptExecutionError
e <- Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> [Either
      ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)]
forall k a. Map k a -> [a]
Map.elems Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
report]
    , validity :: TxValidity
validity = if (Either
   ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
 -> Bool)
-> [Either
      ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either
  ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
-> Bool
forall a b. Either a b -> Bool
isRight (Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> [Either
      ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)]
forall k a. Map k a -> [a]
Map.elems Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
report) then TxValidity
Valid else TxValidity
Phase2Invalid
    }
 where
  report :: Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
report =
    CardanoEra Era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters Era
-> UTxO Era
-> TxBody Era
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
forall era.
CardanoEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> TxBody era
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
evaluateTransactionExecutionUnits
      CardanoEra Era
ConwayEra
      SystemStart
systemStart
      (EraHistory -> LedgerEpochInfo
toLedgerEpochInfo EraHistory
eraHistory)
      LedgerProtocolParameters Era
pparams
      UTxO Era
utxos
      (Tx Era -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx)

  eraHistory :: EraHistory
  eraHistory :: EraHistory
eraHistory = Interpreter (CardanoEras StandardCrypto) -> EraHistory
forall (xs :: [*]).
(CardanoBlock StandardCrypto ~ HardForkBlock xs) =>
Interpreter xs -> EraHistory
EraHistory (Summary (CardanoEras StandardCrypto)
-> Interpreter (CardanoEras StandardCrypto)
forall (xs :: [*]). Summary xs -> Interpreter xs
History.mkInterpreter Summary (CardanoEras StandardCrypto)
summary)

  summary :: History.Summary (CardanoEras StandardCrypto)
  summary :: Summary (CardanoEras StandardCrypto)
summary =
    NonEmpty (CardanoEras StandardCrypto) EraSummary
-> Summary (CardanoEras StandardCrypto)
forall (xs :: [*]). NonEmpty xs EraSummary -> Summary xs
History.Summary (NonEmpty (CardanoEras StandardCrypto) EraSummary
 -> Summary (CardanoEras StandardCrypto))
-> (EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary)
-> EraSummary
-> Summary (CardanoEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary
forall a x (xs1 :: [*]). a -> NonEmpty (x : xs1) a
NonEmptyOne (EraSummary -> Summary (CardanoEras StandardCrypto))
-> EraSummary -> Summary (CardanoEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$
      History.EraSummary
        { eraStart :: Bound
History.eraStart = Bound
History.initBound
        , eraEnd :: EraEnd
History.eraEnd = EraEnd
History.EraUnbounded
        , eraParams :: EraParams
History.eraParams =
            History.EraParams
              { eraEpochSize :: EpochSize
History.eraEpochSize = EpochSize
epochSize
              , eraSlotLength :: SlotLength
History.eraSlotLength = SlotLength
slotLength
              , eraSafeZone :: SafeZone
History.eraSafeZone = SafeZone
History.UnsafeIndefiniteSafeZone
              , eraGenesisWin :: GenesisWindow
History.eraGenesisWin = GenesisWindow
genesisWindow
              }
        }

  epochSize :: EpochSize
  epochSize :: EpochSize
epochSize = Word64 -> EpochSize
EpochSize Word64
100

  slotLength :: SlotLength
  slotLength :: SlotLength
slotLength = POSIXTime -> SlotLength
mkSlotLength POSIXTime
1

  systemStart :: SystemStart
  systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0

  genesisWindow :: GenesisWindow
  genesisWindow :: GenesisWindow
genesisWindow = Word64 -> GenesisWindow
GenesisWindow Word64
10

-- | Keep only UTxOs mentioned in the given transaction.
restrictUTxO :: Tx Era -> UTxO Era -> UTxO Era
restrictUTxO :: Tx Era -> UTxO Era -> UTxO Era
restrictUTxO Tx Era
tx (UTxO Map TxIn (TxOut CtxUTxO Era)
utxo) =
  Map TxIn (TxOut CtxUTxO Era) -> UTxO Era
forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
UTxO (Map TxIn (TxOut CtxUTxO Era) -> UTxO Era)
-> Map TxIn (TxOut CtxUTxO Era) -> UTxO Era
forall a b. (a -> b) -> a -> b
$
    (TxIn -> TxOut CtxUTxO Era -> Bool)
-> Map TxIn (TxOut CtxUTxO Era) -> Map TxIn (TxOut CtxUTxO Era)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
      ( \TxIn
k TxOut CtxUTxO Era
_ ->
          TxIn
k TxIn -> [TxIn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn)
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era)) -> TxIn
forall a b. (a, b) -> a
fst (TxBodyContent ViewTx Era
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))]
forall build era. TxBodyContent build era -> TxIns build era
txIns TxBodyContent ViewTx Era
body)
            Bool -> Bool -> Bool
|| TxIn
k TxIn -> [TxIn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TxInsReference ViewTx Era -> [TxIn]
forall {build} {era}. TxInsReference build era -> [TxIn]
toInputList (TxBodyContent ViewTx Era -> TxInsReference ViewTx Era
forall build era.
TxBodyContent build era -> TxInsReference build era
txInsReference TxBodyContent ViewTx Era
body)
      )
      Map TxIn (TxOut CtxUTxO Era)
utxo
 where
  body :: TxBodyContent ViewTx Era
body = TxBody Era -> TxBodyContent ViewTx Era
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent (TxBody Era -> TxBodyContent ViewTx Era)
-> TxBody Era -> TxBodyContent ViewTx Era
forall a b. (a -> b) -> a -> b
$ Tx Era -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx
  toInputList :: TxInsReference build era -> [TxIn]
toInputList (TxInsReference BabbageEraOnwards era
_ [TxIn]
ins TxInsReferenceDatums build
_) = [TxIn]
ins
  toInputList TxInsReference build era
_ = []

convValidityInterval
  :: (TxValidityLowerBound era, TxValidityUpperBound era)
  -> ValidityInterval
convValidityInterval :: forall era.
(TxValidityLowerBound era, TxValidityUpperBound era)
-> ValidityInterval
convValidityInterval (TxValidityLowerBound era
lowerBound, TxValidityUpperBound era
upperBound) =
  ValidityInterval
    { invalidBefore :: StrictMaybe SlotNo
invalidBefore = case TxValidityLowerBound era
lowerBound of
        TxValidityLowerBound era
TxValidityNoLowerBound -> StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
        TxValidityLowerBound AllegraEraOnwards era
_ SlotNo
s -> SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
s
    , invalidHereafter :: StrictMaybe SlotNo
invalidHereafter = case TxValidityUpperBound era
upperBound of
        TxValidityUpperBound ShelleyBasedEra era
_ Maybe SlotNo
Nothing -> StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
        TxValidityUpperBound ShelleyBasedEra era
_ (Just SlotNo
s) -> SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust SlotNo
s
    }

-- | The UTxO set of a chain state.
chainStateUTxO :: MockChainState Era -> UTxO Era
chainStateUTxO :: MockChainState Era -> UTxO Era
chainStateUTxO = ShelleyBasedEra Era -> UTxO (ShelleyLedgerEra Era) -> UTxO Era
forall era.
ShelleyBasedEra era -> UTxO (ShelleyLedgerEra era) -> UTxO era
fromLedgerUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (UTxO ConwayEra -> UTxO Era)
-> (MockChainState Era -> UTxO ConwayEra)
-> MockChainState Era
-> UTxO Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MockChainState Era -> UTxO (ShelleyLedgerEra Era)
MockChainState Era -> UTxO ConwayEra
chainStateLedgerUTxO

{- | The chain state's UTxO set in ledger form, which is how it is actually
stored. 'chainStateUTxO' converts it to the api type; anything that only
feeds it back to a ledger function should take this instead and skip the
round trip.
-}
chainStateLedgerUTxO :: MockChainState Era -> Ledger.UTxO LedgerEra
chainStateLedgerUTxO :: MockChainState Era -> UTxO (ShelleyLedgerEra Era)
chainStateLedgerUTxO MockChainState Era
state = MockChainState Era
state MockChainState Era
-> Getting (UTxO ConwayEra) (MockChainState Era) (UTxO ConwayEra)
-> UTxO ConwayEra
forall s a. s -> Getting a s a -> a
^. (MempoolState (ShelleyLedgerEra Era)
 -> Const (UTxO ConwayEra) (MempoolState (ShelleyLedgerEra Era)))
-> MockChainState Era
-> Const (UTxO ConwayEra) (MockChainState Era)
(LedgerState ConwayEra
 -> Const (UTxO ConwayEra) (LedgerState ConwayEra))
-> MockChainState Era
-> Const (UTxO ConwayEra) (MockChainState Era)
forall era (f :: * -> *).
Functor f =>
(MempoolState (ShelleyLedgerEra era)
 -> f (MempoolState (ShelleyLedgerEra era)))
-> MockChainState era -> f (MockChainState era)
poolState ((LedgerState ConwayEra
  -> Const (UTxO ConwayEra) (LedgerState ConwayEra))
 -> MockChainState Era
 -> Const (UTxO ConwayEra) (MockChainState Era))
-> ((UTxO ConwayEra -> Const (UTxO ConwayEra) (UTxO ConwayEra))
    -> LedgerState ConwayEra
    -> Const (UTxO ConwayEra) (LedgerState ConwayEra))
-> Getting (UTxO ConwayEra) (MockChainState Era) (UTxO ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState ConwayEra
 -> Const (UTxO ConwayEra) (UTxOState ConwayEra))
-> LedgerState ConwayEra
-> Const (UTxO ConwayEra) (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
L.utxoState ((UTxOState ConwayEra
  -> Const (UTxO ConwayEra) (UTxOState ConwayEra))
 -> LedgerState ConwayEra
 -> Const (UTxO ConwayEra) (LedgerState ConwayEra))
-> ((UTxO ConwayEra -> Const (UTxO ConwayEra) (UTxO ConwayEra))
    -> UTxOState ConwayEra
    -> Const (UTxO ConwayEra) (UTxOState ConwayEra))
-> (UTxO ConwayEra -> Const (UTxO ConwayEra) (UTxO ConwayEra))
-> LedgerState ConwayEra
-> Const (UTxO ConwayEra) (LedgerState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
 -> Const
      (UTxO ConwayEra)
      (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin))
-> UTxOState ConwayEra
-> Const (UTxO ConwayEra) (UTxOState ConwayEra)
forall era.
EraStake era =>
Iso' (UTxOState era) (UTxO era, Coin, Coin, GovState era, Coin)
Iso'
  (UTxOState ConwayEra)
  (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
L._UTxOState (((UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
  -> Const
       (UTxO ConwayEra)
       (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin))
 -> UTxOState ConwayEra
 -> Const (UTxO ConwayEra) (UTxOState ConwayEra))
-> ((UTxO ConwayEra -> Const (UTxO ConwayEra) (UTxO ConwayEra))
    -> (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
    -> Const
         (UTxO ConwayEra)
         (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin))
-> (UTxO ConwayEra -> Const (UTxO ConwayEra) (UTxO ConwayEra))
-> UTxOState ConwayEra
-> Const (UTxO ConwayEra) (UTxOState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxO ConwayEra -> Const (UTxO ConwayEra) (UTxO ConwayEra))
-> (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
-> Const
     (UTxO ConwayEra)
     (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
  (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
  (UTxO ConwayEra)
  (UTxO ConwayEra)
_1

-- | The protocol parameters a chain state validates with.
chainStatePParams :: MockChainState Era -> LedgerProtocolParameters Era
chainStatePParams :: MockChainState Era -> LedgerProtocolParameters Era
chainStatePParams MockChainState Era
state = PParams (ShelleyLedgerEra Era) -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters (LedgerEnv ConwayEra -> PParams ConwayEra
forall era. LedgerEnv era -> PParams era
ledgerPp (MockChainState Era
state MockChainState Era
-> Getting
     (LedgerEnv ConwayEra) (MockChainState Era) (LedgerEnv ConwayEra)
-> LedgerEnv ConwayEra
forall s a. s -> Getting a s a -> a
^. (MempoolEnv (ShelleyLedgerEra Era)
 -> Const (LedgerEnv ConwayEra) (MempoolEnv (ShelleyLedgerEra Era)))
-> MockChainState Era
-> Const (LedgerEnv ConwayEra) (MockChainState Era)
Getting
  (LedgerEnv ConwayEra) (MockChainState Era) (LedgerEnv ConwayEra)
forall era (f :: * -> *).
Functor f =>
(MempoolEnv (ShelleyLedgerEra era)
 -> f (MempoolEnv (ShelleyLedgerEra era)))
-> MockChainState era -> f (MockChainState era)
env))

{- | Build a MockChainState for validation: the given base state - typically
the state the original transaction validated against, so its certificate
state (stake registrations, deposits, DRep and pool state) is intact - with
the slot and the UTxO set replaced, and the accumulated coverage data
blanked. The base state carries the coverage of every honest transaction
replayed to reach it; blanking it makes the coverage read back after
applying a modified transaction exactly that transaction's own delta,
instead of honest-run coverage with the attack's mixed in.
-}
buildMockState
  :: MockChainState Era
  -> SlotNo
  -> UTxO Era
  -> MockChainState Era
buildMockState :: MockChainState Era -> SlotNo -> UTxO Era -> MockChainState Era
buildMockState MockChainState Era
baseState SlotNo
slot UTxO Era
utxo =
  MockChainState Era
baseState
    MockChainState Era
-> (MockChainState Era -> MockChainState Era) -> MockChainState Era
forall a b. a -> (a -> b) -> b
& (MempoolEnv (ShelleyLedgerEra Era)
 -> Identity (MempoolEnv (ShelleyLedgerEra Era)))
-> MockChainState Era -> Identity (MockChainState Era)
(LedgerEnv ConwayEra -> Identity (LedgerEnv ConwayEra))
-> MockChainState Era -> Identity (MockChainState Era)
forall era (f :: * -> *).
Functor f =>
(MempoolEnv (ShelleyLedgerEra era)
 -> f (MempoolEnv (ShelleyLedgerEra era)))
-> MockChainState era -> f (MockChainState era)
env ((LedgerEnv ConwayEra -> Identity (LedgerEnv ConwayEra))
 -> MockChainState Era -> Identity (MockChainState Era))
-> ((SlotNo -> Identity SlotNo)
    -> LedgerEnv ConwayEra -> Identity (LedgerEnv ConwayEra))
-> (SlotNo -> Identity SlotNo)
-> MockChainState Era
-> Identity (MockChainState Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo -> Identity SlotNo)
-> LedgerEnv ConwayEra -> Identity (LedgerEnv ConwayEra)
forall era (f :: * -> *).
Functor f =>
(SlotNo -> f SlotNo) -> LedgerEnv era -> f (LedgerEnv era)
L.slot ((SlotNo -> Identity SlotNo)
 -> MockChainState Era -> Identity (MockChainState Era))
-> SlotNo -> MockChainState Era -> MockChainState Era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SlotNo
slot
    MockChainState Era
-> (MockChainState Era -> MockChainState Era) -> MockChainState Era
forall a b. a -> (a -> b) -> b
& (MempoolState (ShelleyLedgerEra Era)
 -> Identity (MempoolState (ShelleyLedgerEra Era)))
-> MockChainState Era -> Identity (MockChainState Era)
(LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> MockChainState Era -> Identity (MockChainState Era)
forall era (f :: * -> *).
Functor f =>
(MempoolState (ShelleyLedgerEra era)
 -> f (MempoolState (ShelleyLedgerEra era)))
-> MockChainState era -> f (MockChainState era)
poolState ((LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
 -> MockChainState Era -> Identity (MockChainState Era))
-> ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
    -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> MockChainState Era
-> Identity (MockChainState Era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
-> LedgerState ConwayEra -> Identity (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
L.utxoState ((UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
 -> LedgerState ConwayEra -> Identity (LedgerState ConwayEra))
-> ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
    -> UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
-> (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> LedgerState ConwayEra
-> Identity (LedgerState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
 -> Identity (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin))
-> UTxOState ConwayEra -> Identity (UTxOState ConwayEra)
forall era.
EraStake era =>
Iso' (UTxOState era) (UTxO era, Coin, Coin, GovState era, Coin)
Iso'
  (UTxOState ConwayEra)
  (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
L._UTxOState (((UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
  -> Identity (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin))
 -> UTxOState ConwayEra -> Identity (UTxOState ConwayEra))
-> ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
    -> (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
    -> Identity (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin))
-> (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> UTxOState ConwayEra
-> Identity (UTxOState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxO ConwayEra -> Identity (UTxO ConwayEra))
-> (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
-> Identity (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
  (UTxO ConwayEra, Coin, Coin, GovState ConwayEra, Coin)
  (UTxO ConwayEra)
  (UTxO ConwayEra)
_1 ((UTxO ConwayEra -> Identity (UTxO ConwayEra))
 -> MockChainState Era -> Identity (MockChainState Era))
-> UTxO ConwayEra -> MockChainState Era -> MockChainState Era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ShelleyBasedEra Era -> UTxO Era -> UTxO (ShelleyLedgerEra Era)
forall era.
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
toLedgerUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra UTxO Era
utxo
    MockChainState Era
-> (MockChainState Era -> MockChainState Era) -> MockChainState Era
forall a b. a -> (a -> b) -> b
& (CoverageData -> Identity CoverageData)
-> MockChainState Era -> Identity (MockChainState Era)
forall era (f :: * -> *).
Functor f =>
(CoverageData -> f CoverageData)
-> MockChainState era -> f (MockChainState era)
coverageData ((CoverageData -> Identity CoverageData)
 -> MockChainState Era -> Identity (MockChainState Era))
-> CoverageData -> MockChainState Era -> MockChainState Era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CoverageData
forall a. Monoid a => a
mempty

{- | Check if an 'ApplyTxError' contains a Phase 2 (script execution) failure.

The only genuine Phase 2 signal in an 'ApplyTxError' is 'ValidationTagMismatch':
the ledger re-ran the scripts and their result contradicts the transaction's
'IsValid' flag.

'CollectErrors' is deliberately not treated as Phase 2: its cases
('NoRedeemer', 'NoWitness', 'NoCostModel', 'BadTranslation') mean script
execution never started, which is Phase 1 in nature. It is also unreachable
here: the mockchain collects scripts in 'constructValidated' before 'applyTx'
and returns such failures as 'MockchainError', never as 'ApplyTxError'.
-}
hasPhase2Failure :: ApplyTxError LedgerEra -> Bool
hasPhase2Failure :: ApplyTxError (ShelleyLedgerEra Era) -> Bool
hasPhase2Failure (ApplyTxError NonEmpty
  (PredicateFailure (EraRule "LEDGER" (ShelleyLedgerEra Era)))
failures) = (ConwayLedgerPredFailure ConwayEra -> Bool)
-> NonEmpty (ConwayLedgerPredFailure ConwayEra) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ConwayLedgerPredFailure ConwayEra -> Bool
forall {era} {era} {era} {era}.
(PredicateFailure (EraRule "UTXO" era) ~ ConwayUtxoPredFailure era,
 PredicateFailure (EraRule "UTXOW" era)
 ~ ConwayUtxowPredFailure era,
 PredicateFailure (EraRule "UTXOS" era)
 ~ ConwayUtxosPredFailure era) =>
ConwayLedgerPredFailure era -> Bool
isPhase2 NonEmpty
  (PredicateFailure (EraRule "LEDGER" (ShelleyLedgerEra Era)))
NonEmpty (ConwayLedgerPredFailure ConwayEra)
failures
 where
  isPhase2 :: ConwayLedgerPredFailure era -> Bool
isPhase2 (ConwayUtxowFailure (UtxoFailure (UtxosFailure ValidationTagMismatch{}))) = Bool
True
  isPhase2 ConwayLedgerPredFailure era
_ = Bool
False

{- | Validate a transaction with full Phase 1 + Phase 2 validation inside MockchainT.

This uses 'applyTransaction' which performs complete ledger validation including:
- Fee adequacy
- Signature verification
- UTxO existence
- Value preservation
- Validity intervals
- Collateral requirements
- Script execution (Phase 2)
-}
validateTxM
  :: (MonadMockchain Era m)
  => NodeParams Era
  -> MockChainState Era
  {- ^ The state the original transaction validated against (see
  'currentChainState'); its slot and UTxO set are replaced below.
  -}
  -> Tx Era
  -> UTxO Era
  -> m (ValidityReport, CoverageData)
validateTxM :: forall (m :: * -> *).
MonadMockchain Era m =>
NodeParams Era
-> MockChainState Era
-> Tx Era
-> UTxO Era
-> m (ValidityReport, CoverageData)
validateTxM NodeParams Era
params MockChainState Era
baseState Tx Era
tx UTxO Era
utxo = do
  -- Validate at a slot within the transaction's own validity interval (like
  -- 'threatModelEnvs' does when replaying). Otherwise the ledger rejects the
  -- transaction with 'OutsideValidityIntervalUTxO' (Phase 1) whenever the
  -- current mockchain slot falls outside the interval, masking any Phase 2
  -- script failure.
  let txBodyContent :: TxBodyContent ViewTx Era
txBodyContent = TxBody Era -> TxBodyContent ViewTx Era
forall era. TxBody era -> TxBodyContent ViewTx era
getTxBodyContent (TxBody Era -> TxBodyContent ViewTx Era)
-> TxBody Era -> TxBodyContent ViewTx Era
forall a b. (a -> b) -> a -> b
$ Tx Era -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx
  (TxValidityLowerBound Era, TxValidityUpperBound Era) -> m ()
forall era (m :: * -> *).
MonadMockchain era m =>
(TxValidityLowerBound era, TxValidityUpperBound era) -> m ()
setTimeToValidRange (TxBodyContent ViewTx Era -> TxValidityLowerBound Era
forall build era.
TxBodyContent build era -> TxValidityLowerBound era
txValidityLowerBound TxBodyContent ViewTx Era
txBodyContent, TxBodyContent ViewTx Era -> TxValidityUpperBound Era
forall build era.
TxBodyContent build era -> TxValidityUpperBound era
txValidityUpperBound TxBodyContent ViewTx Era
txBodyContent)
  SlotNo
slot <- m SlotNo
forall era (m :: * -> *). MonadMockchain era m => m SlotNo
getSlot
  let mockState :: MockChainState Era
mockState = MockChainState Era -> SlotNo -> UTxO Era -> MockChainState Era
buildMockState MockChainState Era
baseState SlotNo
slot UTxO Era
utxo
      NodeParams{SystemStart
npSystemStart :: SystemStart
npSystemStart :: forall era. NodeParams era -> SystemStart
npSystemStart, EraHistory
npEraHistory :: EraHistory
npEraHistory :: forall era. NodeParams era -> EraHistory
npEraHistory, LedgerProtocolParameters Era
npProtocolParameters :: LedgerProtocolParameters Era
npProtocolParameters :: forall era. NodeParams era -> LedgerProtocolParameters era
npProtocolParameters} = NodeParams Era
params
  (ValidityReport, CoverageData) -> m (ValidityReport, CoverageData)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ValidityReport, CoverageData)
 -> m (ValidityReport, CoverageData))
-> (ValidityReport, CoverageData)
-> m (ValidityReport, CoverageData)
forall a b. (a -> b) -> a -> b
$ case NodeParams Era
-> MockChainState Era
-> Tx Era
-> Either
     (SendTxError Era)
     (MockChainState Era, Validated (Tx (ShelleyLedgerEra Era)))
forall era.
(EraStake (ShelleyLedgerEra era), IsEra era,
 IsAlonzoBasedEra era) =>
NodeParams era
-> MockChainState era
-> Tx era
-> Either
     (SendTxError era)
     (MockChainState era, Validated (Tx (ShelleyLedgerEra era)))
applyTransaction NodeParams Era
params MockChainState Era
mockState Tx Era
tx of
    Left (ApplyTxFailure ApplyTxError (ShelleyLedgerEra Era)
err)
      | ApplyTxError (ShelleyLedgerEra Era) -> Bool
hasPhase2Failure ApplyTxError (ShelleyLedgerEra Era)
err ->
          let (CoverageData
covData, [String]
errors) =
                Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> (CoverageData, [String])
forall k b.
Map k (Either ScriptExecutionError b) -> (CoverageData, [String])
extractFromExUnits (Map
   ScriptWitnessIndex
   (Either
      ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
 -> (CoverageData, [String]))
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> (CoverageData, [String])
forall a b. (a -> b) -> a -> b
$
                  CardanoEra Era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters Era
-> UTxO Era
-> TxBody Era
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
forall era.
CardanoEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> TxBody era
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
evaluateTransactionExecutionUnits
                    CardanoEra Era
ConwayEra
                    SystemStart
npSystemStart
                    (EraHistory -> LedgerEpochInfo
toLedgerEpochInfo EraHistory
npEraHistory)
                    LedgerProtocolParameters Era
npProtocolParameters
                    UTxO Era
utxo
                    (Tx Era -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx)
           in (ValidityReport{[String]
errors :: [String]
errors :: [String]
errors, validity :: TxValidity
validity = TxValidity
Phase2Invalid}, CoverageData
covData)
      | Bool
otherwise ->
          (ValidityReport{errors :: [String]
errors = [ApplyTxError ConwayEra -> String
forall a. Show a => a -> String
show ApplyTxError (ShelleyLedgerEra Era)
ApplyTxError ConwayEra
err], validity :: TxValidity
validity = TxValidity
Phase1Invalid}, CoverageData
forall a. Monoid a => a
mempty)
    Left (MockchainError (VExUnits (Phase2Error (ScriptErrorEvaluationFailed DebugPlutusFailure{EvaluationError
dpfEvaluationError :: EvaluationError
dpfEvaluationError :: DebugPlutusFailure -> EvaluationError
dpfEvaluationError, EvalTxExecutionUnitsLog
dpfExecutionLogs :: EvalTxExecutionUnitsLog
dpfExecutionLogs :: DebugPlutusFailure -> EvalTxExecutionUnitsLog
dpfExecutionLogs})))) ->
      (ValidityReport{errors :: [String]
errors = [EvaluationError -> String
forall a. Show a => a -> String
show EvaluationError
dpfEvaluationError], validity :: TxValidity
validity = TxValidity
Phase2Invalid}, (Text -> CoverageData) -> EvalTxExecutionUnitsLog -> CoverageData
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> CoverageData
coverageDataFromLogMsg (String -> CoverageData)
-> (Text -> String) -> Text -> CoverageData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) EvalTxExecutionUnitsLog
dpfExecutionLogs)
    Left SendTxError Era
err -> (ValidityReport{errors :: [String]
errors = [SendTxError Era -> String
forall a. Show a => a -> String
show SendTxError Era
err], validity :: TxValidity
validity = TxValidity
Phase1Invalid}, CoverageData
forall a. Monoid a => a
mempty)
    Right (MockChainState Era
state', Validated (Tx (ShelleyLedgerEra Era))
_) -> (ValidityReport{errors :: [String]
errors = [], validity :: TxValidity
validity = TxValidity
Valid}, MockChainState Era
state' MockChainState Era
-> Getting CoverageData (MockChainState Era) CoverageData
-> CoverageData
forall s a. s -> Getting a s a -> a
^. Getting CoverageData (MockChainState Era) CoverageData
forall era (f :: * -> *).
Functor f =>
(CoverageData -> f CoverageData)
-> MockChainState era -> f (MockChainState era)
coverageData)

extractFromExUnits :: Map.Map k (Either ScriptExecutionError b) -> (CoverageData, [String])
extractFromExUnits :: forall k b.
Map k (Either ScriptExecutionError b) -> (CoverageData, [String])
extractFromExUnits = (Either ScriptExecutionError b -> (CoverageData, [String]))
-> [Either ScriptExecutionError b] -> (CoverageData, [String])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Either ScriptExecutionError b -> (CoverageData, [String])
forall {b}.
Either ScriptExecutionError b -> (CoverageData, [String])
fromScriptResult ([Either ScriptExecutionError b] -> (CoverageData, [String]))
-> (Map k (Either ScriptExecutionError b)
    -> [Either ScriptExecutionError b])
-> Map k (Either ScriptExecutionError b)
-> (CoverageData, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (Either ScriptExecutionError b)
-> [Either ScriptExecutionError b]
forall k a. Map k a -> [a]
Map.elems
 where
  fromScriptResult :: Either ScriptExecutionError b -> (CoverageData, [String])
fromScriptResult (Left (ScriptErrorEvaluationFailed DebugPlutusFailure{EvalTxExecutionUnitsLog
dpfExecutionLogs :: DebugPlutusFailure -> EvalTxExecutionUnitsLog
dpfExecutionLogs :: EvalTxExecutionUnitsLog
dpfExecutionLogs, EvaluationError
dpfEvaluationError :: DebugPlutusFailure -> EvaluationError
dpfEvaluationError :: EvaluationError
dpfEvaluationError})) =
    ( (Text -> CoverageData) -> EvalTxExecutionUnitsLog -> CoverageData
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> CoverageData
coverageDataFromLogMsg (String -> CoverageData)
-> (Text -> String) -> Text -> CoverageData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) EvalTxExecutionUnitsLog
dpfExecutionLogs
    , [EvaluationError -> String
forall a. Show a => a -> String
show EvaluationError
dpfEvaluationError]
    )
  fromScriptResult Either ScriptExecutionError b
_ = (CoverageData
forall a. Monoid a => a
mempty, [])

{- | Re-balance fees, recalculate execution units, and re-sign a modified transaction.

After applying TxModifier operations, the transaction body changes which:
1. Invalidates the original signatures (body hash changed)
2. May require different fees (outputs changed)
3. May have invalid execution units (for added scripts)

This function:
1. Recalculates execution units for all scripts
2. Calculates the new required fee
3. Adjusts the change output (the original transaction's change output,
   located in the modified one by 'adjustOriginalChangeOutput') to compensate
4. Re-signs the transaction with the wallet's key

A 'Left' means the modification cannot be realized as a well-formed
transaction on this particular input (e.g. "No change output found", or no
usable collateral input) - a limitation of this function, not a verdict on
the transaction. The threat-model runners all treat it as a skipped test
rather than an error.

The steps below have a load-bearing order: each one's comment explains what
it needs to see from the ones before it. In particular, everything that can
change the transaction's *size* has to be reflected in the shape the fee is
estimated from - 'topUpUnderfundedOutputs' and 'ensureCollateralInputShape'
run before it, and the change output's absorption of the residual is solved
*together with* the fee as a fixed point ('settle' below), because each
determines the other. Reordering or interleaving a new corrective step
would still compile - it would only show up as an intermittent
property-test failure (a wrong fee, or @BabbageOutputTooSmallUTxO@), so
check each step's comment before moving anything.
-}
rebalanceAndSign
  :: (MonadMockchain Era m)
  => MockChainState Era
  {- ^ The state the original transaction validated against (see
  'currentChainState'): deposits looked up for the value balance below
  must come from the same state the modified transaction is re-validated
  against.
  -}
  -> Wallet
  -> Tx Era
  {- ^ The original, unmodified transaction: its outputs identify which
  wallet output is the change output (see 'adjustOriginalChangeOutput').
  -}
  -> Tx Era
  -- ^ The modified transaction to rebalance
  -> UTxO Era
  -> m (Either String (Tx Era))
rebalanceAndSign :: forall (m :: * -> *).
MonadMockchain Era m =>
MockChainState Era
-> Wallet
-> Tx Era
-> Tx Era
-> UTxO Era
-> m (Either String (Tx Era))
rebalanceAndSign MockChainState Era
chainState Wallet
wallet Tx Era
originalTx Tx Era
tx UTxO Era
utxo = do
  LedgerProtocolParameters Era
pparams <- m (LedgerProtocolParameters Era)
forall era (m :: * -> *).
MonadBlockchain era m =>
m (LedgerProtocolParameters era)
Convex.Class.queryProtocolParameters
  NetworkId
networkId <- m NetworkId
forall era (m :: * -> *). MonadBlockchain era m => m NetworkId
Convex.Class.queryNetworkId
  SystemStart
systemStart <- m SystemStart
forall era (m :: * -> *). MonadBlockchain era m => m SystemStart
Convex.Class.querySystemStart
  EraHistory
eraHistory <- m EraHistory
forall era (m :: * -> *). MonadBlockchain era m => m EraHistory
Convex.Class.queryEraHistory

  let walletAddr :: AddressInEra Era
walletAddr = NetworkId -> Wallet -> AddressInEra Era
forall era.
IsShelleyBasedEra era =>
NetworkId -> Wallet -> AddressInEra era
Wallet.addressInEra NetworkId
networkId Wallet
wallet
      -- Hashing every key witness, so computed once and shared by the fee
      -- estimate and the re-signing step below.
      originalSigners :: [Hash PaymentKey]
originalSigners = Tx Era -> [Hash PaymentKey]
txSigners Tx Era
tx

  -- First, recalculate execution units for all scripts in the transaction.
  -- This is necessary because TxModifier may add scripts with ExecutionUnits
  -- 0 0. A structural evaluation failure (the modified transaction cannot be
  -- meaningfully executed at all) is a Left and skips the run; a script that
  -- runs and rejects is not an error here (see 'updateExecutionUnits').
  case LedgerProtocolParameters Era
-> SystemStart
-> EraHistory
-> UTxO Era
-> Tx Era
-> Either String (Tx Era)
updateExecutionUnits LedgerProtocolParameters Era
pparams SystemStart
systemStart EraHistory
eraHistory UTxO Era
utxo Tx Era
tx of
    Left String
err -> Either String (Tx Era) -> m (Either String (Tx Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String (Tx Era)
forall a b. a -> Either a b
Left String
err)
    Right Tx Era
txWithUpdatedExUnits -> do
      {- A TxModifier that bloats an output's value or datum (e.g. adding junk
      tokens or extra datum fields) only adds what it's testing - it doesn't also
      top up that output's ADA to cover the larger minimum UTxO requirement its
      new size demands, which a real attacker constructing this transaction
      would have to do anyway. Do that now, so later steps (fee estimation, value
      balancing) see the transaction's true final shape (see
      'topUpUnderfundedOutputs').
      -}
      let txWithFundedOutputs' :: Tx Era
txWithFundedOutputs' = LedgerProtocolParameters Era -> Tx Era -> Tx Era
topUpUnderfundedOutputs LedgerProtocolParameters Era
pparams Tx Era
txWithUpdatedExUnits

      {- The script integrity hash commits to the transaction's redeemers, datums,
      and the cost models of the languages it uses - all of which are final from
      here on (execution units were recalculated above; every step below only
      moves the fee, the outputs, and the collateral fields, none of which the
      hash covers). Set it now rather than after the fee is fixed: a TxModifier
      that introduces the FIRST Plutus script into a previously script-free
      transaction flips this body field from absent to present (~35 bytes), and
      only by setting it here does the fee estimation below see those bytes.
      -}
      let txWithFundedOutputs :: Tx Era
txWithFundedOutputs = UTxO Era -> LedgerProtocolParameters Era -> Tx Era -> Tx Era
recalculateScriptIntegrityHash UTxO Era
utxo LedgerProtocolParameters Era
pparams Tx Era
txWithFundedOutputs'

      {- If a TxModifier introduced a Plutus script into a transaction that
      previously ran none, it now needs a collateral input and return output that
      didn't exist before. Give it that shape *before* estimating the fee below,
      so the fee calculation sees the transaction's true final size (see
      'ensureCollateralInputShape'). This shape is used only to size 'tempTx'
      below - it is not the shape the final transaction ends up with.
      'recalculateTotalCollateral' (called later, after the fee and change are
      both final) re-derives the collateral input and return from scratch rather
      than building on this one, since only then is the real required collateral
      amount known.
      -}
      let txWithCollateralShape :: Tx Era
txWithCollateralShape = UTxO Era -> Tx Era -> Tx Era
ensureCollateralInputShape UTxO Era
utxo Tx Era
txWithFundedOutputs

      {- 'evaluateTransactionBalance' needs to know, for every stake/DRep/pool
      credential a certificate here registers or deregisters, the deposit
      already on file for it in the chain's live cert state - that's what its
      three lookup arguments are for. Pull them out of the supplied chain state
      (which reflects the chain as of this transaction, i.e. before it is
      applied), so a certificate's deposit or refund lands in the residual just
      like any other value flow. Passing 'mempty' here instead would silently
      treat every deregistration's refund as zero, unbalancing e.g. the
      withdrawal use-case's stake-registration transactions.
      -}
      let certState :: CertState ConwayEra
certState = LedgerState ConwayEra -> CertState ConwayEra
forall era. LedgerState era -> CertState era
lsCertState (MockChainState Era
chainState MockChainState Era
-> Getting
     (LedgerState ConwayEra)
     (MockChainState Era)
     (LedgerState ConwayEra)
-> LedgerState ConwayEra
forall s a. s -> Getting a s a -> a
^. (MempoolState (ShelleyLedgerEra Era)
 -> Const
      (LedgerState ConwayEra) (MempoolState (ShelleyLedgerEra Era)))
-> MockChainState Era
-> Const (LedgerState ConwayEra) (MockChainState Era)
Getting
  (LedgerState ConwayEra)
  (MockChainState Era)
  (LedgerState ConwayEra)
forall era (f :: * -> *).
Functor f =>
(MempoolState (ShelleyLedgerEra era)
 -> f (MempoolState (ShelleyLedgerEra era)))
-> MockChainState era -> f (MockChainState era)
poolState)
          registeredPools :: Set (Hash StakePoolKey)
registeredPools =
            (KeyHash 'StakePool -> Hash StakePoolKey)
-> Set (KeyHash 'StakePool) -> Set (Hash StakePoolKey)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash 'StakePool -> Hash StakePoolKey
StakePoolKeyHash (Set (KeyHash 'StakePool) -> Set (Hash StakePoolKey))
-> Set (KeyHash 'StakePool) -> Set (Hash StakePoolKey)
forall a b. (a -> b) -> a -> b
$
              Map (KeyHash 'StakePool) StakePoolState -> Set (KeyHash 'StakePool)
forall k a. Map k a -> Set k
Map.keysSet (PState ConwayEra -> Map (KeyHash 'StakePool) StakePoolState
forall era. PState era -> Map (KeyHash 'StakePool) StakePoolState
psStakePools (CertState ConwayEra
ConwayCertState ConwayEra
certState ConwayCertState ConwayEra
-> Getting
     (PState ConwayEra) (ConwayCertState ConwayEra) (PState ConwayEra)
-> PState ConwayEra
forall s a. s -> Getting a s a -> a
^. (PState ConwayEra -> Const (PState ConwayEra) (PState ConwayEra))
-> CertState ConwayEra
-> Const (PState ConwayEra) (CertState ConwayEra)
Getting
  (PState ConwayEra) (ConwayCertState ConwayEra) (PState ConwayEra)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState ConwayEra) (PState ConwayEra)
certPStateL))
          stakeDeposits :: Map StakeCredential Coin
stakeDeposits =
            (AccountState ConwayEra -> Coin)
-> Map StakeCredential (AccountState ConwayEra)
-> Map StakeCredential Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (AccountState ConwayEra -> CompactForm Coin)
-> AccountState ConwayEra
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AccountState ConwayEra
-> Getting
     (CompactForm Coin) (AccountState ConwayEra) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting
  (CompactForm Coin) (AccountState ConwayEra) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState ConwayEra) (CompactForm Coin)
depositAccountStateL)) (Map StakeCredential (AccountState ConwayEra)
 -> Map StakeCredential Coin)
-> Map StakeCredential (AccountState ConwayEra)
-> Map StakeCredential Coin
forall a b. (a -> b) -> a -> b
$
              (StakeCredential -> StakeCredential)
-> Map StakeCredential (AccountState ConwayEra)
-> Map StakeCredential (AccountState ConwayEra)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys StakeCredential -> StakeCredential
fromShelleyStakeCredential (Map StakeCredential (AccountState ConwayEra)
 -> Map StakeCredential (AccountState ConwayEra))
-> Map StakeCredential (AccountState ConwayEra)
-> Map StakeCredential (AccountState ConwayEra)
forall a b. (a -> b) -> a -> b
$
                CertState ConwayEra
ConwayCertState ConwayEra
certState ConwayCertState ConwayEra
-> Getting
     (Map StakeCredential (AccountState ConwayEra))
     (ConwayCertState ConwayEra)
     (Map StakeCredential (AccountState ConwayEra))
-> Map StakeCredential (AccountState ConwayEra)
forall s a. s -> Getting a s a -> a
^. (DState ConwayEra
 -> Const
      (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra))
-> CertState ConwayEra
-> Const
     (Map StakeCredential (AccountState ConwayEra))
     (CertState ConwayEra)
(DState ConwayEra
 -> Const
      (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra))
-> ConwayCertState ConwayEra
-> Const
     (Map StakeCredential (AccountState ConwayEra))
     (ConwayCertState ConwayEra)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState ConwayEra) (DState ConwayEra)
certDStateL ((DState ConwayEra
  -> Const
       (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra))
 -> ConwayCertState ConwayEra
 -> Const
      (Map StakeCredential (AccountState ConwayEra))
      (ConwayCertState ConwayEra))
-> ((Map StakeCredential (AccountState ConwayEra)
     -> Const
          (Map StakeCredential (AccountState ConwayEra))
          (Map StakeCredential (AccountState ConwayEra)))
    -> DState ConwayEra
    -> Const
         (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra))
-> Getting
     (Map StakeCredential (AccountState ConwayEra))
     (ConwayCertState ConwayEra)
     (Map StakeCredential (AccountState ConwayEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts ConwayEra
 -> Const
      (Map StakeCredential (AccountState ConwayEra))
      (Accounts ConwayEra))
-> DState ConwayEra
-> Const
     (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra)
(ConwayAccounts ConwayEra
 -> Const
      (Map StakeCredential (AccountState ConwayEra))
      (ConwayAccounts ConwayEra))
-> DState ConwayEra
-> Const
     (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((ConwayAccounts ConwayEra
  -> Const
       (Map StakeCredential (AccountState ConwayEra))
       (ConwayAccounts ConwayEra))
 -> DState ConwayEra
 -> Const
      (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra))
-> ((Map StakeCredential (AccountState ConwayEra)
     -> Const
          (Map StakeCredential (AccountState ConwayEra))
          (Map StakeCredential (AccountState ConwayEra)))
    -> ConwayAccounts ConwayEra
    -> Const
         (Map StakeCredential (AccountState ConwayEra))
         (ConwayAccounts ConwayEra))
-> (Map StakeCredential (AccountState ConwayEra)
    -> Const
         (Map StakeCredential (AccountState ConwayEra))
         (Map StakeCredential (AccountState ConwayEra)))
-> DState ConwayEra
-> Const
     (Map StakeCredential (AccountState ConwayEra)) (DState ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map StakeCredential (AccountState ConwayEra)
 -> Const
      (Map StakeCredential (AccountState ConwayEra))
      (Map StakeCredential (AccountState ConwayEra)))
-> Accounts ConwayEra
-> Const
     (Map StakeCredential (AccountState ConwayEra)) (Accounts ConwayEra)
(Map StakeCredential (AccountState ConwayEra)
 -> Const
      (Map StakeCredential (AccountState ConwayEra))
      (Map StakeCredential (AccountState ConwayEra)))
-> ConwayAccounts ConwayEra
-> Const
     (Map StakeCredential (AccountState ConwayEra))
     (ConwayAccounts ConwayEra)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map StakeCredential (AccountState era))
Lens'
  (Accounts ConwayEra) (Map StakeCredential (AccountState ConwayEra))
accountsMapL
          drepDeposits :: Map (Credential 'DRepRole) Coin
drepDeposits =
            (DRepState -> Coin)
-> Map (Credential 'DRepRole) DRepState
-> Map (Credential 'DRepRole) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (DRepState -> CompactForm Coin) -> DRepState -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DRepState -> CompactForm Coin
drepDeposit) (VState ConwayEra -> Map (Credential 'DRepRole) DRepState
forall era. VState era -> Map (Credential 'DRepRole) DRepState
Conway.vsDReps (CertState ConwayEra
ConwayCertState ConwayEra
certState ConwayCertState ConwayEra
-> Getting
     (VState ConwayEra) (ConwayCertState ConwayEra) (VState ConwayEra)
-> VState ConwayEra
forall s a. s -> Getting a s a -> a
^. (VState ConwayEra -> Const (VState ConwayEra) (VState ConwayEra))
-> CertState ConwayEra
-> Const (VState ConwayEra) (CertState ConwayEra)
Getting
  (VState ConwayEra) (ConwayCertState ConwayEra) (VState ConwayEra)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState ConwayEra) (VState ConwayEra)
Conway.certVStateL))

      {- The fee and the change output determine each other: the fee is part of
      the value balance, so it moves the residual the change output has to
      absorb - and absorbing the residual can change the change output's
      serialized size (new multi-asset entries from a token residual, or the
      coin crossing a CBOR width boundary), which moves the minimum fee right
      back. So the two are solved together as a fixed point: compute the fee
      for the current outputs, absorb the residual that fee leaves, re-check
      the fee against the absorbed outputs, and repeat until the fee covers
      its own consequences. The fee only ever grows across iterations and the
      change output's size is bounded, so this settles almost immediately
      (one extra round at most in practice; the iteration cap is pure
      paranoia).
      -}
      let maxFee :: Coin
maxFee = Integer -> Coin
Coin (Integer
2 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
32 :: Integer) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)

          -- The witness count matches the re-signing step at the end: one vkey
          -- witness per original signer (at least 1, so an unsigned transaction
          -- doesn't get its fee underestimated).
          witnessCount :: Word
witnessCount = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ([Hash PaymentKey] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Hash PaymentKey]
originalSigners))

          -- The minimum fee for the transaction with the given outputs: sized
          -- over the collateral shape, with the fee field itself at its
          -- worst-case width.
          feeFor :: [TxOut CtxTx Era] -> Coin
feeFor [TxOut CtxTx Era]
outs =
            let Tx TxBody Era
body' [KeyWitness Era]
_ = [TxOut CtxTx Era] -> Tx Era -> Tx Era
setTxOutputsList [TxOut CtxTx Era]
outs (Coin -> Tx Era -> Tx Era
setTxFeeCoin Coin
maxFee Tx Era
txWithCollateralShape)
             in ShelleyBasedEra Era
-> PParams (ShelleyLedgerEra Era)
-> UTxO Era
-> TxBody Era
-> Word
-> Coin
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era)
-> UTxO era
-> TxBody era
-> Word
-> Coin
calculateMinTxFee
                  ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra
                  (LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
unLedgerProtocolParameters LedgerProtocolParameters Era
pparams)
                  UTxO Era
utxo
                  TxBody Era
body'
                  Word
witnessCount

          {- Measure how far the transaction is from being value-conserved at the
          given fee, and let the change output absorb it. This single number
          subsumes the old fee-increase-only case (a plain fee change is all the
          previous code compensated for) as well as any value a TxModifier
          added, removed, or resized elsewhere in the transaction (e.g. a
          duplicated or shrunk output) without a matching change on the input
          side - instead of every TxModifier having to hand-balance its own
          mutation.
          -}
          absorbAt :: Coin -> Either String [TxOut CtxTx Era]
absorbAt Coin
fee =
            let Tx TxBody Era
body' [KeyWitness Era]
_ = Coin -> Tx Era -> Tx Era
setTxFeeCoin Coin
fee Tx Era
txWithFundedOutputs
                residual :: Value
residual =
                  TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue (TxOutValue Era -> Value) -> TxOutValue Era -> Value
forall a b. (a -> b) -> a -> b
$
                    ShelleyBasedEra Era
-> PParams (ShelleyLedgerEra Era)
-> Set (Hash StakePoolKey)
-> Map StakeCredential Coin
-> Map (Credential 'DRepRole) Coin
-> UTxO Era
-> TxBody Era
-> TxOutValue Era
forall era.
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era)
-> Set (Hash StakePoolKey)
-> Map StakeCredential Coin
-> Map (Credential 'DRepRole) Coin
-> UTxO era
-> TxBody era
-> TxOutValue era
evaluateTransactionBalance
                      ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra
                      (LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
unLedgerProtocolParameters LedgerProtocolParameters Era
pparams)
                      Set (Hash StakePoolKey)
registeredPools
                      Map StakeCredential Coin
stakeDeposits
                      Map (Credential 'DRepRole) Coin
drepDeposits
                      UTxO Era
utxo
                      TxBody Era
body'
             in LedgerProtocolParameters Era
-> AddressInEra Era
-> [TxOut CtxTx Era]
-> Value
-> [TxOut CtxTx Era]
-> Either String [TxOut CtxTx Era]
adjustOriginalChangeOutput LedgerProtocolParameters Era
pparams AddressInEra Era
walletAddr (Tx Era -> [TxOut CtxTx Era]
txOutputs Tx Era
originalTx) Value
residual (Tx Era -> [TxOut CtxTx Era]
txOutputs Tx Era
txWithFundedOutputs)

          settle :: Int -> Coin -> Either String (Coin, [TxOut CtxTx Era])
          settle :: Int -> Coin -> Either String (Coin, [TxOut CtxTx Era])
settle Int
0 Coin
_ = String -> Either String (Coin, [TxOut CtxTx Era])
forall a b. a -> Either a b
Left String
"Fee and change output failed to reach a fixed point"
          settle Int
n Coin
fee = do
            [TxOut CtxTx Era]
outs <- Coin -> Either String [TxOut CtxTx Era]
absorbAt Coin
fee
            let fee' :: Coin
fee' = [TxOut CtxTx Era] -> Coin
feeFor [TxOut CtxTx Era]
outs
            -- fee' <= fee is enough (fee' == fee is the common case): the
            -- outputs absorbed the residual at fee, so the transaction is
            -- exactly balanced at fee, and its minimum fee fee' is covered.
            if Coin
fee' Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
fee
              then (Coin, [TxOut CtxTx Era])
-> Either String (Coin, [TxOut CtxTx Era])
forall a b. b -> Either a b
Right (Coin
fee, [TxOut CtxTx Era]
outs)
              else Int -> Coin -> Either String (Coin, [TxOut CtxTx Era])
settle (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Coin
fee'

      case Int -> Coin -> Either String (Coin, [TxOut CtxTx Era])
settle Int
5 ([TxOut CtxTx Era] -> Coin
feeFor (Tx Era -> [TxOut CtxTx Era]
txOutputs Tx Era
txWithFundedOutputs)) of
        Left String
err -> Either String (Tx Era) -> m (Either String (Tx Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String (Tx Era)
forall a b. a -> Either a b
Left String
err)
        Right (Coin
newFee, [TxOut CtxTx Era]
adjustedOutputs) -> do
          -- Apply the settled fee and outputs
          let modifiedTx :: Tx Era
modifiedTx = [TxOut CtxTx Era] -> Tx Era -> Tx Era
setTxOutputsList [TxOut CtxTx Era]
adjustedOutputs (Coin -> Tx Era -> Tx Era
setTxFeeCoin Coin
newFee Tx Era
txWithFundedOutputs)

          -- Recalculate total collateral based on new fee
          case LedgerProtocolParameters Era
-> UTxO Era -> Tx Era -> Either String (Tx Era)
recalculateTotalCollateral LedgerProtocolParameters Era
pparams UTxO Era
utxo Tx Era
modifiedTx of
            Left String
err -> Either String (Tx Era) -> m (Either String (Tx Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String (Tx Era)
forall a b. a -> Either a b
Left String
err)
            Right Tx Era
txWithCollateral -> do
              {- The script integrity hash was already set before fee estimation
              above - that is where its body bytes must be sized. Recompute it
              here as well: a no-op today, since nothing after the early
              computation touches redeemers, datums, or language views (the
              recomputation ignores the fee/output/collateral fields updated
              since). But if a future fix-up step ever invalidates the hash,
              this keeps every modified transaction from failing phase 1 with
              @PPViewHashesDontMatch@ - a failure mode the environmental-skip
              tolerance would silently absorb, leaving suites green with zero
              attack coverage. The hash is 32 bytes either way, so recomputing
              late can never invalidate the fee.
              -}
              let finalTx :: Tx Era
finalTx = UTxO Era -> LedgerProtocolParameters Era -> Tx Era -> Tx Era
recalculateScriptIntegrityHash UTxO Era
utxo LedgerProtocolParameters Era
pparams Tx Era
txWithCollateral

              -- Re-sign (strip old signatures and add new one)
              let Tx TxBody Era
finalBody [KeyWitness Era]
_ = Tx Era
finalTx
                  unsignedTx :: Tx Era
unsignedTx = [KeyWitness Era] -> TxBody Era -> Tx Era
forall era. [KeyWitness era] -> TxBody era -> Tx era
makeSignedTransaction [] TxBody Era
finalBody
                  sign :: Hash PaymentKey -> Tx era -> Either String (Tx era)
sign Hash PaymentKey
hash Tx era
tx' = case Hash PaymentKey -> [(Hash PaymentKey, Wallet)] -> Maybe Wallet
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Hash PaymentKey
hash [(Hash PaymentKey, Wallet)]
mockWalletHashes of
                    Just Wallet
w -> Tx era -> Either String (Tx era)
forall a b. b -> Either a b
Right (Tx era -> Either String (Tx era))
-> Tx era -> Either String (Tx era)
forall a b. (a -> b) -> a -> b
$ Wallet -> Tx era -> Tx era
forall era. IsShelleyBasedEra era => Wallet -> Tx era -> Tx era
Wallet.signTx Wallet
w Tx era
tx'
                    Maybe Wallet
Nothing -> String -> Either String (Tx era)
forall a b. a -> Either a b
Left String
"Transaction was signed by an unknown wallet"
              Either String (Tx Era) -> m (Either String (Tx Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (Tx Era) -> m (Either String (Tx Era)))
-> Either String (Tx Era) -> m (Either String (Tx Era))
forall a b. (a -> b) -> a -> b
$ (Hash PaymentKey -> Tx Era -> Either String (Tx Era))
-> Tx Era -> [Hash PaymentKey] -> Either String (Tx Era)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM Hash PaymentKey -> Tx Era -> Either String (Tx Era)
forall {era}.
IsShelleyBasedEra era =>
Hash PaymentKey -> Tx era -> Either String (Tx era)
sign Tx Era
unsignedTx [Hash PaymentKey]
originalSigners

{- | Update execution units in a transaction by evaluating all scripts.

This computes the actual execution units required for each script and updates
the redeemers in the transaction with those values. This is necessary because
TxModifier operations like addPlutusScriptMint use ExecutionUnits 0 0 as
placeholders.

A script that runs and *rejects* the transaction shows up here as
'ScriptErrorEvaluationFailed'; its redeemer keeps its previous execution
units and the rejection is reported by the Phase 2 validation later - the
very outcome 'shouldNotValidate' attacks look for. Every other evaluation
error is structural (a missing input, datum, script, or cost model, a
redeemer pointing nowhere, an execution-units overflow): the transaction the
modifier built cannot be meaningfully executed at all, so it is returned as
a 'Left' and the run is skipped as environmental. Silently keeping the
placeholder units instead would fail Phase 2 on budget and be miscounted as
the validator rejecting the attack - a false negative.
-}
updateExecutionUnits
  :: LedgerProtocolParameters Era
  -> SystemStart
  -> EraHistory
  -> UTxO Era
  -> Tx Era
  -> Either String (Tx Era)
updateExecutionUnits :: LedgerProtocolParameters Era
-> SystemStart
-> EraHistory
-> UTxO Era
-> Tx Era
-> Either String (Tx Era)
updateExecutionUnits LedgerProtocolParameters Era
pparams SystemStart
systemStart EraHistory
eraHistory UTxO Era
utxo Tx Era
tx =
  let exUnitsMap :: Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
exUnitsMap =
        CardanoEra Era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters Era
-> UTxO Era
-> TxBody Era
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
forall era.
CardanoEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> TxBody era
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
evaluateTransactionExecutionUnits
          CardanoEra Era
ConwayEra
          SystemStart
systemStart
          (EraHistory -> LedgerEpochInfo
toLedgerEpochInfo EraHistory
eraHistory)
          LedgerProtocolParameters Era
pparams
          UTxO Era
utxo
          (Tx Era -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx Era
tx)
      structuralErrors :: [(ScriptWitnessIndex, ScriptExecutionError)]
structuralErrors =
        [ (ScriptWitnessIndex
idx, ScriptExecutionError
err)
        | (ScriptWitnessIndex
idx, Left ScriptExecutionError
err) <- Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> [(ScriptWitnessIndex,
     Either
       ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
exUnitsMap
        , Bool -> Bool
not (ScriptExecutionError -> Bool
isEvaluationFailure ScriptExecutionError
err)
        ]
      -- Extract only successful execution unit results
      successfulExUnits :: Map ScriptWitnessIndex ExecutionUnits
successfulExUnits =
        (Either
   ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
 -> Maybe ExecutionUnits)
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> Map ScriptWitnessIndex ExecutionUnits
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe
          ( \case
              Right (EvalTxExecutionUnitsLog
_, ExecutionUnits
exUnits) -> ExecutionUnits -> Maybe ExecutionUnits
forall a. a -> Maybe a
Just ExecutionUnits
exUnits
              Left ScriptExecutionError
_ -> Maybe ExecutionUnits
forall a. Maybe a
Nothing
          )
          Map
  ScriptWitnessIndex
  (Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
exUnitsMap
   in case [(ScriptWitnessIndex, ScriptExecutionError)]
structuralErrors of
        [] -> Tx Era -> Either String (Tx Era)
forall a b. b -> Either a b
Right (Map ScriptWitnessIndex ExecutionUnits -> Tx Era -> Tx Era
updateTxRedeemersWithExUnits Map ScriptWitnessIndex ExecutionUnits
successfulExUnits Tx Era
tx)
        ((ScriptWitnessIndex
idx, ScriptExecutionError
err) : [(ScriptWitnessIndex, ScriptExecutionError)]
_) ->
          String -> Either String (Tx Era)
forall a b. a -> Either a b
Left (String -> Either String (Tx Era))
-> String -> Either String (Tx Era)
forall a b. (a -> b) -> a -> b
$
            String
"Recalculating execution units failed for "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ScriptWitnessIndex -> String
forall a. Show a => a -> String
show ScriptWitnessIndex
idx
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ScriptExecutionError -> String
forall a. Show a => a -> String
show ScriptExecutionError
err
 where
  isEvaluationFailure :: ScriptExecutionError -> Bool
isEvaluationFailure ScriptErrorEvaluationFailed{} = Bool
True
  isEvaluationFailure ScriptExecutionError
_ = Bool
False

{- | Update the execution units in a transaction's redeemers.

This function takes a map from ScriptWitnessIndex to ExecutionUnits and updates
the corresponding redeemers in the transaction.
-}
updateTxRedeemersWithExUnits
  :: Map.Map ScriptWitnessIndex ExecutionUnits
  -> Tx Era
  -> Tx Era
updateTxRedeemersWithExUnits :: Map ScriptWitnessIndex ExecutionUnits -> Tx Era -> Tx Era
updateTxRedeemersWithExUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap (Tx (ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits) =
  let scriptData' :: TxBodyScriptData Era
scriptData' = Map ScriptWitnessIndex ExecutionUnits
-> TxBodyScriptData Era -> TxBodyScriptData Era
updateScriptDataExUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap TxBodyScriptData Era
scriptData
   in TxBody Era -> [KeyWitness Era] -> Tx Era
forall era. TxBody era -> [KeyWitness era] -> Tx era
Tx (ShelleyBasedEra Era
-> TxBody (ShelleyLedgerEra Era)
-> [Script (ShelleyLedgerEra Era)]
-> TxBodyScriptData Era
-> Maybe (TxAuxData (ShelleyLedgerEra Era))
-> TxScriptValidity Era
-> TxBody Era
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (TxAuxData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData' Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits

-- | Update execution units in TxBodyScriptData based on ScriptWitnessIndex map.
updateScriptDataExUnits
  :: Map.Map ScriptWitnessIndex ExecutionUnits
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
updateScriptDataExUnits :: Map ScriptWitnessIndex ExecutionUnits
-> TxBodyScriptData Era -> TxBodyScriptData Era
updateScriptDataExUnits Map ScriptWitnessIndex ExecutionUnits
_ TxBodyScriptData Era
TxBodyNoScriptData = TxBodyScriptData Era
forall era. TxBodyScriptData era
TxBodyNoScriptData
updateScriptDataExUnits Map ScriptWitnessIndex ExecutionUnits
exUnitsMap (TxBodyScriptData AlonzoEraOnwards Era
eraWit TxDats (ShelleyLedgerEra Era)
dats (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)) =
  AlonzoEraOnwards Era
-> TxDats (ShelleyLedgerEra Era)
-> Redeemers (ShelleyLedgerEra Era)
-> TxBodyScriptData Era
forall era.
AlonzoEraOnwardsConstraints era =>
AlonzoEraOnwards era
-> TxDats (ShelleyLedgerEra era)
-> Redeemers (ShelleyLedgerEra era)
-> TxBodyScriptData era
TxBodyScriptData AlonzoEraOnwards Era
eraWit TxDats (ShelleyLedgerEra Era)
dats (Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Redeemers ConwayEra
forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
updatedRdmrs)
 where
  updatedRdmrs :: Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
updatedRdmrs = (ConwayPlutusPurpose AsIx ConwayEra
 -> (Data ConwayEra, ExUnits) -> (Data ConwayEra, ExUnits))
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Map
     (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ConwayPlutusPurpose AsIx (ShelleyLedgerEra Era)
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> (Data (ShelleyLedgerEra Era), ExUnits)
ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits) -> (Data ConwayEra, ExUnits)
updateRedeemer' Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs

  updateRedeemer' :: Conway.ConwayPlutusPurpose Ledger.AsIx LedgerEra -> (Ledger.Data LedgerEra, Ledger.ExUnits) -> (Ledger.Data LedgerEra, Ledger.ExUnits)
  updateRedeemer' :: ConwayPlutusPurpose AsIx (ShelleyLedgerEra Era)
-> (Data (ShelleyLedgerEra Era), ExUnits)
-> (Data (ShelleyLedgerEra Era), ExUnits)
updateRedeemer' ConwayPlutusPurpose AsIx (ShelleyLedgerEra Era)
purpose (Data (ShelleyLedgerEra Era)
dat, ExUnits
_oldExUnits) =
    case ConwayPlutusPurpose AsIx (ShelleyLedgerEra Era)
-> Maybe ScriptWitnessIndex
purposeToScriptWitnessIndex ConwayPlutusPurpose AsIx (ShelleyLedgerEra Era)
purpose of
      Just ScriptWitnessIndex
idx -> case ScriptWitnessIndex
-> Map ScriptWitnessIndex ExecutionUnits -> Maybe ExecutionUnits
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptWitnessIndex
idx Map ScriptWitnessIndex ExecutionUnits
exUnitsMap of
        Just ExecutionUnits
newExUnits -> (Data (ShelleyLedgerEra Era)
dat, ExecutionUnits -> ExUnits
toAlonzoExUnits ExecutionUnits
newExUnits)
        Maybe ExecutionUnits
Nothing -> (Data (ShelleyLedgerEra Era)
dat, ExUnits
_oldExUnits) -- Keep old if not in map
      Maybe ScriptWitnessIndex
Nothing -> (Data (ShelleyLedgerEra Era)
dat, ExUnits
_oldExUnits)

  -- Convert Conway purpose to cardano-api ScriptWitnessIndex
  purposeToScriptWitnessIndex :: Conway.ConwayPlutusPurpose Ledger.AsIx LedgerEra -> Maybe ScriptWitnessIndex
  purposeToScriptWitnessIndex :: ConwayPlutusPurpose AsIx (ShelleyLedgerEra Era)
-> Maybe ScriptWitnessIndex
purposeToScriptWitnessIndex (Conway.ConwaySpending (Ledger.AsIx Word32
ix)) = ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a. a -> Maybe a
Just (ScriptWitnessIndex -> Maybe ScriptWitnessIndex)
-> ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a b. (a -> b) -> a -> b
$ Word32 -> ScriptWitnessIndex
ScriptWitnessIndexTxIn Word32
ix
  purposeToScriptWitnessIndex (Conway.ConwayMinting (Ledger.AsIx Word32
ix)) = ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a. a -> Maybe a
Just (ScriptWitnessIndex -> Maybe ScriptWitnessIndex)
-> ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a b. (a -> b) -> a -> b
$ Word32 -> ScriptWitnessIndex
ScriptWitnessIndexMint Word32
ix
  purposeToScriptWitnessIndex (Conway.ConwayRewarding (Ledger.AsIx Word32
ix)) = ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a. a -> Maybe a
Just (ScriptWitnessIndex -> Maybe ScriptWitnessIndex)
-> ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a b. (a -> b) -> a -> b
$ Word32 -> ScriptWitnessIndex
ScriptWitnessIndexWithdrawal Word32
ix
  purposeToScriptWitnessIndex (Conway.ConwayCertifying (Ledger.AsIx Word32
ix)) = ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a. a -> Maybe a
Just (ScriptWitnessIndex -> Maybe ScriptWitnessIndex)
-> ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a b. (a -> b) -> a -> b
$ Word32 -> ScriptWitnessIndex
ScriptWitnessIndexCertificate Word32
ix
  purposeToScriptWitnessIndex (Conway.ConwayVoting (Ledger.AsIx Word32
ix)) = ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a. a -> Maybe a
Just (ScriptWitnessIndex -> Maybe ScriptWitnessIndex)
-> ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a b. (a -> b) -> a -> b
$ Word32 -> ScriptWitnessIndex
ScriptWitnessIndexVoting Word32
ix
  purposeToScriptWitnessIndex (Conway.ConwayProposing (Ledger.AsIx Word32
ix)) = ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a. a -> Maybe a
Just (ScriptWitnessIndex -> Maybe ScriptWitnessIndex)
-> ScriptWitnessIndex -> Maybe ScriptWitnessIndex
forall a b. (a -> b) -> a -> b
$ Word32 -> ScriptWitnessIndex
ScriptWitnessIndexProposing Word32
ix

{- | Recalculate and update the script integrity hash in a transaction.

The script integrity hash commits to:
- The redeemers in the transaction
- The datums in the witness set
- The cost models for languages used (from protocol parameters)

After modifying a transaction (adding/removing inputs, changing redeemers/datums),
this hash becomes stale and must be recalculated.
-}
recalculateScriptIntegrityHash :: UTxO Era -> LedgerProtocolParameters Era -> Tx Era -> Tx Era
recalculateScriptIntegrityHash :: UTxO Era -> LedgerProtocolParameters Era -> Tx Era -> Tx Era
recalculateScriptIntegrityHash UTxO Era
utxo LedgerProtocolParameters Era
pparams tx :: Tx Era
tx@(Tx (ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits) =
  let
    pp :: PParams (ShelleyLedgerEra Era)
pp = LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
unLedgerProtocolParameters LedgerProtocolParameters Era
pparams
    ledgerUtxo :: UTxO (ShelleyLedgerEra Era)
ledgerUtxo = ShelleyBasedEra Era -> UTxO Era -> UTxO (ShelleyLedgerEra Era)
forall era.
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
toLedgerUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra UTxO Era
utxo
    ShelleyTx ShelleyBasedEra Era
_ Tx (ShelleyLedgerEra Era)
ledgerTx = Tx Era
tx
    scriptsProvided :: ScriptsProvided ConwayEra
scriptsProvided = UTxO ConwayEra -> Tx ConwayEra -> ScriptsProvided ConwayEra
forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO (ShelleyLedgerEra Era)
UTxO ConwayEra
ledgerUtxo Tx (ShelleyLedgerEra Era)
Tx ConwayEra
ledgerTx
    scriptsNeeded :: Set ScriptHash
scriptsNeeded = ScriptsNeeded ConwayEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO ConwayEra -> TxBody ConwayEra -> ScriptsNeeded ConwayEra
forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO (ShelleyLedgerEra Era)
UTxO ConwayEra
ledgerUtxo TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body)

    -- Compute new script integrity hash
    newHash :: StrictMaybe ScriptIntegrityHash
newHash = ScriptIntegrity ConwayEra -> ScriptIntegrityHash
forall era. Era era => ScriptIntegrity era -> ScriptIntegrityHash
hashScriptIntegrity (ScriptIntegrity ConwayEra -> ScriptIntegrityHash)
-> StrictMaybe (ScriptIntegrity ConwayEra)
-> StrictMaybe ScriptIntegrityHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PParams ConwayEra
-> Tx ConwayEra
-> ScriptsProvided ConwayEra
-> Set ScriptHash
-> StrictMaybe (ScriptIntegrity ConwayEra)
forall era.
(AlonzoEraPParams era, AlonzoEraTxWits era, EraUTxO era) =>
PParams era
-> Tx era
-> ScriptsProvided era
-> Set ScriptHash
-> StrictMaybe (ScriptIntegrity era)
mkScriptIntegrity PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pp Tx (ShelleyLedgerEra Era)
Tx ConwayEra
ledgerTx ScriptsProvided ConwayEra
scriptsProvided Set ScriptHash
scriptsNeeded

    -- Update the body with new hash
    body' :: TxBody ConwayEra
body' = TxBody (ShelleyLedgerEra Era)
body{Conway.ctbScriptIntegrityHash = newHash}
   in
    TxBody Era -> [KeyWitness Era] -> Tx Era
forall era. TxBody era -> [KeyWitness era] -> Tx era
Tx (ShelleyBasedEra Era
-> TxBody (ShelleyLedgerEra Era)
-> [Script (ShelleyLedgerEra Era)]
-> TxBodyScriptData Era
-> Maybe (TxAuxData (ShelleyLedgerEra Era))
-> TxScriptValidity Era
-> TxBody Era
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (TxAuxData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body' [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits

{- | Recalculate the total collateral and collateral return based on the new fee.

Total collateral = ceiling(fee * collateralPercentage / 100)
Collateral return = collateral input value - total collateral

This is needed because cardano-ledger is strict about collateral matching the fee.
When the fee increases (e.g., due to bloated datum), we need to:
1. Increase the total collateral field
2. Decrease the collateral return (to provide more collateral)

If the transaction runs a Plutus script (spending, minting, or otherwise) but
doesn't have any collateral inputs yet - e.g. a 'TxModifier' introduced a new
Plutus script, such as a minting policy, into a transaction that previously
ran no scripts at all - a key-address input already present in the
transaction is reused as the collateral input. The candidates are tried in
the order 'collateralInputCandidates' ranks them (richest first) and the
first one that yields a buildable collateral arrangement wins, so a small
input that happens to sort first in 'TxIn' order cannot mask a sufficient
one further down. The same UTxO can appear
in both the regular input set and the collateral input set: on a successful
script run the collateral fields are simply ignored by the ledger, so this
"double duty" is safe and is what a real wallet without a dedicated
collateral reserve would do too.

Collateral inputs that carry native tokens are supported: the ledger's
collateral balance (inputs minus return output) must be pure ADA, so the
return output is given exactly the inputs' tokens along with the leftover
lovelace.

Returns Left if no suitable collateral input is available, or if the chosen
collateral inputs don't have enough value to cover the required collateral.
The latter can happen when a TxModifier significantly increases the
transaction size (and thus the fee) - the original collateral may no longer
be sufficient. Also returns Left for token-carrying collateral whose
leftover lovelace can't fund the token-returning return output the tokens
require.
-}
recalculateTotalCollateral :: LedgerProtocolParameters Era -> UTxO Era -> Tx Era -> Either String (Tx Era)
recalculateTotalCollateral :: LedgerProtocolParameters Era
-> UTxO Era -> Tx Era -> Either String (Tx Era)
recalculateTotalCollateral LedgerProtocolParameters Era
pparams UTxO Era
utxo tx :: Tx Era
tx@(Tx (ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits)
  -- No Plutus script runs in this transaction: no collateral is required at all.
  | Bool -> Bool
not (TxBodyScriptData Era -> Bool
needsCollateral TxBodyScriptData Era
scriptData) = Tx Era -> Either String (Tx Era)
forall a b. b -> Either a b
Right Tx Era
tx
  | Bool
otherwise =
      case UTxO Era
-> TxBody (ShelleyLedgerEra Era)
-> [(Set TxIn, [TxOut CtxUTxO Era])]
collateralInputCandidates UTxO Era
utxo TxBody (ShelleyLedgerEra Era)
body of
        [] -> String -> Either String (Tx Era)
forall a b. a -> Either a b
Left String
"Transaction runs a Plutus script but no key-address input is available to use as collateral"
        [(Set TxIn, [TxOut CtxUTxO Era])]
candidates ->
          let attempts :: [(Set TxIn, Either String (Tx Era))]
attempts = [(Set TxIn
collInputs, (Set TxIn, [TxOut CtxUTxO Era]) -> Either String (Tx Era)
recalculateWith (Set TxIn, [TxOut CtxUTxO Era])
candidate) | candidate :: (Set TxIn, [TxOut CtxUTxO Era])
candidate@(Set TxIn
collInputs, [TxOut CtxUTxO Era]
_) <- [(Set TxIn, [TxOut CtxUTxO Era])]
candidates]
           in case [Tx Era
tx' | (Set TxIn
_, Right Tx Era
tx') <- [(Set TxIn, Either String (Tx Era))]
attempts] of
                Tx Era
tx' : [Tx Era]
_ -> Tx Era -> Either String (Tx Era)
forall a b. b -> Either a b
Right Tx Era
tx'
                [] -> String -> Either String (Tx Era)
forall a b. a -> Either a b
Left ([(Set TxIn, String)] -> String
allCandidatesFailed [(Set TxIn
collInputs, String
err) | (Set TxIn
collInputs, Left String
err) <- [(Set TxIn, Either String (Tx Era))]
attempts])
 where
  -- Every candidate failed: report each one's own reason, so that e.g. an
  -- "insufficient collateral" from the richest input does not hide that a
  -- poorer, token-carrying one failed for a different reason.
  allCandidatesFailed :: [(Set TxIn, String)] -> String
allCandidatesFailed [(Set TxIn
_, String
err)] = String
err
  allCandidatesFailed [(Set TxIn, String)]
errs =
    String
"None of the "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(Set TxIn, String)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Set TxIn, String)]
errs)
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" collateral input candidates could be used:"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"\n  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (Text -> EvalTxExecutionUnitsLog -> Text
Text.intercalate (String -> Text
Text.pack String
", ") ((TxIn -> Text) -> [TxIn] -> EvalTxExecutionUnitsLog
forall a b. (a -> b) -> [a] -> [b]
map (TxIn -> Text
renderTxIn (TxIn -> Text) -> (TxIn -> TxIn) -> TxIn -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> TxIn
fromShelleyTxIn) (Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList Set TxIn
collInputs))) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err
        | (Set TxIn
collInputs, String
err) <- [(Set TxIn, String)]
errs
        ]

  pp :: PParams (ShelleyLedgerEra Era)
pp = LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
unLedgerProtocolParameters LedgerProtocolParameters Era
pparams
  collPerc :: Natural
collPerc = PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pp PParams ConwayEra
-> Getting Natural (PParams ConwayEra) Natural -> Natural
forall s a. s -> Getting a s a -> a
^. Getting Natural (PParams ConwayEra) Natural
forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' (PParams ConwayEra) Natural
ppCollateralPercentageL
  Coin Integer
fee = TxBody ConwayEra -> Coin
Conway.ctbTxfee TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body
  -- Required total collateral: ceiling(fee * collateralPercentage / 100)
  requiredColl :: Coin
requiredColl@(Coin Integer
requiredCollAmount) = Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
fee Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Natural -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
collPerc Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational
100 :: Rational))

  -- Rebuild the collateral fields around one candidate set of collateral
  -- inputs and the outputs they resolve to.
  --
  -- The candidate's inputs are non-empty, but (for existing collateral
  -- inputs) none of them may resolve against the supplied UTxO set.
  recalculateWith :: (Set TxIn, [TxOut CtxUTxO Era]) -> Either String (Tx Era)
recalculateWith (Set TxIn
_, []) = String -> Either String (Tx Era)
forall a b. a -> Either a b
Left String
"Transaction's collateral inputs do not resolve in the supplied UTxO set"
  -- Address to send any collateral return to, if a fresh return output needs
  -- to be created (i.e. there wasn't one already): the address of the
  -- collateral input itself.
  recalculateWith (Set TxIn
collInputsSet, collOuts :: [TxOut CtxUTxO Era]
collOuts@(TxOut AddressInEra Era
fallbackReturnAddr TxOutValue Era
_ TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_ : [TxOut CtxUTxO Era]
_)) =
    let collInValue :: Value
collInValue = [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat [TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
val | TxOut AddressInEra Era
_ TxOutValue Era
val TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_ <- [TxOut CtxUTxO Era]
collOuts]
        Coin Integer
collInputValue = Value -> Coin
selectLovelace Value
collInValue
        {- The collateral balance the ledger checks is (collateral
        inputs - collateral return), and it must be pure ADA: any
        native tokens the collateral inputs carry have to come
        back, in full, in the return output - only lovelace can
        be paid as collateral.
        -}
        collTokens :: Value
collTokens = (AssetId -> Bool) -> Value -> Value
filterValue (AssetId -> AssetId -> Bool
forall a. Eq a => a -> a -> Bool
/= AssetId
AdaAssetId) Value
collInValue
        -- Calculate new collateral return = input value - required collateral
        newReturnAmount :: Integer
newReturnAmount = Integer
collInputValue Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
requiredCollAmount
        returnValue :: Value
returnValue = Coin -> Value
lovelaceToValue (Integer -> Coin
Coin Integer
newReturnAmount) Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
collTokens
        -- The output the leftover would be returned in, had we not yet
        -- decided whether it's big enough to keep as its own output.
        candidateReturnOut :: TxOut CtxTx Era
candidateReturnOut = case TxBody ConwayEra -> StrictMaybe (Sized (TxOut ConwayEra))
Conway.ctbCollateralReturn TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body of
          SJust Sized (TxOut ConwayEra)
sizedOut ->
            let TxOut AddressInEra Era
addr TxOutValue Era
_ TxOutDatum CtxTx Era
datum ReferenceScript Era
rscript = ShelleyBasedEra Era
-> TxOut (ShelleyLedgerEra Era) -> TxOut CtxTx Era
forall era ctx.
ShelleyBasedEra era
-> TxOut (ShelleyLedgerEra era) -> TxOut ctx era
fromShelleyTxOut ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Sized (BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra
forall a. Sized a -> a
CBOR.sizedValue Sized (TxOut ConwayEra)
Sized (BabbageTxOut ConwayEra)
sizedOut)
             in AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra Era
addr (ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Value -> MaryValue
toMaryValue Value
returnValue)) TxOutDatum CtxTx Era
datum ReferenceScript Era
rscript
          StrictMaybe (Sized (TxOut ConwayEra))
SNothing ->
            AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra Era
fallbackReturnAddr (ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Value -> MaryValue
toMaryValue Value
returnValue)) TxOutDatum CtxTx Era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript Era
forall era. ReferenceScript era
ReferenceScriptNone
        minReturnAda :: Coin
minReturnAda = ShelleyBasedEra Era
-> PParams (ShelleyLedgerEra Era) -> TxOut CtxTx Era -> Coin
forall era.
HasCallStack =>
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> TxOut CtxTx era -> Coin
calculateMinimumUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra PParams (ShelleyLedgerEra Era)
pp TxOut CtxTx Era
candidateReturnOut
        -- A leftover that's non-zero but still below the minimum ADA an
        -- output must carry can't be returned as its own output (the
        -- ledger would reject it with BabbageOutputTooSmallUTxO); in
        -- that case forfeit the whole collateral input instead of
        -- creating an under-funded return output. Forfeiting is only
        -- possible for ADA-only collateral, though: dropping the
        -- return output of token-carrying collateral would pay the
        -- tokens as collateral, which the ledger rejects.
        canReturnLeftover :: Bool
canReturnLeftover = (Integer
newReturnAmount Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 Bool -> Bool -> Bool
&& Value
collTokens Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty) Bool -> Bool -> Bool
|| Integer -> Coin
Coin Integer
newReturnAmount Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
minReturnAda
     in if Integer
newReturnAmount Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
          then String -> Either String (Tx Era)
forall a b. a -> Either a b
Left (String -> Either String (Tx Era))
-> String -> Either String (Tx Era)
forall a b. (a -> b) -> a -> b
$ String
"Insufficient collateral: inputs=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
collInputValue String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", need=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
requiredCollAmount
          else
            if Bool -> Bool
not Bool
canReturnLeftover Bool -> Bool -> Bool
&& Value
collTokens Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
forall a. Monoid a => a
mempty
              then
                String -> Either String (Tx Era)
forall a b. a -> Either a b
Left (String -> Either String (Tx Era))
-> String -> Either String (Tx Era)
forall a b. (a -> b) -> a -> b
$
                  String
"Collateral inputs carry native tokens, but the leftover lovelace ("
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
newReturnAmount
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") is below the minimum ADA the token-returning collateral return output must carry ("
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show (Coin -> Integer
unCoin Coin
minReturnAda)
                    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
              else
                -- Update the collateral inputs, total collateral, and collateral return
                let (Coin
actualTotalCollateral, StrictMaybe (Sized (BabbageTxOut ConwayEra))
newCollateralReturn)
                      | Bool
canReturnLeftover =
                          (Coin
requiredColl, AddressInEra Era
-> Value
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
setCollateralReturn AddressInEra Era
fallbackReturnAddr Value
returnValue (TxBody ConwayEra -> StrictMaybe (Sized (TxOut ConwayEra))
Conway.ctbCollateralReturn TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body))
                      | Bool
otherwise = (Integer -> Coin
Coin Integer
collInputValue, StrictMaybe (Sized (BabbageTxOut ConwayEra))
forall a. StrictMaybe a
SNothing)
                    body' :: TxBody ConwayEra
body' =
                      TxBody (ShelleyLedgerEra Era)
body
                        { Conway.ctbCollateralInputs = collInputsSet
                        , Conway.ctbTotalCollateral = SJust actualTotalCollateral
                        , Conway.ctbCollateralReturn = newCollateralReturn
                        }
                 in Tx Era -> Either String (Tx Era)
forall a b. b -> Either a b
Right (Tx Era -> Either String (Tx Era))
-> Tx Era -> Either String (Tx Era)
forall a b. (a -> b) -> a -> b
$ TxBody Era -> [KeyWitness Era] -> Tx Era
forall era. TxBody era -> [KeyWitness era] -> Tx era
Tx (ShelleyBasedEra Era
-> TxBody (ShelleyLedgerEra Era)
-> [Script (ShelleyLedgerEra Era)]
-> TxBodyScriptData Era
-> Maybe (TxAuxData (ShelleyLedgerEra Era))
-> TxScriptValidity Era
-> TxBody Era
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (TxAuxData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body' [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits

{- | Does this transaction run a Plutus script? The ledger demands collateral
exactly when the transaction carries at least one redeemer: every script
execution has a redeemer, and a Plutus script that is merely *attached* to
the transaction - e.g. parked as a reference script on a spent or referenced
UTxO, the standard deployed-script pattern - doesn't run and needs no
collateral.
-}
needsCollateral :: TxBodyScriptData Era -> Bool
needsCollateral :: TxBodyScriptData Era -> Bool
needsCollateral = \case
  TxBodyScriptData Era
TxBodyNoScriptData -> Bool
False
  TxBodyScriptData AlonzoEraOnwards Era
_ TxDats (ShelleyLedgerEra Era)
_ (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs) -> Bool -> Bool
not (Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> Bool
forall k a. Map k a -> Bool
Map.null Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs)

{- | Does this transaction run at least one Plutus script? See 'needsCollateral'.
| Does any Plutus script run in this transaction? 'runningPlutusScriptHashes'
answers /which/ ones, and is empty exactly when this is 'False'.
-}
txRunsPlutusScript :: Tx Era -> Bool
txRunsPlutusScript :: Tx Era -> Bool
txRunsPlutusScript (Tx (ShelleyTxBody ShelleyBasedEra Era
_ TxBody (ShelleyLedgerEra Era)
_ [Script (ShelleyLedgerEra Era)]
_ TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_) = TxBodyScriptData Era -> Bool
needsCollateral TxBodyScriptData Era
scriptData

{- | The hashes of the Plutus scripts that run in this transaction.

Built from the ledger's own notion of which scripts a transaction must
satisfy ('getScriptsNeeded'), so it covers every purpose - spending,
minting, rewarding, certifying, voting, proposing - and cannot drift from
the ledger rules the way a hand-rolled redeemer walk would.

Narrowed to scripts *provided* as Plutus: a native script runs no Plutus
code and cannot inspect outputs at all, so it never guards anything.
Reference scripts are included, since 'getScriptsProvided' resolves them
from the UTxO set rather than the witness set.

Empty exactly when 'txRunsPlutusScript' is 'False', which is checked first
both to short-circuit the UTxO walk and to keep that equivalence true by
construction - 'Convex.ThreatModel.guardedScriptOutputs' relies on it to
subsume 'Convex.ThreatModel.requireScriptExecution'.
-}
runningPlutusScriptHashes :: Ledger.UTxO LedgerEra -> Tx Era -> Set.Set Ledger.ScriptHash
runningPlutusScriptHashes :: UTxO (ShelleyLedgerEra Era) -> Tx Era -> Set ScriptHash
runningPlutusScriptHashes UTxO (ShelleyLedgerEra Era)
ledgerUtxo tx :: Tx Era
tx@(Tx (ShelleyTxBody ShelleyBasedEra Era
_ TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
_ TxBodyScriptData Era
_ Maybe (TxAuxData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_)
  | Bool -> Bool
not (Tx Era -> Bool
txRunsPlutusScript Tx Era
tx) = Set ScriptHash
forall a. Set a
Set.empty
  | Bool
otherwise = (ScriptHash -> Bool) -> Set ScriptHash -> Set ScriptHash
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ScriptHash -> Bool
isPlutus (ScriptsNeeded ConwayEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO ConwayEra -> TxBody ConwayEra -> ScriptsNeeded ConwayEra
forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO (ShelleyLedgerEra Era)
UTxO ConwayEra
ledgerUtxo TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body))
 where
  ShelleyTx ShelleyBasedEra Era
_ Tx (ShelleyLedgerEra Era)
ledgerTx = Tx Era
tx
  ScriptsProvided Map ScriptHash (Script ConwayEra)
provided = UTxO ConwayEra -> Tx ConwayEra -> ScriptsProvided ConwayEra
forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO (ShelleyLedgerEra Era)
UTxO ConwayEra
ledgerUtxo Tx (ShelleyLedgerEra Era)
Tx ConwayEra
ledgerTx
  isPlutus :: ScriptHash -> Bool
isPlutus ScriptHash
h = Bool
-> (AlonzoScript ConwayEra -> Bool)
-> Maybe (AlonzoScript ConwayEra)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Maybe Language -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Language -> Bool)
-> (AlonzoScript ConwayEra -> Maybe Language)
-> AlonzoScript ConwayEra
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoScript (ShelleyLedgerEra Era) -> Maybe Language
AlonzoScript ConwayEra -> Maybe Language
getScriptLanguage) (ScriptHash
-> Map ScriptHash (AlonzoScript ConwayEra)
-> Maybe (AlonzoScript ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
h Map ScriptHash (Script ConwayEra)
Map ScriptHash (AlonzoScript ConwayEra)
provided)

{- | The payment credential's script hash, or @Nothing@ for a key or Byron
address. See 'Convex.ThreatModel.guardedScriptOutputs' for what matching
this against 'runningPlutusScriptHashes' does and does not establish.
-}
scriptHashOfAddressAny :: AddressAny -> Maybe Ledger.ScriptHash
scriptHashOfAddressAny :: AddressAny -> Maybe ScriptHash
scriptHashOfAddressAny = \case
  AddressByron{} -> Maybe ScriptHash
forall a. Maybe a
Nothing
  AddressShelley (ShelleyAddress Network
_ PaymentCredential
paymentCred StakeReference
_) -> case PaymentCredential
paymentCred of
    ScriptHashObj ScriptHash
h -> ScriptHash -> Maybe ScriptHash
forall a. a -> Maybe a
Just ScriptHash
h
    KeyHashObj KeyHash 'Payment
_ -> Maybe ScriptHash
forall a. Maybe a
Nothing

{- | The candidate collateral input sets to try, in order of preference, each
paired with the outputs its inputs resolve to in the UTxO set: the existing
collateral inputs if there are any (a single candidate, whose outputs may be
fewer than its inputs if the UTxO set does not cover them all), otherwise
each key-address spend input on its own, richest first, with ADA-only inputs
ahead of token-carrying ones of equal lovelace (their dust leftover can be
forfeited, and they need no token-returning return output). Script-address
inputs are never candidates.

Ranking by lovelace is also what keeps the fee sizing honest:
'ensureCollateralInputShape' sizes the fee against the first candidate's
collateral return output before the fee is fixed, while
'recalculateTotalCollateral' may fall through to a later candidate once it
knows the fee. A later candidate is never richer, so its return output is
never larger than the one the fee was sized for.
-}
collateralInputCandidates :: UTxO Era -> Conway.TxBody LedgerEra -> [(Set.Set Ledger.TxIn, [TxOut CtxUTxO Era])]
collateralInputCandidates :: UTxO Era
-> TxBody (ShelleyLedgerEra Era)
-> [(Set TxIn, [TxOut CtxUTxO Era])]
collateralInputCandidates UTxO Era
utxo TxBody (ShelleyLedgerEra Era)
body
  | Bool -> Bool
not (Set TxIn -> Bool
forall a. Set a -> Bool
Set.null Set TxIn
existing) = [(Set TxIn
existing, (TxIn -> Maybe (TxOut CtxUTxO Era))
-> [TxIn] -> [TxOut CtxUTxO Era]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TxIn -> Maybe (TxOut CtxUTxO Era)
resolve (Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList Set TxIn
existing))]
  | Bool
otherwise = [(TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn, [TxOut CtxUTxO Era
txOut]) | (TxIn
txIn, TxOut CtxUTxO Era
txOut, (Coin, Bool)
_) <- ((TxIn, TxOut CtxUTxO Era, (Coin, Bool)) -> Down (Coin, Bool))
-> [(TxIn, TxOut CtxUTxO Era, (Coin, Bool))]
-> [(TxIn, TxOut CtxUTxO Era, (Coin, Bool))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(TxIn
_, TxOut CtxUTxO Era
_, (Coin, Bool)
rank) -> (Coin, Bool) -> Down (Coin, Bool)
forall a. a -> Down a
Down (Coin, Bool)
rank) [(TxIn, TxOut CtxUTxO Era, (Coin, Bool))]
keyInputs]
 where
  existing :: Set TxIn
existing = TxBody ConwayEra -> Set TxIn
Conway.ctbCollateralInputs TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body
  resolve :: TxIn -> Maybe (TxOut CtxUTxO Era)
resolve TxIn
txIn = TxIn -> Map TxIn (TxOut CtxUTxO Era) -> Maybe (TxOut CtxUTxO Era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TxIn -> TxIn
fromShelleyTxIn TxIn
txIn) (UTxO Era -> Map TxIn (TxOut CtxUTxO Era)
forall era. UTxO era -> Map TxIn (TxOut CtxUTxO era)
unUTxO UTxO Era
utxo)
  -- Each key-address spend input with its output and rank: by lovelace, then ADA-only before token-carrying.
  keyInputs :: [(TxIn, TxOut CtxUTxO Era, (Coin, Bool))]
keyInputs =
    [ (TxIn
txIn, TxOut CtxUTxO Era
txOut, (Value -> Coin
selectLovelace Value
value, Maybe Coin -> Bool
forall a. Maybe a -> Bool
isJust (Value -> Maybe Coin
valueToLovelace Value
value)))
    | TxIn
txIn <- Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (TxBody ConwayEra -> Set TxIn
Conway.ctbSpendInputs TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body)
    , Just txOut :: TxOut CtxUTxO Era
txOut@(TxOut AddressInEra Era
_ TxOutValue Era
val TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_) <- [TxIn -> Maybe (TxOut CtxUTxO Era)
resolve TxIn
txIn]
    , AddressAny -> Bool
isKeyAddressAny (TxOut CtxUTxO Era -> AddressAny
forall ctx. TxOut ctx Era -> AddressAny
addressOfTxOut TxOut CtxUTxO Era
txOut)
    , let value :: Value
value = TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
val
    ]

{- | Ensure every output in a transaction carries at least the protocol's
minimum required ADA for its current size (its value's assets, its datum,
etc). A 'TxModifier' that bloats an output's value or datum (e.g. adding
junk tokens or extra datum fields) only adds what it's testing; it doesn't
separately account for the larger minimum UTxO requirement that bloat
demands. Without this, such a mutation fails Phase 1 with
@BabbageOutputTooSmallUTxO@ before the validator ever gets a chance to
accept or reject the bloat, wasting the test on a ledger bookkeeping
artifact instead of the validator's own logic - a real attacker constructing
this transaction would simply provide the required ADA, so the test should
too.

The shortfall for whichever outputs need it is made up generically once
'rebalanceAndSign' absorbs the transaction's overall value residual into the
wallet's change output.
-}
topUpUnderfundedOutputs :: LedgerProtocolParameters Era -> Tx Era -> Tx Era
topUpUnderfundedOutputs :: LedgerProtocolParameters Era -> Tx Era -> Tx Era
topUpUnderfundedOutputs LedgerProtocolParameters Era
pparams Tx Era
tx = [TxOut CtxTx Era] -> Tx Era -> Tx Era
setTxOutputsList ((TxOut CtxTx Era -> TxOut CtxTx Era)
-> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a b. (a -> b) -> [a] -> [b]
map TxOut CtxTx Era -> TxOut CtxTx Era
topUp (Tx Era -> [TxOut CtxTx Era]
txOutputs Tx Era
tx)) Tx Era
tx
 where
  pp :: PParams (ShelleyLedgerEra Era)
pp = LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
unLedgerProtocolParameters LedgerProtocolParameters Era
pparams
  topUp :: TxOut CtxTx Era -> TxOut CtxTx Era
topUp out :: TxOut CtxTx Era
out@(TxOut AddressInEra Era
addr TxOutValue Era
val TxOutDatum CtxTx Era
datum ReferenceScript Era
refScript)
    | Coin
current Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
required = TxOut CtxTx Era
out
    | Bool
otherwise =
        let newValue :: Value
newValue = TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
val Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
negateValue (Coin -> Value
lovelaceToValue Coin
current) Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Coin -> Value
lovelaceToValue Coin
required
         in AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra Era
addr (ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Value -> MaryValue
toMaryValue Value
newValue)) TxOutDatum CtxTx Era
datum ReferenceScript Era
refScript
   where
    required :: Coin
required = ShelleyBasedEra Era
-> PParams (ShelleyLedgerEra Era) -> TxOut CtxTx Era -> Coin
forall era.
HasCallStack =>
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> TxOut CtxTx era -> Coin
calculateMinimumUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra PParams (ShelleyLedgerEra Era)
pp TxOut CtxTx Era
out
    current :: Coin
current = TxOutValue Era -> Coin
forall era. TxOutValue era -> Coin
txOutValueToLovelace TxOutValue Era
val

{- | If a transaction runs a Plutus script, give its collateral fields the
shape 'recalculateTotalCollateral' will produce later, sized at an upper
bound: the collateral inputs (the existing ones, or else the preferred
key-address input candidate, see 'collateralInputCandidates'), a collateral
return output carrying the SUM of those inputs' values, and a total-collateral
field holding their summed lovelace. This exists purely so that a subsequent
min-fee calculation sees the transaction's true final shape - including the
return output a first-time collateral input requires, and the bytes of a
total-collateral field that did not exist before - before the fee is fixed.
'recalculateTotalCollateral' then rebuilds both fields with the precise
amounts once the real fee is known.

Summing without subtracting the required collateral keeps the placeholders an
upper bound on the encoded size: the real return is the sum minus the
required collateral (with the same tokens), and the real total collateral, a
percentage of the fee, is far smaller than the inputs' lovelace - even when a
modifier shrinks the fee and thereby *grows* the real return, or when several
collateral inputs sum to more than any single one. An existing return
output's stale value is replaced, keeping its address, datum and reference
script, exactly like the rebuild does.

Does nothing if no Plutus script needs to run, or if no candidate resolves
(in which case 'recalculateTotalCollateral' reports the error later).
-}
ensureCollateralInputShape :: UTxO Era -> Tx Era -> Tx Era
ensureCollateralInputShape :: UTxO Era -> Tx Era -> Tx Era
ensureCollateralInputShape UTxO Era
utxo tx :: Tx Era
tx@(Tx (ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits)
  | Bool -> Bool
not (TxBodyScriptData Era -> Bool
needsCollateral TxBodyScriptData Era
scriptData) = Tx Era
tx
  | Bool
otherwise = case UTxO Era
-> TxBody (ShelleyLedgerEra Era)
-> [(Set TxIn, [TxOut CtxUTxO Era])]
collateralInputCandidates UTxO Era
utxo TxBody (ShelleyLedgerEra Era)
body of
      (Set TxIn
collInputs, collOuts :: [TxOut CtxUTxO Era]
collOuts@(TxOut AddressInEra Era
fallbackAddr TxOutValue Era
_ TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_ : [TxOut CtxUTxO Era]
_)) : [(Set TxIn, [TxOut CtxUTxO Era])]
_ ->
        let summedValue :: Value
summedValue = [Value] -> Value
forall a. Monoid a => [a] -> a
mconcat [TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
v | TxOut AddressInEra Era
_ TxOutValue Era
v TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_ <- [TxOut CtxUTxO Era]
collOuts]
            body' :: TxBody ConwayEra
body' =
              TxBody (ShelleyLedgerEra Era)
body
                { Conway.ctbCollateralInputs = collInputs
                , Conway.ctbCollateralReturn = setCollateralReturn fallbackAddr summedValue (Conway.ctbCollateralReturn body)
                , Conway.ctbTotalCollateral = SJust (selectLovelace summedValue)
                }
         in TxBody Era -> [KeyWitness Era] -> Tx Era
forall era. TxBody era -> [KeyWitness era] -> Tx era
Tx (ShelleyBasedEra Era
-> TxBody (ShelleyLedgerEra Era)
-> [Script (ShelleyLedgerEra Era)]
-> TxBodyScriptData Era
-> Maybe (TxAuxData (ShelleyLedgerEra Era))
-> TxScriptValidity Era
-> TxBody Era
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (TxAuxData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body' [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits
      [(Set TxIn, [TxOut CtxUTxO Era])]
_ -> Tx Era
tx

{- | Update the collateral return output with a new value (the leftover
lovelace plus, exactly, whatever native tokens the collateral inputs carry -
the caller computes this; the ledger demands the tokens come back in full).
If there's no existing collateral return output, a fresh one is created at
the given fallback address (used when a transaction gains a collateral input
for the first time and thus never had a return output to begin with).
-}
setCollateralReturn
  :: AddressInEra Era
  -> Value
  -> StrictMaybe (CBOR.Sized (Ledger.TxOut LedgerEra))
  -> StrictMaybe (CBOR.Sized (Ledger.TxOut LedgerEra))
setCollateralReturn :: AddressInEra Era
-> Value
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
setCollateralReturn AddressInEra Era
fallbackAddr Value
newValue StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
existing
  | Value
newValue Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty = StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
StrictMaybe (Sized (BabbageTxOut ConwayEra))
forall a. StrictMaybe a
SNothing -- No return needed if all collateral is used
  | Bool
otherwise = case StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
existing of
      SJust Sized (TxOut (ShelleyLedgerEra Era))
sizedOut ->
        let oldOut :: BabbageTxOut ConwayEra
oldOut = Sized (BabbageTxOut ConwayEra) -> BabbageTxOut ConwayEra
forall a. Sized a -> a
CBOR.sizedValue Sized (TxOut (ShelleyLedgerEra Era))
Sized (BabbageTxOut ConwayEra)
sizedOut
            TxOut AddressInEra Era
addr TxOutValue Era
_ TxOutDatum CtxTx Era
datum ReferenceScript Era
rscript = ShelleyBasedEra Era
-> TxOut (ShelleyLedgerEra Era) -> TxOut CtxTx Era
forall era ctx.
ShelleyBasedEra era
-> TxOut (ShelleyLedgerEra era) -> TxOut ctx era
fromShelleyTxOut ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra TxOut (ShelleyLedgerEra Era)
BabbageTxOut ConwayEra
oldOut
            newOut :: TxOut CtxTx Era
newOut = AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra Era
addr (ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Value -> MaryValue
toMaryValue Value
newValue)) TxOutDatum CtxTx Era
datum ReferenceScript Era
rscript
         in Sized (TxOut (ShelleyLedgerEra Era))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
forall a. a -> StrictMaybe a
SJust (Sized (TxOut (ShelleyLedgerEra Era))
 -> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era))))
-> Sized (TxOut (ShelleyLedgerEra Era))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
forall a b. (a -> b) -> a -> b
$ TxOut CtxTx Era -> Sized (TxOut (ShelleyLedgerEra Era))
mkSizedShelleyTxOut TxOut CtxTx Era
newOut
      StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
SNothing ->
        let newOut :: TxOut CtxTx Era
newOut = AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra Era
fallbackAddr (ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Value -> MaryValue
toMaryValue Value
newValue)) TxOutDatum CtxTx Era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone ReferenceScript Era
forall era. ReferenceScript era
ReferenceScriptNone
         in Sized (TxOut (ShelleyLedgerEra Era))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
forall a. a -> StrictMaybe a
SJust (Sized (TxOut (ShelleyLedgerEra Era))
 -> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era))))
-> Sized (TxOut (ShelleyLedgerEra Era))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
forall a b. (a -> b) -> a -> b
$ TxOut CtxTx Era -> Sized (TxOut (ShelleyLedgerEra Era))
mkSizedShelleyTxOut TxOut CtxTx Era
newOut

-- | Convert a 'TxOut' into a sized ledger 'TxOut', as stored in a tx body.
mkSizedShelleyTxOut :: TxOut CtxTx Era -> CBOR.Sized (Ledger.TxOut LedgerEra)
mkSizedShelleyTxOut :: TxOut CtxTx Era -> Sized (TxOut (ShelleyLedgerEra Era))
mkSizedShelleyTxOut TxOut CtxTx Era
out =
  Version -> BabbageTxOut ConwayEra -> Sized (BabbageTxOut ConwayEra)
forall a. EncCBOR a => Version -> a -> Sized a
CBOR.mkSized (forall era. Era era => Version
Ledger.eraProtVerLow @LedgerEra) (ShelleyBasedEra Era -> TxOut CtxUTxO Era -> TxOut ConwayEra
forall era ledgerera.
(HasCallStack, ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut CtxUTxO era -> TxOut ledgerera
toShelleyTxOut ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (TxOut CtxTx Era -> TxOut CtxUTxO Era
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
toCtxUTxOTxOut TxOut CtxTx Era
out))

-- | Extract the Plutus language from a ledger script, if it's a Plutus script
getScriptLanguage :: Ledger.AlonzoScript LedgerEra -> Maybe Plutus.Language
getScriptLanguage :: AlonzoScript (ShelleyLedgerEra Era) -> Maybe Language
getScriptLanguage AlonzoScript (ShelleyLedgerEra Era)
script = case AlonzoScript (ShelleyLedgerEra Era)
script of
  Ledger.NativeScript{} -> Maybe Language
forall a. Maybe a
Nothing
  Ledger.PlutusScript PlutusScript (ShelleyLedgerEra Era)
ps -> Language -> Maybe Language
forall a. a -> Maybe a
Just (Language -> Maybe Language) -> Language -> Maybe Language
forall a b. (a -> b) -> a -> b
$ PlutusScript ConwayEra -> Language
forall era. AlonzoEraScript era => PlutusScript era -> Language
Ledger.plutusScriptLanguage PlutusScript (ShelleyLedgerEra Era)
PlutusScript ConwayEra
ps

-- | Set the fee in a transaction
setTxFeeCoin :: Coin -> Tx Era -> Tx Era
setTxFeeCoin :: Coin -> Tx Era -> Tx Era
setTxFeeCoin Coin
fee (Tx (ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits) =
  TxBody Era -> [KeyWitness Era] -> Tx Era
forall era. TxBody era -> [KeyWitness era] -> Tx era
Tx (ShelleyBasedEra Era
-> TxBody (ShelleyLedgerEra Era)
-> [Script (ShelleyLedgerEra Era)]
-> TxBodyScriptData Era
-> Maybe (TxAuxData (ShelleyLedgerEra Era))
-> TxScriptValidity Era
-> TxBody Era
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (TxAuxData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body{Conway.ctbTxfee = fee} [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits

-- | Set transaction outputs (helper that works at the Tx level)
setTxOutputsList :: [TxOut CtxTx Era] -> Tx Era -> Tx Era
setTxOutputsList :: [TxOut CtxTx Era] -> Tx Era -> Tx Era
setTxOutputsList [TxOut CtxTx Era]
newOuts (Tx (ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits) =
  let newOutsSeq :: StrictSeq (Sized (BabbageTxOut ConwayEra))
newOutsSeq = [Sized (BabbageTxOut ConwayEra)]
-> StrictSeq (Sized (BabbageTxOut ConwayEra))
forall a. [a] -> StrictSeq a
Seq.fromList ((TxOut CtxTx Era -> Sized (BabbageTxOut ConwayEra))
-> [TxOut CtxTx Era] -> [Sized (BabbageTxOut ConwayEra)]
forall a b. (a -> b) -> [a] -> [b]
map TxOut CtxTx Era -> Sized (TxOut (ShelleyLedgerEra Era))
TxOut CtxTx Era -> Sized (BabbageTxOut ConwayEra)
mkSizedShelleyTxOut [TxOut CtxTx Era]
newOuts)
      body' :: TxBody ConwayEra
body' = TxBody (ShelleyLedgerEra Era)
body{Conway.ctbOutputs = newOutsSeq}
   in TxBody Era -> [KeyWitness Era] -> Tx Era
forall era. TxBody era -> [KeyWitness era] -> Tx era
Tx (ShelleyBasedEra Era
-> TxBody (ShelleyLedgerEra Era)
-> [Script (ShelleyLedgerEra Era)]
-> TxBodyScriptData Era
-> Maybe (TxAuxData (ShelleyLedgerEra Era))
-> TxScriptValidity Era
-> TxBody Era
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (TxAuxData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
ShelleyTxBody ShelleyBasedEra Era
era TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body' [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
scriptData Maybe (TxAuxData (ShelleyLedgerEra Era))
auxData TxScriptValidity Era
validity) [KeyWitness Era]
wits

{- | Adjust the change output by a value delta, identifying it through the
original transaction: its change output is taken to be its last wallet
output (see 'adjustChangeOutput'), and that output is then located in the
modified outputs, trying in order:

1. the original change output, still unchanged (the modifier may have
   shifted it by removing an earlier output);
2. whatever wallet output sits at the original change output's index (the
   modifier rewrote the change output in place, e.g. with 'changeValueOf');
3. the last wallet output left unchanged by the modifier (the change output
   itself was removed);
4. 'adjustChangeOutput''s choice, the last wallet output.

Going straight to the last wallet output of the /modified/ transaction goes
wrong whenever a 'TxModifier' adds an output to the wallet itself. Double
satisfaction, for one, redirects a victim's output to the signer with
'addOutput', which appends it after the real change output; that new output
typically sits at its minimum ADA, so charging the fee to it fails with
"Change output would fall below the minimum required ADA" even though the
real change output could easily cover it. Conversely, looking only for
unchanged wallet outputs goes wrong when the modifier rewrote the change
output in place (as token forgery does): the fee would then be charged to an
earlier wallet output, such as an exact payment the validator checks.
-}
adjustOriginalChangeOutput
  :: LedgerProtocolParameters Era
  -> AddressInEra Era
  -- ^ Wallet address to find change output
  -> [TxOut CtxTx Era]
  -- ^ The original (unmodified) transaction's outputs
  -> Value
  -- ^ Value delta to apply to the change output
  -> [TxOut CtxTx Era]
  -- ^ Transaction outputs
  -> Either String [TxOut CtxTx Era]
adjustOriginalChangeOutput :: LedgerProtocolParameters Era
-> AddressInEra Era
-> [TxOut CtxTx Era]
-> Value
-> [TxOut CtxTx Era]
-> Either String [TxOut CtxTx Era]
adjustOriginalChangeOutput LedgerProtocolParameters Era
pparams AddressInEra Era
walletAddr [TxOut CtxTx Era]
originalOutputs Value
delta [TxOut CtxTx Era]
outputs =
  case [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe [Int]
candidates of
    Just Int
i -> LedgerProtocolParameters Era
-> Int
-> Value
-> [TxOut CtxTx Era]
-> Either String [TxOut CtxTx Era]
adjustOutputAt LedgerProtocolParameters Era
pparams Int
i Value
delta [TxOut CtxTx Era]
outputs
    Maybe Int
Nothing -> LedgerProtocolParameters Era
-> AddressInEra Era
-> Value
-> [TxOut CtxTx Era]
-> Either String [TxOut CtxTx Era]
adjustChangeOutput LedgerProtocolParameters Era
pparams AddressInEra Era
walletAddr Value
delta [TxOut CtxTx Era]
outputs
 where
  isWallet :: TxOut CtxTx Era -> Bool
isWallet (TxOut AddressInEra Era
addr TxOutValue Era
_ TxOutDatum CtxTx Era
_ ReferenceScript Era
_) = AddressInEra Era
addr AddressInEra Era -> AddressInEra Era -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra Era
walletAddr
  indexed :: [(Int, TxOut CtxTx Era)]
indexed = [Int] -> [TxOut CtxTx Era] -> [(Int, TxOut CtxTx Era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [TxOut CtxTx Era]
outputs
  originalChange :: Maybe (Int, TxOut CtxTx Era)
originalChange = [(Int, TxOut CtxTx Era)] -> Maybe (Int, TxOut CtxTx Era)
forall a. [a] -> Maybe a
listToMaybe ([(Int, TxOut CtxTx Era)] -> [(Int, TxOut CtxTx Era)]
forall a. [a] -> [a]
reverse [(Int
i, TxOut CtxTx Era
o) | (Int
i, TxOut CtxTx Era
o) <- [Int] -> [TxOut CtxTx Era] -> [(Int, TxOut CtxTx Era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [TxOut CtxTx Era]
originalOutputs, TxOut CtxTx Era -> Bool
isWallet TxOut CtxTx Era
o])
  candidates :: [Int]
candidates =
    [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Int
i | Just (Int
_, TxOut CtxTx Era
change) <- [Maybe (Int, TxOut CtxTx Era)
originalChange], (Int
i, TxOut CtxTx Era
o) <- [(Int, TxOut CtxTx Era)] -> [(Int, TxOut CtxTx Era)]
forall a. [a] -> [a]
reverse [(Int, TxOut CtxTx Era)]
indexed, TxOut CtxTx Era
o TxOut CtxTx Era -> TxOut CtxTx Era -> Bool
forall a. Eq a => a -> a -> Bool
== TxOut CtxTx Era
change]
      , [Int
i | Just (Int
i, TxOut CtxTx Era
_) <- [Maybe (Int, TxOut CtxTx Era)
originalChange], Just TxOut CtxTx Era
o <- [Int -> [(Int, TxOut CtxTx Era)] -> Maybe (TxOut CtxTx Era)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
i [(Int, TxOut CtxTx Era)]
indexed], TxOut CtxTx Era -> Bool
isWallet TxOut CtxTx Era
o]
      , [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
i | (Int
i, TxOut CtxTx Era
o) <- [(Int, TxOut CtxTx Era)]
indexed, TxOut CtxTx Era -> Bool
isWallet TxOut CtxTx Era
o, TxOut CtxTx Era
o TxOut CtxTx Era -> [TxOut CtxTx Era] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TxOut CtxTx Era]
originalOutputs]
      ]

{- | Adjust the last output going to wallet address by a value delta (see
'adjustOutputAt').

Taking the last wallet output as the change output is only a heuristic. It
assumes the transaction was balanced with trailing change
('Convex.CoinSelection.TrailingChange'; with @LeadingChange@ the change
output comes first), and it goes wrong as soon as a 'TxModifier' appends an
output to the wallet itself, since 'addOutput' puts it after the real change
output. 'rebalanceAndSign' therefore uses 'adjustOriginalChangeOutput', which
only falls back to this when it can't identify the change output from the
original transaction.
-}
adjustChangeOutput
  :: LedgerProtocolParameters Era
  -> AddressInEra Era
  -- ^ Wallet address to find change output
  -> Value
  -- ^ Value delta to apply to the change output
  -> [TxOut CtxTx Era]
  -- ^ Transaction outputs
  -> Either String [TxOut CtxTx Era]
adjustChangeOutput :: LedgerProtocolParameters Era
-> AddressInEra Era
-> Value
-> [TxOut CtxTx Era]
-> Either String [TxOut CtxTx Era]
adjustChangeOutput LedgerProtocolParameters Era
pparams AddressInEra Era
walletAddr Value
delta [TxOut CtxTx Era]
outputs = do
  let indexed :: [(Int, TxOut CtxTx Era)]
indexed = [Int] -> [TxOut CtxTx Era] -> [(Int, TxOut CtxTx Era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [TxOut CtxTx Era]
outputs
      walletOutputs :: [(Int, TxOut CtxTx Era)]
walletOutputs =
        [ (Int
i, TxOut CtxTx Era
o)
        | (Int
i, o :: TxOut CtxTx Era
o@(TxOut AddressInEra Era
addr TxOutValue Era
_ TxOutDatum CtxTx Era
_ ReferenceScript Era
_)) <- [(Int, TxOut CtxTx Era)]
indexed
        , AddressInEra Era
addr AddressInEra Era -> AddressInEra Era -> Bool
forall a. Eq a => a -> a -> Bool
== AddressInEra Era
walletAddr
        ]
  case [(Int, TxOut CtxTx Era)] -> Maybe (Int, TxOut CtxTx Era)
forall a. [a] -> Maybe a
listToMaybe ([(Int, TxOut CtxTx Era)] -> [(Int, TxOut CtxTx Era)]
forall a. [a] -> [a]
reverse [(Int, TxOut CtxTx Era)]
walletOutputs) of
    Maybe (Int, TxOut CtxTx Era)
Nothing -> String -> Either String [TxOut CtxTx Era]
forall a b. a -> Either a b
Left String
"No change output found to wallet address"
    Just (Int
idx, TxOut CtxTx Era
_) -> LedgerProtocolParameters Era
-> Int
-> Value
-> [TxOut CtxTx Era]
-> Either String [TxOut CtxTx Era]
adjustOutputAt LedgerProtocolParameters Era
pparams Int
idx Value
delta [TxOut CtxTx Era]
outputs

{- | Add a value delta to the change output, at the given index.

The delta is added to the change output's value: a negative Lovelace (or
other asset) component subtracts from it. This is used both to cover a plain
fee increase/decrease and, more generally, to absorb whatever residual value
imbalance ('rebalanceAndSign''s 'evaluateTransactionBalance' check) a
'TxModifier' introduced elsewhere in the transaction (e.g. an output that was
added, removed, or resized without a matching change on the input side).

Unlike every other output, the change output can't be fixed up afterwards by
'topUpUnderfundedOutputs': that helper's top-ups are themselves absorbed by a
further adjustment of the change output, so applying it to the change output
itself would just cancel back out. So the minimum-UTxO requirement is checked
right here, on the one output this function is the last thing to touch.
-}
adjustOutputAt
  :: LedgerProtocolParameters Era
  -> Int
  -> Value
  -> [TxOut CtxTx Era]
  -> Either String [TxOut CtxTx Era]
adjustOutputAt :: LedgerProtocolParameters Era
-> Int
-> Value
-> [TxOut CtxTx Era]
-> Either String [TxOut CtxTx Era]
adjustOutputAt LedgerProtocolParameters Era
pparams Int
idx Value
delta [TxOut CtxTx Era]
outputs =
  case Int -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Int -> [a] -> [a]
drop Int
idx [TxOut CtxTx Era]
outputs of
    [] -> String -> Either String [TxOut CtxTx Era]
forall a b. a -> Either a b
Left String
"No change output found to wallet address"
    TxOut AddressInEra Era
addr TxOutValue Era
val TxOutDatum CtxTx Era
datum ReferenceScript Era
refScript : [TxOut CtxTx Era]
_ -> do
      let oldValue :: Value
oldValue = TxOutValue Era -> Value
forall era. TxOutValue era -> Value
txOutValueToValue TxOutValue Era
val
          newValue :: Value
newValue = Value
oldValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
delta
          -- The components the change output would have to go negative in to
          -- absorb the delta. ADA can only run short; a *token* shortfall
          -- can't be fixed with more funds at all: the modification produces
          -- more of the token than the transaction consumes, and only an
          -- input holding that token (or its minting policy validating)
          -- could supply it.
          shortfall :: Value
shortfall = [Item Value] -> Value
forall l. IsList l => [Item l] -> l
fromList [(AssetId
aId, Quantity -> Quantity
forall a. Num a => a -> a
negate Quantity
q) | (AssetId
aId, Quantity
q) <- Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList Value
newValue, Quantity
q Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity
0]
      if Value
shortfall Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
forall a. Monoid a => a
mempty
        then
          String -> Either String [TxOut CtxTx Era]
forall a b. a -> Either a b
Left (String -> Either String [TxOut CtxTx Era])
-> String -> Either String [TxOut CtxTx Era]
forall a b. (a -> b) -> a -> b
$
            String
"Change output cannot cover the value shortfall introduced by the transaction modification: "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (Value -> Text
renderValue Value
shortfall)
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" missing, and no wallet input provides it"
        else do
          let newVal :: TxOutValue Era
newVal = ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (Value -> MaryValue
toMaryValue Value
newValue)
              newOutput :: TxOut CtxTx Era
newOutput = AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra Era
addr TxOutValue Era
newVal TxOutDatum CtxTx Era
datum ReferenceScript Era
refScript
              required :: Coin
required = ShelleyBasedEra Era
-> PParams (ShelleyLedgerEra Era) -> TxOut CtxTx Era -> Coin
forall era.
HasCallStack =>
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> TxOut CtxTx era -> Coin
calculateMinimumUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra (LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
unLedgerProtocolParameters LedgerProtocolParameters Era
pparams) TxOut CtxTx Era
newOutput
          if TxOutValue Era -> Coin
forall era. TxOutValue era -> Coin
txOutValueToLovelace TxOutValue Era
newVal Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
< Coin
required
            then String -> Either String [TxOut CtxTx Era]
forall a b. a -> Either a b
Left String
"Change output would fall below the minimum required ADA after rebalancing"
            else [TxOut CtxTx Era] -> Either String [TxOut CtxTx Era]
forall a b. b -> Either a b
Right ([TxOut CtxTx Era] -> Either String [TxOut CtxTx Era])
-> [TxOut CtxTx Era] -> Either String [TxOut CtxTx Era]
forall a b. (a -> b) -> a -> b
$ Int -> TxOut CtxTx Era -> [TxOut CtxTx Era] -> [TxOut CtxTx Era]
forall a. Int -> a -> [a] -> [a]
replaceAt Int
idx TxOut CtxTx Era
newOutput [TxOut CtxTx Era]
outputs

-- | Replace element at index in a list
replaceAt :: Int -> a -> [a] -> [a]
replaceAt :: forall a. Int -> a -> [a] -> [a]
replaceAt Int
_ a
_ [] = []
replaceAt Int
0 a
x (a
_ : [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
replaceAt Int
n a
x (a
y : [a]
ys) = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> a -> [a] -> [a]
forall a. Int -> a -> [a] -> [a]
replaceAt (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) a
x [a]
ys

{- | Extract coverage data from a ValidationError string containing CovLoc annotations.
Handles the format found in Phase2 script evaluation errors where coverage
annotations appear as "CoverLocation (CovLoc {...})" or "CoverBool (CovLoc {...}) Bool"
-}
extractCoverageFromValidationError :: String -> CoverageData
extractCoverageFromValidationError :: String -> CoverageData
extractCoverageFromValidationError String
errStr =
  [CoverageData] -> CoverageData
forall a. Monoid a => [a] -> a
mconcat ([CoverageData] -> CoverageData) -> [CoverageData] -> CoverageData
forall a b. (a -> b) -> a -> b
$ (String -> CoverageData) -> [String] -> [CoverageData]
forall a b. (a -> b) -> [a] -> [b]
map (String -> CoverageData
coverageDataFromLogMsg (String -> CoverageData) -> ShowS -> String -> CoverageData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
unescapeHaskellString) ([String] -> [CoverageData]) -> [String] -> [CoverageData]
forall a b. (a -> b) -> a -> b
$ String -> [String]
extractCoverageAnnotations String
errStr

-- | Unescape common Haskell string escapes (backslash-quote to quote, backslash-backslash to backslash)
unescapeHaskellString :: String -> String
unescapeHaskellString :: ShowS
unescapeHaskellString [] = []
unescapeHaskellString (Char
'\\' : Char
'"' : String
xs) = Char
'"' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unescapeHaskellString String
xs
unescapeHaskellString (Char
'\\' : Char
'\\' : String
xs) = Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unescapeHaskellString String
xs
unescapeHaskellString (Char
x : String
xs) = Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unescapeHaskellString String
xs

{- | Extract all "CoverLocation (...)" and "CoverBool (...)" substrings from text.
Uses bracket counting to properly match nested parentheses.
-}
extractCoverageAnnotations :: String -> [String]
extractCoverageAnnotations :: String -> [String]
extractCoverageAnnotations [] = []
extractCoverageAnnotations String
s = case String -> Maybe (String, String)
findCoverageStart String
s of
  Maybe (String, String)
Nothing -> []
  Just (String
prefix, String
rest) ->
    case String -> Maybe (String, String)
extractBalancedParens String
rest of
      Maybe (String, String)
Nothing -> String -> [String]
extractCoverageAnnotations (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
s) -- skip and continue
      Just (String
content, String
remaining) ->
        (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
content String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
extractCoverageAnnotations String
remaining
 where
  -- Find "CoverLocation (" or "CoverBool (" prefix
  -- Returns the prefix and rest of string starting with '('
  -- "CoverLocation " is 14 chars, "CoverBool " is 10 chars
  findCoverageStart :: String -> Maybe (String, String)
  findCoverageStart :: String -> Maybe (String, String)
findCoverageStart [] = Maybe (String, String)
forall a. Maybe a
Nothing
  findCoverageStart String
str
    | String
"CoverLocation (" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"CoverLocation ", Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
14 String
str) -- keep "(CovLoc..."
    | String
"CoverBool (" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"CoverBool ", Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
10 String
str) -- keep "(CovLoc..."
    | Bool
otherwise = String -> Maybe (String, String)
findCoverageStart (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
str)

  -- Extract content within balanced parentheses
  -- Expects the string to start with '(' and returns content between matching parens
  extractBalancedParens :: String -> Maybe (String, String)
  extractBalancedParens :: String -> Maybe (String, String)
extractBalancedParens (Char
'(' : String
xs) = Integer -> String -> String -> Maybe (String, String)
go' Integer
1 [] String
xs
   where
    go' :: Integer -> [Char] -> [Char] -> Maybe ([Char], [Char])
    go' :: Integer -> String -> String -> Maybe (String, String)
go' Integer
_ String
_ [] = Maybe (String, String)
forall a. Maybe a
Nothing
    go' Integer
n String
acc (Char
c : String
cs)
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' = Integer -> String -> String -> Maybe (String, String)
go' (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
cs
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' =
          if Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
            then (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (ShowS
forall a. [a] -> [a]
reverse String
acc, String
cs)
            else Integer -> String -> String -> Maybe (String, String)
go' (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
cs
      | Bool
otherwise = Integer -> String -> String -> Maybe (String, String)
go' Integer
n (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) String
cs
  extractBalancedParens String
_ = Maybe (String, String)
forall a. Maybe a
Nothing