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

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

  -- * TxOut accessors
  addressOfTxOut,
  valueOfTxOut,
  datumOfTxOut,
  referenceScriptOfTxOut,

  -- * Redeemer and script data
  redeemerOfTxIn,
  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,
  txInputs,
  txReferenceInputs,
  txOutputs,

  -- * Value utilities
  leqValue,
  projectAda,

  -- * Validation
  ValidityReport (..),
  validateTx,
  validateTxM,
  buildMockState,

  -- * Rebalancing
  rebalanceAndSignM,
  rebalanceAndSign,
  updateExecutionUnits,
  updateTxRedeemersWithExUnits,
  updateScriptDataExUnits,
  recalculateScriptIntegrityHash,
  recalculateTotalCollateral,
  getScriptLanguage,
  getTxFeeCoin,
  setTxFeeCoin,
  setTxOutputsList,
  adjustChangeOutputM,
  adjustChangeOutput,
  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 (getLanguageView, ppCollateralPercentageL)
import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
import Cardano.Ledger.Alonzo.Tx (ScriptIntegrity (..), hashScriptIntegrity)
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.Conway.Scripts qualified as Conway
import Cardano.Ledger.Conway.TxBody qualified as Conway
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.Slotting.Slot ()
import Cardano.Slotting.Time (SlotLength, mkSlotLength)
import Control.Lens ((&), (.~), (^.), _1)
import Data.List (isPrefixOf)

import Convex.CardanoApi.Lenses qualified as L
import Convex.Class (
  ExUnitsError (..),
  MockChainState,
  MonadBlockchain (..),
  MonadMockchain (..),
  SendTxError (..),
  ValidationError (..),
  coverageData,
  env,
  getSlot,
  poolState,
 )
import Convex.MockChain (applyTransaction, initialState)
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 (listToMaybe, mapMaybe)
import Data.Maybe.Strict
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 (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)
_ -> [Char] -> AsIx Word32 TxIn
forall a. HasCallStack => [Char] -> a
error [Char]
"The impossible happened!"

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.
isKeyAddressAny :: AddressAny -> Bool
isKeyAddressAny :: AddressAny -> Bool
isKeyAddressAny = AddressInEra Era -> Bool
forall era. AddressInEra era -> Bool
isKeyAddress (AddressInEra Era -> Bool)
-> (AddressAny -> AddressInEra Era) -> AddressAny -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra Era -> AddressAny -> AddressInEra Era
forall era. ShelleyBasedEra era -> AddressAny -> AddressInEra era
anyAddressInShelleyBasedEra (forall era. IsShelleyBasedEra era => ShelleyBasedEra era
shelleyBasedEra @Era)

recomputeScriptData
  :: Maybe Word32 -- Index to remove
  -> (Word32 -> Word32)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
recomputeScriptData :: Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeScriptData Maybe Word32
_ Word32 -> Word32
_ TxBodyScriptData Era
TxBodyNoScriptData = TxBodyScriptData Era
forall era. TxBodyScriptData era
TxBodyNoScriptData
recomputeScriptData 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 = Ledger.hoistPlutusPurpose (\(Ledger.AsIx ix) -> Ledger.AsIx (f ix)) -- TODO: replace when hoistPlutusPurpose is available
  updatePtr :: ConwayPlutusPurpose AsIx ConwayEra
-> ConwayPlutusPurpose AsIx ConwayEra
updatePtr = \case
    Conway.ConwayMinting (Ledger.AsIx Word32
ix) -> 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 -> Word32
f Word32
ix))
    Conway.ConwaySpending (Ledger.AsIx Word32
ix) -> 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 -> Word32
f Word32
ix))
    Conway.ConwayRewarding (Ledger.AsIx Word32
ix) -> AsIx Word32 RewardAccount -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 RewardAccount -> ConwayPlutusPurpose f era
Conway.ConwayRewarding (Word32 -> AsIx Word32 RewardAccount
forall ix it. ix -> AsIx ix it
Ledger.AsIx (Word32 -> Word32
f Word32
ix))
    Conway.ConwayCertifying (Ledger.AsIx Word32
ix) -> AsIx Word32 (TxCert ConwayEra)
-> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 (TxCert era) -> ConwayPlutusPurpose f era
Conway.ConwayCertifying (Word32 -> AsIx Word32 (TxCert ConwayEra)
forall ix it. ix -> AsIx ix it
Ledger.AsIx (Word32 -> Word32
f Word32
ix))
    Conway.ConwayVoting (Ledger.AsIx Word32
ix) -> AsIx Word32 Voter -> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 Voter -> ConwayPlutusPurpose f era
Conway.ConwayVoting (Word32 -> AsIx Word32 Voter
forall ix it. ix -> AsIx ix it
Ledger.AsIx (Word32 -> Word32
f Word32
ix))
    Conway.ConwayProposing (Ledger.AsIx Word32
ix) -> AsIx Word32 (ProposalProcedure ConwayEra)
-> ConwayPlutusPurpose AsIx ConwayEra
forall (f :: * -> * -> *) era.
f Word32 (ProposalProcedure era) -> ConwayPlutusPurpose f era
Conway.ConwayProposing (Word32 -> AsIx Word32 (ProposalProcedure ConwayEra)
forall ix it. ix -> AsIx ix it
Ledger.AsIx (Word32 -> Word32
f Word32
ix))
  idxFilter :: ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits) -> Bool
idxFilter (Conway.ConwaySpending (Ledger.AsIx Word32
idx)) (Data ConwayEra, ExUnits)
_ = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i
  idxFilter (Conway.ConwayMinting (Ledger.AsIx Word32
idx)) (Data ConwayEra, ExUnits)
_ = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i
  idxFilter (Conway.ConwayCertifying (Ledger.AsIx Word32
idx)) (Data ConwayEra, ExUnits)
_ = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i
  idxFilter (Conway.ConwayRewarding (Ledger.AsIx Word32
idx)) (Data ConwayEra, ExUnits)
_ = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i
  idxFilter (Conway.ConwayVoting (Ledger.AsIx Word32
idx)) (Data ConwayEra, ExUnits)
_ = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i
  idxFilter (Conway.ConwayProposing (Ledger.AsIx Word32
idx)) (Data ConwayEra, ExUnits)
_ = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i

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 ([Char] -> Data ConwayEra
forall a. HasCallStack => [Char] -> a
error [Char]
"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)

-- | Like recomputeScriptData but only updates minting redeemer indices
recomputeScriptDataForMint
  :: Maybe Word32 -- Index to remove
  -> (Word32 -> Word32)
  -> TxBodyScriptData Era
  -> TxBodyScriptData Era
recomputeScriptDataForMint :: Maybe Word32
-> (Word32 -> Word32)
-> TxBodyScriptData Era
-> TxBodyScriptData Era
recomputeScriptDataForMint Maybe Word32
_ Word32 -> Word32
_ TxBodyScriptData Era
TxBodyNoScriptData = TxBodyScriptData Era
forall era. TxBodyScriptData era
TxBodyNoScriptData
recomputeScriptDataForMint 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 = \case
    Conway.ConwayMinting (Ledger.AsIx Word32
ix) -> 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 -> Word32
f Word32
ix))
    ConwayPlutusPurpose AsIx ConwayEra
other -> ConwayPlutusPurpose AsIx ConwayEra
other -- Don't modify non-minting redeemers
  idxFilter :: ConwayPlutusPurpose AsIx ConwayEra
-> (Data ConwayEra, ExUnits) -> Bool
idxFilter (Conway.ConwayMinting (Ledger.AsIx Word32
idx)) (Data ConwayEra, ExUnits)
_ = Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx Maybe Word32 -> Maybe Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Word32
i
  idxFilter ConwayPlutusPurpose AsIx ConwayEra
_ (Data ConwayEra, ExUnits)
_ = Bool
True -- Keep all non-minting redeemers

-- | 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 [Char] Wallet
detectSigningWallet Tx Era
tx =
  case Tx Era -> [Hash PaymentKey]
txSigners Tx Era
tx of
    [] -> [Char] -> Either [Char] Wallet
forall a b. a -> Either a b
Left [Char]
"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 [Char] Wallet
forall a b. b -> Either a b
Right Wallet
w
        [] -> [Char] -> Either [Char] Wallet
forall a b. a -> Either a b
Left [Char]
"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

txInputs :: Tx Era -> [TxIn]
txInputs :: Tx Era -> [TxIn]
txInputs Tx Era
tx = ((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])
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))] -> [TxIn]
forall a b. (a -> b) -> a -> b
$ TxBodyContent ViewTx Era
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn Era))]
forall build era. TxBodyContent build era -> TxIns build era
txIns TxBodyContent ViewTx Era
body
 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

txReferenceInputs :: Tx Era -> [TxIn]
txReferenceInputs :: Tx Era -> [TxIn]
txReferenceInputs Tx Era
tx =
  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
 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

txOutputs :: Tx Era -> [TxOut CtxTx Era]
txOutputs :: Tx Era -> [TxOut CtxTx Era]
txOutputs Tx Era
tx = TxBodyContent ViewTx Era -> [TxOut CtxTx Era]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txOuts TxBodyContent ViewTx Era
body
 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

-- | 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 result of validating a transaction. In case of failure, it includes a list
  of reasons.
-}
data ValidityReport = ValidityReport
  { ValidityReport -> Bool
valid :: Bool
  , ValidityReport -> [[Char]]
errors :: [String]
  }
  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 -> [Char]
(Int -> ValidityReport -> ShowS)
-> (ValidityReport -> [Char])
-> ([ValidityReport] -> ShowS)
-> Show ValidityReport
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidityReport -> ShowS
showsPrec :: Int -> ValidityReport -> ShowS
$cshow :: ValidityReport -> [Char]
show :: ValidityReport -> [Char]
$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 =
  Bool -> [[Char]] -> ValidityReport
ValidityReport
    ((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))
    [ScriptExecutionError -> [Char]
forall a. Show a => a -> [Char]
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]
 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
    }

-- | Build a MockChainState from NodeParams, slot, and UTxO for validation
buildMockState
  :: NodeParams Era
  -> SlotNo
  -> UTxO Era
  -> MockChainState Era
buildMockState :: NodeParams Era -> SlotNo -> UTxO Era -> MockChainState Era
buildMockState NodeParams Era
params SlotNo
slot UTxO Era
utxo =
  NodeParams Era -> MockChainState Era
forall era.
IsShelleyBasedEra era =>
NodeParams era -> MockChainState era
initialState NodeParams Era
params
    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

{- | 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
  -> Tx Era
  -> UTxO Era
  -> m (ValidityReport, CoverageData)
validateTxM :: forall (m :: * -> *).
MonadMockchain Era m =>
NodeParams Era
-> Tx Era -> UTxO Era -> m (ValidityReport, CoverageData)
validateTxM NodeParams Era
params Tx Era
tx UTxO Era
utxo = do
  SlotNo
slot <- m SlotNo
forall era (m :: * -> *). MonadMockchain era m => m SlotNo
getSlot
  let mockState :: MockChainState Era
mockState = NodeParams Era -> SlotNo -> UTxO Era -> MockChainState Era
buildMockState NodeParams Era
params SlotNo
slot UTxO Era
utxo
  (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 (MockchainError (VExUnits (Phase2Error (ScriptErrorEvaluationFailed DebugPlutusFailure{EvaluationError
dpfEvaluationError :: EvaluationError
dpfEvaluationError :: DebugPlutusFailure -> EvaluationError
dpfEvaluationError, EvalTxExecutionUnitsLog
dpfExecutionLogs :: EvalTxExecutionUnitsLog
dpfExecutionLogs :: DebugPlutusFailure -> EvalTxExecutionUnitsLog
dpfExecutionLogs})))) ->
      (Bool -> [[Char]] -> ValidityReport
ValidityReport Bool
False [EvaluationError -> [Char]
forall a. Show a => a -> [Char]
show 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 ([Char] -> CoverageData
coverageDataFromLogMsg ([Char] -> CoverageData)
-> (Text -> [Char]) -> Text -> CoverageData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack) EvalTxExecutionUnitsLog
dpfExecutionLogs)
    Left SendTxError Era
err -> (Bool -> [[Char]] -> ValidityReport
ValidityReport Bool
False [SendTxError Era -> [Char]
forall a. Show a => a -> [Char]
show SendTxError Era
err], CoverageData
forall a. Monoid a => a
mempty)
    Right (MockChainState Era
state', Validated (Tx (ShelleyLedgerEra Era))
_) -> (Bool -> [[Char]] -> ValidityReport
ValidityReport Bool
True [], 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)

{- | 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 (last output to wallet address) to compensate
4. Re-signs the transaction with the wallet's key
-}
rebalanceAndSignM
  :: (MonadMockchain Era m, MonadFail m)
  => Wallet
  -> Tx Era
  -> UTxO Era
  -> m (Tx Era)
rebalanceAndSignM :: forall (m :: * -> *).
(MonadMockchain Era m, MonadFail m) =>
Wallet -> Tx Era -> UTxO Era -> m (Tx Era)
rebalanceAndSignM Wallet
wallet Tx Era
tx UTxO Era
utxo = do
  Either [Char] (Tx Era)
result <- Wallet -> Tx Era -> UTxO Era -> m (Either [Char] (Tx Era))
forall (m :: * -> *).
MonadMockchain Era m =>
Wallet -> Tx Era -> UTxO Era -> m (Either [Char] (Tx Era))
rebalanceAndSign Wallet
wallet Tx Era
tx UTxO Era
utxo
  case Either [Char] (Tx Era)
result of
    Left [Char]
err -> [Char] -> m (Tx Era)
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
    Right Tx Era
signedTx -> Tx Era -> m (Tx Era)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx Era
signedTx

{- | Like 'rebalanceAndSign' but returns Either instead of using MonadFail.

This is useful for threat model execution where we want to handle rebalancing
failures (e.g., "No change output found") as skipped tests rather than errors.
-}
rebalanceAndSign
  :: (MonadMockchain Era m)
  => Wallet
  -> Tx Era
  -> UTxO Era
  -> m (Either String (Tx Era))
rebalanceAndSign :: forall (m :: * -> *).
MonadMockchain Era m =>
Wallet -> Tx Era -> UTxO Era -> m (Either [Char] (Tx Era))
rebalanceAndSign Wallet
wallet 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

  -- First, recalculate execution units for all scripts in the transaction
  -- This is necessary because TxModifier may add scripts with ExecutionUnits 0 0
  let txWithUpdatedExUnits :: Tx Era
txWithUpdatedExUnits = LedgerProtocolParameters Era
-> SystemStart -> EraHistory -> UTxO Era -> Tx Era -> Tx Era
updateExecutionUnits LedgerProtocolParameters Era
pparams SystemStart
systemStart EraHistory
eraHistory UTxO Era
utxo Tx Era
tx

  -- Get the current fee from the transaction (from the ledger body)
  let currentFee :: Coin
currentFee = Tx Era -> Coin
getTxFeeCoin Tx Era
txWithUpdatedExUnits

  -- Create a temp tx with max fee to calculate the actual required fee
  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)
      tempTx :: Tx Era
tempTx = Coin -> Tx Era -> Tx Era
setTxFeeCoin Coin
maxFee Tx Era
txWithUpdatedExUnits
      Tx TxBody Era
tempBody [KeyWitness Era]
_ = Tx Era
tempTx
      newFee :: Coin
newFee =
        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
tempBody
          Word
1

  -- Calculate fee difference
  let feeDiff :: Coin
feeDiff = Coin
newFee Coin -> Coin -> Coin
forall a. Num a => a -> a -> a
- Coin
currentFee -- positive = fee increased

  -- Adjust the change output and set the new fee
  let currentOuts :: [TxOut CtxTx Era]
currentOuts = Tx Era -> [TxOut CtxTx Era]
txOutputs Tx Era
txWithUpdatedExUnits
  case AddressInEra Era
-> Coin -> [TxOut CtxTx Era] -> Either [Char] [TxOut CtxTx Era]
adjustChangeOutput AddressInEra Era
walletAddr Coin
feeDiff [TxOut CtxTx Era]
currentOuts of
    Left [Char]
err -> Either [Char] (Tx Era) -> m (Either [Char] (Tx Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] (Tx Era)
forall a b. a -> Either a b
Left [Char]
err)
    Right [TxOut CtxTx Era]
adjustedOutputs -> do
      -- Apply the changes: new fee and adjusted outputs
      let modifiedTx :: Tx Era
modifiedTx = [TxOut CtxTx Era] -> Tx Era -> Tx Era
setTxOutputsList [TxOut CtxTx Era]
adjustedOutputs (Tx Era -> Tx Era) -> Tx Era -> Tx Era
forall a b. (a -> b) -> a -> b
$ Coin -> Tx Era -> Tx Era
setTxFeeCoin Coin
newFee Tx Era
txWithUpdatedExUnits

      -- Recalculate total collateral based on new fee
      case LedgerProtocolParameters Era
-> UTxO Era -> Tx Era -> Either [Char] (Tx Era)
recalculateTotalCollateral LedgerProtocolParameters Era
pparams UTxO Era
utxo Tx Era
modifiedTx of
        Left [Char]
err -> Either [Char] (Tx Era) -> m (Either [Char] (Tx Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] (Tx Era)
forall a b. a -> Either a b
Left [Char]
err)
        Right Tx Era
txWithCollateral -> do
          -- Recalculate script integrity hash (after updating execution units)
          let finalTx :: Tx Era
finalTx = LedgerProtocolParameters Era -> Tx Era -> Tx Era
recalculateScriptIntegrityHash 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
              signers :: [Hash PaymentKey]
signers = Tx Era -> [Hash PaymentKey]
txSigners Tx Era
tx
              sign :: Hash PaymentKey -> Tx era -> Either [Char] (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 [Char] (Tx era)
forall a b. b -> Either a b
Right (Tx era -> Either [Char] (Tx era))
-> Tx era -> Either [Char] (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 -> [Char] -> Either [Char] (Tx era)
forall a b. a -> Either a b
Left [Char]
"Transaction was signed by an unknown wallet"
          Either [Char] (Tx Era) -> m (Either [Char] (Tx Era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (Tx Era) -> m (Either [Char] (Tx Era)))
-> Either [Char] (Tx Era) -> m (Either [Char] (Tx Era))
forall a b. (a -> b) -> a -> b
$ (Hash PaymentKey -> Tx Era -> Either [Char] (Tx Era))
-> Tx Era -> [Hash PaymentKey] -> Either [Char] (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 [Char] (Tx Era)
forall {era}.
IsShelleyBasedEra era =>
Hash PaymentKey -> Tx era -> Either [Char] (Tx era)
sign Tx Era
unsignedTx [Hash PaymentKey]
signers

{- | 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.
-}
updateExecutionUnits
  :: LedgerProtocolParameters Era
  -> SystemStart
  -> EraHistory
  -> UTxO Era
  -> Tx Era
  -> Tx Era
updateExecutionUnits :: LedgerProtocolParameters Era
-> SystemStart -> EraHistory -> UTxO Era -> Tx Era -> 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)
      -- 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 Map ScriptWitnessIndex ExecutionUnits -> Tx Era -> Tx Era
updateTxRedeemersWithExUnits Map ScriptWitnessIndex ExecutionUnits
successfulExUnits Tx Era
tx

{- | 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 :: LedgerProtocolParameters Era -> Tx Era -> Tx Era
recalculateScriptIntegrityHash :: LedgerProtocolParameters Era -> Tx Era -> Tx Era
recalculateScriptIntegrityHash LedgerProtocolParameters Era
pparams (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
    -- Extract redeemers and datums from scriptData
    (Redeemers ConwayEra
redeemers, TxDats ConwayEra
datums) = case TxBodyScriptData Era
scriptData of
      TxBodyScriptData Era
TxBodyNoScriptData -> (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)
forall a. Monoid a => a
mempty, 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)
      TxBodyScriptData AlonzoEraOnwards Era
_ TxDats (ShelleyLedgerEra Era)
dats Redeemers (ShelleyLedgerEra Era)
rdmrs -> (Redeemers (ShelleyLedgerEra Era)
Redeemers ConwayEra
rdmrs, TxDats (ShelleyLedgerEra Era)
TxDats ConwayEra
dats)

    -- Get the protocol parameters
    pp :: PParams (ShelleyLedgerEra Era)
pp = LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
unLedgerProtocolParameters LedgerProtocolParameters Era
pparams

    -- Determine which languages are used by examining the scripts in the transaction
    usedLangs :: Set Language
usedLangs =
      [Language] -> Set Language
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Language
lang
        | AlonzoScript ConwayEra
script <- [Script (ShelleyLedgerEra Era)]
[AlonzoScript ConwayEra]
scripts
        , Just Language
lang <- [AlonzoScript (ShelleyLedgerEra Era) -> Maybe Language
getScriptLanguage AlonzoScript (ShelleyLedgerEra Era)
AlonzoScript ConwayEra
script]
        ]

    -- Get LangDepView for each used language
    langs :: Set LangDepView
langs =
      [LangDepView] -> Set LangDepView
forall a. Ord a => [a] -> Set a
Set.fromList
        [ PParams ConwayEra -> Language -> LangDepView
forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams (ShelleyLedgerEra Era)
PParams ConwayEra
pp Language
lang
        | Language
lang <- Set Language -> [Language]
forall a. Set a -> [a]
Set.toList Set Language
usedLangs
        ]

    -- Compute new script integrity hash
    -- If no languages are used (e.g., no Plutus scripts), set to SNothing
    newHash :: StrictMaybe ScriptIntegrityHash
newHash =
      if Set LangDepView -> Bool
forall a. Set a -> Bool
Set.null Set LangDepView
langs
        then StrictMaybe ScriptIntegrityHash
forall a. StrictMaybe a
SNothing
        else ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a. a -> StrictMaybe a
SJust (ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash)
-> ScriptIntegrityHash -> StrictMaybe ScriptIntegrityHash
forall a b. (a -> b) -> a -> b
$ ScriptIntegrity ConwayEra -> ScriptIntegrityHash
forall era. Era era => ScriptIntegrity era -> ScriptIntegrityHash
hashScriptIntegrity (Redeemers ConwayEra
-> TxDats ConwayEra -> Set LangDepView -> ScriptIntegrity ConwayEra
forall era.
Redeemers era
-> TxDats era -> Set LangDepView -> ScriptIntegrity era
ScriptIntegrity Redeemers ConwayEra
redeemers TxDats ConwayEra
datums Set LangDepView
langs)

    -- 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)

Returns Left if the collateral inputs don't have enough value to cover the required
collateral. This can happen when a TxModifier significantly increases the transaction
size (and thus the fee) - the original collateral may no longer be sufficient.
-}
recalculateTotalCollateral :: LedgerProtocolParameters Era -> UTxO Era -> Tx Era -> Either String (Tx Era)
recalculateTotalCollateral :: LedgerProtocolParameters Era
-> UTxO Era -> Tx Era -> Either [Char] (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)
  -- If there are no collateral inputs, this is a simple transaction without Plutus scripts.
  -- Return it unchanged - no collateral recalculation needed.
  | Set TxIn -> Bool
forall a. Set a -> Bool
Set.null (TxBody ConwayEra -> Set TxIn
Conway.ctbCollateralInputs TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body) = Tx Era -> Either [Char] (Tx Era)
forall a b. b -> Either a b
Right Tx Era
tx
  | Bool
otherwise =
      let 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
          -- Calculate 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))
          -- Calculate total collateral input value
          collInputs :: [TxIn]
collInputs = Set TxIn -> [TxIn]
forall a. Set a -> [a]
Set.toList (Set TxIn -> [TxIn]) -> Set TxIn -> [TxIn]
forall a b. (a -> b) -> a -> b
$ TxBody ConwayEra -> Set TxIn
Conway.ctbCollateralInputs TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body
          Coin Integer
collInputValue =
            [Coin] -> Coin
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
              [ TxOutValue Era -> Coin
forall era. TxOutValue era -> Coin
txOutValueToLovelace TxOutValue Era
val
              | TxIn
txIn <- [TxIn]
collInputs
              , Just (TxOut AddressInEra Era
_ TxOutValue Era
val TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_) <- [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)]
              ]
          -- 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
       in if Integer
newReturnAmount Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
            then [Char] -> Either [Char] (Tx Era)
forall a b. a -> Either a b
Left ([Char] -> Either [Char] (Tx Era))
-> [Char] -> Either [Char] (Tx Era)
forall a b. (a -> b) -> a -> b
$ [Char]
"Insufficient collateral: inputs=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
collInputValue [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
", need=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
requiredCollAmount
            else
              -- Update both total collateral and collateral return
              let body' :: TxBody ConwayEra
body' =
                    TxBody (ShelleyLedgerEra Era)
body
                      { Conway.ctbTotalCollateral = SJust requiredColl
                      , Conway.ctbCollateralReturn = updateCollateralReturn (Coin newReturnAmount) (Conway.ctbCollateralReturn body)
                      }
               in Tx Era -> Either [Char] (Tx Era)
forall a b. b -> Either a b
Right (Tx Era -> Either [Char] (Tx Era))
-> Tx Era -> Either [Char] (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

{- | Update the collateral return output with a new Ada value.
If there's no existing collateral return, returns SNothing (no collateral return needed).
-}
updateCollateralReturn :: Coin -> StrictMaybe (CBOR.Sized (Ledger.TxOut LedgerEra)) -> StrictMaybe (CBOR.Sized (Ledger.TxOut LedgerEra))
updateCollateralReturn :: Coin
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
-> StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
updateCollateralReturn (Coin Integer
0) StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
_ = StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
StrictMaybe (Sized (BabbageTxOut ConwayEra))
forall a. StrictMaybe a
SNothing -- No return needed if all collateral is used
updateCollateralReturn Coin
_newCoin StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
SNothing = StrictMaybe (Sized (TxOut (ShelleyLedgerEra Era)))
StrictMaybe (Sized (BabbageTxOut ConwayEra))
forall a. StrictMaybe a
SNothing -- No existing return output to modify
updateCollateralReturn Coin
newCoin (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
      -- Create new output with updated Ada value (preserve any non-Ada assets)
      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 (Coin -> Value
lovelaceToValue Coin
newCoin))) TxOutDatum CtxTx Era
datum ReferenceScript Era
rscript
      newLedgerOut :: TxOut ConwayEra
newLedgerOut = 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
newOut)
   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
$ Version -> BabbageTxOut ConwayEra -> Sized (BabbageTxOut ConwayEra)
forall a. EncCBOR a => Version -> a -> Sized a
CBOR.mkSized (forall era. Era era => Version
Ledger.eraProtVerLow @LedgerEra) TxOut ConwayEra
BabbageTxOut ConwayEra
newLedgerOut

-- | 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

-- | Get the fee from a transaction
getTxFeeCoin :: Tx Era -> Coin
getTxFeeCoin :: Tx Era -> Coin
getTxFeeCoin (Tx (ShelleyTxBody ShelleyBasedEra Era
_ TxBody (ShelleyLedgerEra Era)
body [Script (ShelleyLedgerEra Era)]
_ TxBodyScriptData Era
_ Maybe (TxAuxData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_) = TxBody ConwayEra -> Coin
Conway.ctbTxfee TxBody (ShelleyLedgerEra Era)
TxBody ConwayEra
body

-- | 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
          [ 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))
          | TxOut CtxTx Era
out <- [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 last output going to wallet address by fee difference.

If fee increased, we subtract from the change output.
If fee decreased, we add to the change output.
-}
adjustChangeOutputM
  :: (MonadFail m)
  => AddressInEra Era
  -- ^ Wallet address to find change output
  -> Coin
  -- ^ Fee difference (positive = fee increased)
  -> [TxOut CtxTx Era]
  -- ^ Transaction outputs
  -> m [TxOut CtxTx Era]
adjustChangeOutputM :: forall (m :: * -> *).
MonadFail m =>
AddressInEra Era
-> Coin -> [TxOut CtxTx Era] -> m [TxOut CtxTx Era]
adjustChangeOutputM AddressInEra Era
walletAddr Coin
feeDiff [TxOut CtxTx Era]
outputs =
  case AddressInEra Era
-> Coin -> [TxOut CtxTx Era] -> Either [Char] [TxOut CtxTx Era]
adjustChangeOutput AddressInEra Era
walletAddr Coin
feeDiff [TxOut CtxTx Era]
outputs of
    Left [Char]
err -> [Char] -> m [TxOut CtxTx Era]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
err
    Right [TxOut CtxTx Era]
result -> [TxOut CtxTx Era] -> m [TxOut CtxTx Era]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TxOut CtxTx Era]
result

-- | Like 'adjustChangeOutput' but returns Either instead of using MonadFail.
adjustChangeOutput
  :: AddressInEra Era
  -- ^ Wallet address to find change output
  -> Coin
  -- ^ Fee difference (positive = fee increased)
  -> [TxOut CtxTx Era]
  -- ^ Transaction outputs
  -> Either String [TxOut CtxTx Era]
adjustChangeOutput :: AddressInEra Era
-> Coin -> [TxOut CtxTx Era] -> Either [Char] [TxOut CtxTx Era]
adjustChangeOutput AddressInEra Era
walletAddr (Coin Integer
feeDiff) [TxOut CtxTx Era]
outputs = do
  -- Find last output to wallet address
  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 -> [Char] -> Either [Char] [TxOut CtxTx Era]
forall a b. a -> Either a b
Left [Char]
"No change output found to wallet address"
    Just (Int
idx, TxOut AddressInEra Era
addr TxOutValue Era
val TxOutDatum CtxTx Era
datum ReferenceScript Era
refScript) -> do
      let Coin Integer
oldAda = TxOutValue Era -> Coin
forall era. TxOutValue era -> Coin
txOutValueToLovelace TxOutValue Era
val
          newAda :: Integer
newAda = Integer
oldAda Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
feeDiff -- subtract fee increase (or add fee decrease)
      if Integer
newAda Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
        then [Char] -> Either [Char] [TxOut CtxTx Era]
forall a b. a -> Either a b
Left [Char]
"Change output cannot cover fee increase"
        else do
          let newLovelace :: Coin
newLovelace = Integer -> Coin
Coin Integer
newAda
              -- Preserve non-Ada assets in the value
              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 -> Value
negateValue (Coin -> Value
lovelaceToValue (Integer -> Coin
Coin Integer
oldAda)) Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Coin -> Value
lovelaceToValue Coin
newLovelace
              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
          [TxOut CtxTx Era] -> Either [Char] [TxOut CtxTx Era]
forall a b. b -> Either a b
Right ([TxOut CtxTx Era] -> Either [Char] [TxOut CtxTx Era])
-> [TxOut CtxTx Era] -> Either [Char] [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 :: [Char] -> CoverageData
extractCoverageFromValidationError [Char]
errStr =
  [CoverageData] -> CoverageData
forall a. Monoid a => [a] -> a
mconcat ([CoverageData] -> CoverageData) -> [CoverageData] -> CoverageData
forall a b. (a -> b) -> a -> b
$ ([Char] -> CoverageData) -> [[Char]] -> [CoverageData]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> CoverageData
coverageDataFromLogMsg ([Char] -> CoverageData) -> ShowS -> [Char] -> CoverageData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
unescapeHaskellString) ([[Char]] -> [CoverageData]) -> [[Char]] -> [CoverageData]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
extractCoverageAnnotations [Char]
errStr

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

{- | Extract all "CoverLocation (...)" and "CoverBool (...)" substrings from text.
Uses bracket counting to properly match nested parentheses.
-}
extractCoverageAnnotations :: String -> [String]
extractCoverageAnnotations :: [Char] -> [[Char]]
extractCoverageAnnotations [] = []
extractCoverageAnnotations [Char]
s = case [Char] -> Maybe ([Char], [Char])
findCoverageStart [Char]
s of
  Maybe ([Char], [Char])
Nothing -> []
  Just ([Char]
prefix, [Char]
rest) ->
    case [Char] -> Maybe ([Char], [Char])
extractBalancedParens [Char]
rest of
      Maybe ([Char], [Char])
Nothing -> [Char] -> [[Char]]
extractCoverageAnnotations (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
s) -- skip and continue
      Just ([Char]
content, [Char]
remaining) ->
        ([Char]
prefix [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
content [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")") [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char] -> [[Char]]
extractCoverageAnnotations [Char]
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 :: [Char] -> Maybe ([Char], [Char])
findCoverageStart [] = Maybe ([Char], [Char])
forall a. Maybe a
Nothing
  findCoverageStart [Char]
str
    | [Char]
"CoverLocation (" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
str = ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
"CoverLocation ", Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
14 [Char]
str) -- keep "(CovLoc..."
    | [Char]
"CoverBool (" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
str = ([Char], [Char]) -> Maybe ([Char], [Char])
forall a. a -> Maybe a
Just ([Char]
"CoverBool ", Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
10 [Char]
str) -- keep "(CovLoc..."
    | Bool
otherwise = [Char] -> Maybe ([Char], [Char])
findCoverageStart (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 [Char]
str)

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