{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Alonzo.ImpTest (
  module Test.Cardano.Ledger.Mary.ImpTest,
  AlonzoEraImp (..),
  impLookupPlutusScriptMaybe,
  malformedPlutus,
  addCollateralInput,
  impGetPlutusContexts,
  alonzoFixupTx,
  plutusTestScripts,
  impGetScriptContext,
  impGetScriptContextMaybe,
  impPlutusWithContexts,
  impScriptPredicateFailure,
  submitPhase2Invalid_,
  submitPhase2Invalid,
  expectTxSuccess,
  -- Fixup
  fixupDatums,
  fixupOutputDatums,
  fixupPPHash,
  fixupRedeemers,
  fixupRedeemerIndices,
  fixupScriptWits,
) where

import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN)
import Cardano.Crypto.Hash.Blake2b (Blake2b_224)
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis (..))
import Cardano.Ledger.Alonzo.PParams (getLanguageView)
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  collectPlutusScriptsWithContext,
  evalPlutusScriptsWithLogs,
  evalTxExUnits,
 )
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosPredFailure (..),
  TagMismatchDescription (..),
  scriptFailureToFailureDescription,
 )
import Cardano.Ledger.Alonzo.Scripts (plutusScriptLanguage, toAsItem, toAsIx)
import Cardano.Ledger.Alonzo.Tx (IsValid (..), hashScriptIntegrity)
import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..))
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (..), AlonzoScriptsNeeded (..))
import Cardano.Ledger.BaseTypes (Globals (..), StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Crypto (Crypto (..))
import Cardano.Ledger.Keys (Hash)
import Cardano.Ledger.Plutus (
  Data (..),
  Datum (..),
  ExUnits (..),
  Language (..),
  Plutus (..),
  PlutusBinary (..),
  PlutusLanguage,
  PlutusWithContext (..),
  Prices (..),
  SLanguage (..),
  ScriptResult (..),
  hashData,
  hashPlutusScript,
 )
import Cardano.Ledger.Shelley.LedgerState (
  curPParamsEpochStateL,
  esLStateL,
  lsUTxOStateL,
  nesEsL,
  utxosUtxoL,
 )
import Cardano.Ledger.Shelley.UTxO (EraUTxO (..), ScriptsProvided (..), UTxO (..), txouts)
import Cardano.Ledger.TxIn (TxIn)
import Control.Monad (forM)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.MapExtras (fromElems)
import Data.Maybe (catMaybes, isJust, isNothing)
import Data.Set (Set, (\\))
import qualified Data.Set as Set
import Lens.Micro
import Lens.Micro.Mtl (use)
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.TreeDiff ()
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Mary.ImpTest
import Test.Cardano.Ledger.Plutus (
  PlutusArgs (..),
  ScriptTestContext (..),
  testingCostModels,
 )
import Test.Cardano.Ledger.Plutus.Examples
import Test.Cardano.Ledger.Plutus.Guardrail (guardrailScript)

class
  ( MaryEraImp era
  , AlonzoEraScript era
  , AlonzoEraTxWits era
  , AlonzoEraTx era
  , AlonzoEraUTxO era
  , EraPlutusContext era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , TxAuxData era ~ AlonzoTxAuxData era
  ) =>
  AlonzoEraImp era
  where
  scriptTestContexts :: Map (ScriptHash (EraCrypto era)) ScriptTestContext

makeCollateralInput :: ShelleyEraImp era => ImpTestM era (TxIn (EraCrypto era))
makeCollateralInput :: forall era.
ShelleyEraImp era =>
ImpTestM era (TxIn (EraCrypto era))
makeCollateralInput = do
  -- TODO: make more accurate
  let collateral :: Coin
collateral = Integer -> Coin
Coin Integer
10_000_000
  Addr (EraCrypto era)
addr <- forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (Addr c)
freshKeyAddr_
  forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withFixup forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx forall a b. (a -> b) -> a -> b
$ forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo Addr (EraCrypto era)
addr Coin
collateral

addCollateralInput ::
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
addCollateralInput :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
addCollateralInput Tx era
tx
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
collateralInputsTxBodyL)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx
  | Bool
otherwise = do
      [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
ctx <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era
     [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
       ScriptTestContext)]
impGetPlutusContexts Tx era
tx
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
ctx
        then forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
tx
        else do
          forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"addCollateralInput" forall a b. (a -> b) -> a -> b
$ do
            TxIn (EraCrypto era)
collateralInput <- forall era.
ShelleyEraImp era =>
ImpTestM era (TxIn (EraCrypto era))
makeCollateralInput
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
collateralInputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
collateralInput

impLookupPlutusScriptMaybe ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash (EraCrypto era) ->
  Maybe (PlutusScript era)
impLookupPlutusScriptMaybe :: forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash (EraCrypto era)
sh =
  (\(ScriptTestContext Plutus l
plutus PlutusArgs
_) -> forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript Plutus l
plutus) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe ScriptTestContext
impGetScriptContextMaybe @era ScriptHash (EraCrypto era)
sh

impGetPlutusContexts ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era), ScriptTestContext)]
impGetPlutusContexts :: forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era
     [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
       ScriptTestContext)]
impGetPlutusContexts Tx era
tx = do
  let txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
  UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
  let AlonzoScriptsNeeded [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era))]
asn = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo TxBody era
txBody
  [Maybe
   (PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
    ScriptTestContext)]
mbyContexts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era))]
asn forall a b. (a -> b) -> a -> b
$ \(PlutusPurpose AsIxItem era
prp, ScriptHash (EraCrypto era)
sh) -> do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (PlutusPurpose AsIxItem era
prp,ScriptHash (EraCrypto era)
sh,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe ScriptTestContext
impGetScriptContextMaybe @era ScriptHash (EraCrypto era)
sh
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe
   (PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
    ScriptTestContext)]
mbyContexts

fixupRedeemerIndices ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupRedeemerIndices :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupRedeemerIndices Tx era
tx = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemerIndices" forall a b. (a -> b) -> a -> b
$ do
  (TxIn (EraCrypto era)
rootTxIn, TxOut era
_) <- forall era. ImpTestM era (TxIn (EraCrypto era), TxOut era)
lookupImpRootTxOut
  let
    txInputs :: Set (TxIn (EraCrypto era))
txInputs = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL
    rootTxIndex :: Word32
rootTxIndex = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Int
Set.findIndex TxIn (EraCrypto era)
rootTxIn Set (TxIn (EraCrypto era))
txInputs
    updateIndex :: PlutusPurpose AsIx era -> PlutusPurpose AsIx era
updateIndex (SpendingPurpose (AsIx Word32
i))
      | Word32
i forall a. Ord a => a -> a -> Bool
>= Word32
rootTxIndex = forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxIn (EraCrypto era)) -> PlutusPurpose f era
SpendingPurpose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ix it. ix -> AsIx ix it
AsIx forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> a
succ Word32
i
    updateIndex PlutusPurpose AsIx era
x = PlutusPurpose AsIx era
x
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
        forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\(Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
m) -> forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall a b. (a -> b) -> a -> b
$ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PlutusPurpose AsIx era -> PlutusPurpose AsIx era
updateIndex Map (PlutusPurpose AsIx era) (Data era, ExUnits)
m)

fixupRedeemers ::
  forall era.
  (AlonzoEraImp era, HasCallStack) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupRedeemers :: forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupRedeemers Tx era
tx = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupRedeemers" forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contexts <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era
     [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
       ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  let
    maxExUnit :: ExUnits
maxExUnit = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
    mkNewMaxRedeemers :: (PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
 ScriptTestContext)
-> (PlutusPurpose AsIx era, (Data era, ExUnits))
mkNewMaxRedeemers (PlutusPurpose AsIxItem era
prpIdx, ScriptHash (EraCrypto era)
_, ScriptTestContext Plutus l
_ (PlutusArgs Data
dat Maybe Data
_)) =
      (forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose @era forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
prpIdx, (forall era. Era era => Data -> Data era
Data Data
dat, ExUnits
maxExUnit))
    Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
oldRedeemers = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
    newMaxRedeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
 ScriptTestContext)
-> (PlutusPurpose AsIx era, (Data era, ExUnits))
mkNewMaxRedeemers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contexts)
    txWithMaxExUnits :: Tx era
txWithMaxExUnits =
      Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  Globals {SystemStart
systemStart :: Globals -> SystemStart
systemStart :: SystemStart
systemStart, EpochInfo (Either Text)
epochInfo :: Globals -> EpochInfo (Either Text)
epochInfo :: EpochInfo (Either Text)
epochInfo} <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
  let reports :: RedeemerReport era
reports = forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits PParams era
pp Tx era
txWithMaxExUnits UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart
  Map (PlutusPurpose AsIx era) ExUnits
exUnitsPerPurpose <-
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM RedeemerReport era
reports forall a b. (a -> b) -> a -> b
$ \case
      Left TransactionScriptFailure era
err -> do
        forall t. HasCallStack => String -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ String
"Execution Units estimation error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TransactionScriptFailure era
err
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Right ExUnits
exUnits ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ExUnits
exUnits
  let
    mkNewRedeemers :: (PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
 ScriptTestContext)
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
mkNewRedeemers (PlutusPurpose AsIxItem era
prpIdx, ScriptHash (EraCrypto era)
_, ScriptTestContext Plutus l
_ (PlutusArgs Data
dat Maybe Data
_)) =
      let ptr :: PlutusPurpose AsIx era
ptr = forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose @era forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
prpIdx
       in case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PlutusPurpose AsIx era
ptr Map (PlutusPurpose AsIx era) (Data era, ExUnits)
oldRedeemers of
            Just (Data era, ExUnits)
redeemer -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PlutusPurpose AsIx era
ptr, (Data era, ExUnits)
redeemer)
            Maybe (Data era, ExUnits)
Nothing ->
              case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PlutusPurpose AsIx era
ptr Map (PlutusPurpose AsIx era) ExUnits
exUnitsPerPurpose of
                Maybe ExUnits
Nothing -> do
                  forall t. HasCallStack => String -> ImpM t ()
logString forall a b. (a -> b) -> a -> b
$ String
"Missing Redeemer Ptr from execution estimation: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show PlutusPurpose AsIx era
ptr
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                Just ExUnits
exUnits ->
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (PlutusPurpose AsIx era
ptr, (forall era. Era era => Data -> Data era
Data Data
dat, ExUnits
exUnits))
  Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newRedeemers <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
 ScriptTestContext)
-> ImpM
     (LedgerSpec era)
     (Maybe (PlutusPurpose AsIx era, (Data era, ExUnits)))
mkNewRedeemers [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contexts
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers (forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map (PlutusPurpose AsIx era) (Data era, ExUnits)
oldRedeemers, Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newRedeemers, Map (PlutusPurpose AsIx era) (Data era, ExUnits)
newMaxRedeemers])

fixupScriptWits ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupScriptWits :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupScriptWits Tx era
tx = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupScriptWits" forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contexts <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era
     [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
       ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let ScriptsProvided Map (ScriptHash (EraCrypto era)) (Script era)
provided = forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx era
tx
  let contextsToAdd :: [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contextsToAdd = forall a. (a -> Bool) -> [a] -> [a]
filter (\(PlutusPurpose AsIxItem era
_, ScriptHash (EraCrypto era)
sh, ScriptTestContext
_) -> Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
Map.member ScriptHash (EraCrypto era)
sh Map (ScriptHash (EraCrypto era)) (Script era)
provided)) [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contexts
  let
    plutusToScript ::
      forall l.
      PlutusLanguage l =>
      Plutus l ->
      ImpTestM era (Script era)
    plutusToScript :: forall (l :: Language).
PlutusLanguage l =>
Plutus l -> ImpTestM era (Script era)
plutusToScript Plutus l
p =
      case forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript @era Plutus l
p of
        Just PlutusScript era
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
x
        Maybe (PlutusScript era)
Nothing -> forall a. HasCallStack => String -> a
error String
"Plutus version not supported by era"
  [(ScriptHash (EraCrypto era), Script era)]
scriptWits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contextsToAdd forall a b. (a -> b) -> a -> b
$ \(PlutusPurpose AsIxItem era
_, ScriptHash (EraCrypto era)
sh, ScriptTestContext Plutus l
plutus PlutusArgs
_) ->
    (ScriptHash (EraCrypto era)
sh,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (l :: Language).
PlutusLanguage l =>
Plutus l -> ImpTestM era (Script era)
plutusToScript Plutus l
plutus
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map (ScriptHash (EraCrypto era)) (Script era))
scriptTxWitsL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(ScriptHash (EraCrypto era), Script era)]
scriptWits

fixupDatums ::
  forall era.
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
fixupDatums :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
fixupDatums Tx era
tx = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupDatums" forall a b. (a -> b) -> a -> b
$ do
  [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contexts <- forall era.
AlonzoEraImp era =>
Tx era
-> ImpTestM
     era
     [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
       ScriptTestContext)]
impGetPlutusContexts Tx era
tx
  let purposes :: [PlutusPurpose AsIxItem era]
purposes = (forall s a. s -> Getting a s a -> a
^. forall s t a b. Field1 s t a b => Lens s t a b
_1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PlutusPurpose AsIxItem era, ScriptHash (EraCrypto era),
  ScriptTestContext)]
contexts
  [Maybe (Data era)]
datums <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
collectDatums [PlutusPurpose AsIxItem era]
purposes
  let TxDats Map (DataHash (EraCrypto era)) (Data era)
prevDats = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
Era era =>
Map (DataHash (EraCrypto era)) (Data era) -> TxDats era
TxDats
          (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (DataHash (EraCrypto era)) (Data era)
prevDats forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems forall era. Era era => Data era -> DataHash (EraCrypto era)
hashData (forall a. [Maybe a] -> [a]
catMaybes [Maybe (Data era)]
datums))
  where
    collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
    collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era))
collectDatums PlutusPurpose AsIxItem era
purpose = do
      let txIn :: Maybe (TxIn (EraCrypto era))
txIn = forall ix it. AsItem ix it -> it
unAsItem forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 (TxIn (EraCrypto era)))
toSpendingPurpose (forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
purpose)
      Maybe (TxOut era)
txOut <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall era.
ShelleyEraImp era =>
TxIn (EraCrypto era) -> ImpTestM era (TxOut era)
impLookupUTxO @era) Maybe (TxIn (EraCrypto era))
txIn
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TxOut era -> Maybe (Data era)
getData forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (TxOut era)
txOut

    getData :: TxOut era -> Maybe (Data era)
    getData :: TxOut era -> Maybe (Data era)
getData TxOut era
txOut = case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
SimpleGetter (TxOut era) (Datum era)
datumTxOutF of
      DatumHash DataHash (EraCrypto era)
_dh -> forall {era}. Era era => ScriptTestContext -> Data era
spendDatum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall {era}.
EraTxOut era =>
TxOut era -> ScriptHash (EraCrypto era)
txOutScriptHash TxOut era
txOut) (forall era.
AlonzoEraImp era =>
Map (ScriptHash (EraCrypto era)) ScriptTestContext
scriptTestContexts @era)
      Datum era
_ -> forall a. Maybe a
Nothing

    txOutScriptHash :: TxOut era -> ScriptHash (EraCrypto era)
txOutScriptHash TxOut era
txOut
      | Addr Network
_ (ScriptHashObj ScriptHash (EraCrypto era)
sh) StakeReference (EraCrypto era)
_ <- TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL = ScriptHash (EraCrypto era)
sh
      | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"TxOut does not have a payment script"

    spendDatum :: ScriptTestContext -> Data era
spendDatum (ScriptTestContext Plutus l
_ (PlutusArgs Data
_ (Just Data
d))) = forall era. Era era => Data -> Data era
Data Data
d
    spendDatum ScriptTestContext
_ = forall a. HasCallStack => String -> a
error String
"Context does not have a spending datum"

fixupPPHash ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupPPHash :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash Tx era
tx = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupPPHash" forall a b. (a -> b) -> a -> b
$ do
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  let
    scriptHashes :: Set (ScriptHash (EraCrypto era))
    scriptHashes :: Set (ScriptHash (EraCrypto era))
scriptHashes = forall era.
EraUTxO era =>
ScriptsNeeded era -> Set (ScriptHash (EraCrypto era))
getScriptsHashesNeeded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
    plutusLanguage :: ScriptHash (EraCrypto era)
-> ImpM (LedgerSpec era) (Maybe LangDepView)
plutusLanguage ScriptHash (EraCrypto era)
sh = do
      let mbyPlutus :: Maybe (PlutusScript era)
mbyPlutus = forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash (EraCrypto era)
sh
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams era
pp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage @era forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PlutusScript era)
mbyPlutus
  [Maybe LangDepView]
langs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ScriptHash (EraCrypto era)
-> ImpM (LedgerSpec era) (Maybe LangDepView)
plutusLanguage forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set (ScriptHash (EraCrypto era))
scriptHashes
  let
    integrityHash :: StrictMaybe (ScriptIntegrityHash (EraCrypto era))
integrityHash =
      forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era
-> TxDats era
-> StrictMaybe (ScriptIntegrityHash (EraCrypto era))
hashScriptIntegrity
        (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe LangDepView]
langs)
        (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL)
        (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    Tx era
tx
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxBody era =>
Lens'
  (TxBody era) (StrictMaybe (ScriptIntegrityHash (EraCrypto era)))
scriptIntegrityHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (ScriptIntegrityHash (EraCrypto era))
integrityHash

fixupOutputDatums ::
  forall era.
  AlonzoEraImp era =>
  Tx era ->
  ImpTestM era (Tx era)
fixupOutputDatums :: forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupOutputDatums Tx era
tx = forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"fixupOutputDatums" forall a b. (a -> b) -> a -> b
$ do
  let
    addDatum :: TxOut era -> TxOut era
addDatum TxOut era
txOut =
      case TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
addrTxOutL of
        Addr Network
_ (ScriptHashObj ScriptHash (EraCrypto era)
sh) StakeReference (EraCrypto era)
_
          | Just (ScriptTestContext Plutus l
_ (PlutusArgs Data
_ (Just Data
spendDatum))) <- forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe ScriptTestContext
impGetScriptContextMaybe @era ScriptHash (EraCrypto era)
sh
          , Datum era
NoDatum <- TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
SimpleGetter (TxOut era) (Datum era)
datumTxOutF ->
              TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (DataHash (EraCrypto era)))
dataHashTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall era. Era era => Data era -> DataHash (EraCrypto era)
hashData @era forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data -> Data era
Data Data
spendDatum)
        Addr (EraCrypto era)
_ -> TxOut era
txOut
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut era -> TxOut era
addDatum

alonzoFixupTx ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
alonzoFixupTx :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupTx =
  forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addNativeScriptTxWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era (m :: * -> *).
(EraTx era, Applicative m) =>
Tx era -> m (Tx era)
fixupAuxDataHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
addCollateralInput
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
addRootTxIn
    -- We need to update the indices after adding the rootTxIn because the
    -- indices of inputs might get bumped if the rootTxIn appears before them
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupScriptWits
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupOutputDatums
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
fixupDatums
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupRedeemerIndices
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(AlonzoEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupRedeemers
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTxOuts
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupFees
    forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits

mkScriptTestEntry ::
  (PlutusLanguage l, Crypto c) =>
  Plutus l ->
  PlutusArgs ->
  (ScriptHash c, ScriptTestContext)
mkScriptTestEntry :: forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry Plutus l
script PlutusArgs
args =
  ( forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript Plutus l
script
  , ScriptTestContext
      { stcScript :: Plutus l
stcScript = Plutus l
script
      , stcArgs :: PlutusArgs
stcArgs = PlutusArgs
args
      }
  )

plutusTestScripts ::
  forall c l.
  (Crypto c, PlutusLanguage l) =>
  SLanguage l ->
  Map.Map (ScriptHash c) ScriptTestContext
plutusTestScripts :: forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
SLanguage l -> Map (ScriptHash c) ScriptTestContext
plutusTestScripts SLanguage l
lang =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). Plutus l
malformedPlutus @l) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
7)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) forall a. Maybe a
Nothing
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
0)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) forall a. Maybe a
Nothing
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
0)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
3) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
3)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
evenDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
3) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
26)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
2) forall a. Maybe a
Nothing
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
22) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
2) forall a. Maybe a
Nothing
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
22) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
datumIsWellformed SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
221) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyNoDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
122) forall a. Maybe a
Nothing
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry (forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyWithDatum SLanguage l
lang) forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
222) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
5)
    , forall (l :: Language) c.
(PlutusLanguage l, Crypto c) =>
Plutus l -> PlutusArgs -> (ScriptHash c, ScriptTestContext)
mkScriptTestEntry Plutus 'PlutusV3
guardrailScript forall a b. (a -> b) -> a -> b
$ Data -> Maybe Data -> PlutusArgs
PlutusArgs (Integer -> Data
P.I Integer
0) forall a. Maybe a
Nothing
    ]

malformedPlutus :: Plutus l
malformedPlutus :: forall (l :: Language). Plutus l
malformedPlutus = forall (l :: Language). PlutusBinary -> Plutus l
Plutus (ShortByteString -> PlutusBinary
PlutusBinary ShortByteString
"invalid")

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
  ) =>
  ShelleyEraImp (AlonzoEra c)
  where
  initGenesis :: forall s (m :: * -> *) g.
(HasKeyPairs s (EraCrypto (AlonzoEra c)), MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis (AlonzoEra c))
initGenesis =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      AlonzoGenesis
        { agCoinsPerUTxOWord :: CoinPerWord
agCoinsPerUTxOWord = Coin -> CoinPerWord
CoinPerWord (Integer -> Coin
Coin Integer
34482)
        , -- TODO: Replace with correct cost model.
          agCostModels :: CostModels
agCostModels = HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV1]
        , agPrices :: Prices
agPrices =
            Prices
              { prMem :: NonNegativeInterval
prMem = Integer
577 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10_000
              , prSteps :: NonNegativeInterval
prSteps = Integer
721 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
10_000_000
              }
        , agMaxTxExUnits :: ExUnits
agMaxTxExUnits =
            ExUnits
              { exUnitsMem :: Natural
exUnitsMem = Natural
10_000_000
              , exUnitsSteps :: Natural
exUnitsSteps = Natural
10_000_000_000
              }
        , agMaxBlockExUnits :: ExUnits
agMaxBlockExUnits =
            ExUnits
              { exUnitsMem :: Natural
exUnitsMem = Natural
50_000_000
              , exUnitsSteps :: Natural
exUnitsSteps = Natural
40_000_000_000
              }
        , agMaxValSize :: Natural
agMaxValSize = Natural
5000
        , agCollateralPercentage :: Natural
agCollateralPercentage = Natural
150
        , agMaxCollateralInputs :: Natural
agMaxCollateralInputs = Natural
3
        }

  impSatisfyNativeScript :: Set (KeyHash 'Witness (EraCrypto (AlonzoEra c)))
-> TxBody (AlonzoEra c)
-> NativeScript (AlonzoEra c)
-> ImpTestM
     (AlonzoEra c)
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto (AlonzoEra c)))
           (KeyPair 'Witness (EraCrypto (AlonzoEra c)))))
impSatisfyNativeScript = forall era.
(AllegraEraScript era, AllegraEraTxBody era) =>
Set (KeyHash 'Witness (EraCrypto era))
-> TxBody era
-> NativeScript era
-> ImpTestM
     era
     (Maybe
        (Map
           (KeyHash 'Witness (EraCrypto era))
           (KeyPair 'Witness (EraCrypto era))))
impAllegraSatisfyNativeScript
  fixupTx :: HasCallStack =>
Tx (AlonzoEra c) -> ImpTestM (AlonzoEra c) (Tx (AlonzoEra c))
fixupTx = forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (Tx era)
alonzoFixupTx

instance
  ( Crypto c
  , NFData (SigDSIGN (DSIGN c))
  , NFData (VerKeyDSIGN (DSIGN c))
  , ADDRHASH c ~ Blake2b_224
  , DSIGN c ~ Ed25519DSIGN
  , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody)
  ) =>
  MaryEraImp (AlonzoEra c)

instance MaryEraImp (AlonzoEra c) => AlonzoEraImp (AlonzoEra c) where
  scriptTestContexts :: Map (ScriptHash (EraCrypto (AlonzoEra c))) ScriptTestContext
scriptTestContexts = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
SLanguage l -> Map (ScriptHash c) ScriptTestContext
plutusTestScripts SLanguage 'PlutusV1
SPlutusV1

impGetScriptContextMaybe ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash (EraCrypto era) ->
  Maybe ScriptTestContext
impGetScriptContextMaybe :: forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe ScriptTestContext
impGetScriptContextMaybe ScriptHash (EraCrypto era)
sh = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash (EraCrypto era)
sh forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraImp era =>
Map (ScriptHash (EraCrypto era)) ScriptTestContext
scriptTestContexts @era

impGetScriptContext ::
  forall era.
  AlonzoEraImp era =>
  ScriptHash (EraCrypto era) ->
  ImpTestM era ScriptTestContext
impGetScriptContext :: forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> ImpTestM era ScriptTestContext
impGetScriptContext ScriptHash (EraCrypto era)
sh =
  forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (String
"Getting script context for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ScriptHash (EraCrypto era)
sh)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust
    forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe ScriptTestContext
impGetScriptContextMaybe @era ScriptHash (EraCrypto era)
sh

impPlutusWithContexts ::
  (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era [PlutusWithContext (EraCrypto era)]
impPlutusWithContexts :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era [PlutusWithContext (EraCrypto era)]
impPlutusWithContexts Tx era
tx = do
  Globals
globals <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
  PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
  UTxO era
utxo <- forall era. ImpTestM era (UTxO era)
getUTxO
  case forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext (EraCrypto era)]
collectPlutusScriptsWithContext (Globals -> EpochInfo (Either Text)
epochInfo Globals
globals) (Globals -> SystemStart
systemStart Globals
globals) PParams era
pp Tx era
tx UTxO era
utxo of
    Left [CollectError era]
errs ->
      forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Did not expect to get context translation failures: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [CollectError era]
errs)
    Right [PlutusWithContext (EraCrypto era)]
pwcs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [PlutusWithContext (EraCrypto era)]
pwcs

impScriptPredicateFailure ::
  (HasCallStack, AlonzoEraImp era) => Tx era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure Tx era
tx = do
  [PlutusWithContext (EraCrypto era)]
plutusWithContexts <- forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era [PlutusWithContext (EraCrypto era)]
impPlutusWithContexts Tx era
tx
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PlutusWithContext (EraCrypto era)]
plutusWithContexts) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure String
"Could not find any plutus scripts in the transaction"
  case forall c. [PlutusWithContext c] -> ([Text], ScriptResult c)
evalPlutusScriptsWithLogs [PlutusWithContext (EraCrypto era)]
plutusWithContexts of
    ([Text]
logs, Passes [PlutusWithContext (EraCrypto era)]
_) ->
      forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$
        String
"Plutus script: \n"
          forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [PlutusWithContext (EraCrypto era)]
plutusWithContexts)
          forall a. [a] -> [a] -> [a]
++ String
"passed unexpectedly: \n"
          forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Text]
logs)
    ([Text]
_, Fails [PlutusWithContext (EraCrypto era)]
_ NonEmpty (ScriptFailure (EraCrypto era))
failures) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch
          (Bool -> IsValid
IsValid Bool
True)
          (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (forall c. Crypto c => ScriptFailure c -> FailureDescription
scriptFailureToFailureDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ScriptFailure (EraCrypto era))
failures))

submitPhase2Invalid_ ::
  ( HasCallStack
  , AlonzoEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  Tx era ->
  ImpTestM era ()
submitPhase2Invalid_ :: forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid

submitPhase2Invalid ::
  ( HasCallStack
  , AlonzoEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  Tx era ->
  ImpTestM era (Tx era)
submitPhase2Invalid :: forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era (Tx era)
submitPhase2Invalid Tx era
tx = do
  Tx era
fixedUpTx <-
    forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Check that tx fails with IsValid True" forall a b. (a -> b) -> a -> b
$ do
      Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool -> IsValid
IsValid Bool
True
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailure, Tx era
fixedUpTx) <- forall b (m :: * -> *) a.
(HasCallStack, Show b, MonadIO m) =>
Either a b -> m a
expectLeft forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)), Tx era)
        (Tx era))
trySubmitTx Tx era
tx
      AlonzoUtxosPredFailure era
scriptPredicateFailure <- forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era (AlonzoUtxosPredFailure era)
impScriptPredicateFailure Tx era
fixedUpTx
      NonEmpty (PredicateFailure (EraRule "LEDGER" era))
predFailure forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure AlonzoUtxosPredFailure era
scriptPredicateFailure)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
fixedUpTx
  forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Submit tx with IsValid False" forall a b. (a -> b) -> a -> b
$ do
    forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup forall a b. (a -> b) -> a -> b
$ forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$ Tx era
fixedUpTx forall a b. a -> (a -> b) -> b
& forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> IsValid
IsValid Bool
False

expectTxSuccess ::
  ( HasCallStack
  , AlonzoEraImp era
  ) =>
  Tx era -> ImpTestM era ()
expectTxSuccess :: forall era.
(HasCallStack, AlonzoEraImp era) =>
Tx era -> ImpTestM era ()
expectTxSuccess Tx era
tx
  | Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL forall a. Eq a => a -> a -> Bool
== Bool -> IsValid
IsValid Bool
True = do
      UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
      let inputs :: [TxIn (EraCrypto era)]
inputs = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL
          outputs :: [(TxIn (EraCrypto era), TxOut era)]
outputs = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => TxBody era -> UTxO era
txouts forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Inputs should be gone from UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era
-> [(TxIn (EraCrypto era), Maybe (TxOut era) -> Bool)]
-> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn (EraCrypto era)
txIn, forall a. Maybe a -> Bool
isNothing) | TxIn (EraCrypto era)
txIn <- [TxIn (EraCrypto era)]
inputs]
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Outputs should be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era
-> [(TxIn (EraCrypto era), Maybe (TxOut era) -> Bool)]
-> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn (EraCrypto era)
txIn, (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just TxOut era
txOut)) | (TxIn (EraCrypto era)
txIn, TxOut era
txOut) <- [(TxIn (EraCrypto era), TxOut era)]
outputs]
  | Bool
otherwise = do
      UTxO era
utxo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (UTxO era)
utxosUtxoL
      let inputs :: Set (TxIn (EraCrypto era))
inputs = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL
          collaterals :: Set (TxIn (EraCrypto era))
collaterals = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
collateralInputsTxBodyL
          outputs :: [(TxIn (EraCrypto era), TxOut era)]
outputs = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map (TxIn (EraCrypto era)) (TxOut era)
unUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => TxBody era -> UTxO era
txouts forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Non-collateral inputs should still be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era
-> [(TxIn (EraCrypto era), Maybe (TxOut era) -> Bool)]
-> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn (EraCrypto era)
txIn, forall a. Maybe a -> Bool
isJust) | TxIn (EraCrypto era)
txIn <- forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Set (TxIn (EraCrypto era))
inputs forall a. Ord a => Set a -> Set a -> Set a
\\ Set (TxIn (EraCrypto era))
collaterals]
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Collateral inputs should not be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era
-> [(TxIn (EraCrypto era), Maybe (TxOut era) -> Bool)]
-> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn (EraCrypto era)
txIn, forall a. Maybe a -> Bool
isNothing) | TxIn (EraCrypto era)
txIn <- forall a. Set a -> [a]
Set.toList Set (TxIn (EraCrypto era))
collaterals]
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Outputs should not be in UTxO" forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ToExpr (TxOut era)) =>
UTxO era
-> [(TxIn (EraCrypto era), Maybe (TxOut era) -> Bool)]
-> ImpTestM era ()
expectUTxOContent UTxO era
utxo [(TxIn (EraCrypto era)
txIn, forall a. Maybe a -> Bool
isNothing) | (TxIn (EraCrypto era)
txIn, TxOut era
_txOut) <- [(TxIn (EraCrypto era), TxOut era)]
outputs]