{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Invalid (spec) where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..))
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosPredFailure (CollectErrors),
  AlonzoUtxowPredFailure (..),
 )
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..), unRedeemers)
import Cardano.Ledger.BaseTypes (Mismatch (..), Network (..), StrictMaybe (..), natVersion)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Keys (asWitness, witVKeyHash)
import Cardano.Ledger.Plutus (
  Data (..),
  ExUnits (..),
  Language (..),
  hashData,
  hashPlutusScript,
  withSLanguage,
 )
import Cardano.Ledger.Shelley.LedgerState (epochStatePoolParamsL, nesEsL)
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust)
import Data.Sequence.Strict (StrictSeq ((:<|)))
import qualified Data.Set as Set
import Lens.Micro (Lens', lens, (%~), (&), (.~), (<>~), (^.))
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysSucceedsNoDatum,
  alwaysSucceedsWithDatum,
  redeemerSameAsDatum,
 )

spec ::
  forall era.
  ( AlonzoEraImp era
  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Invalid transactions" forall a b. (a -> b) -> a -> b
$ do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Phase 1 script failure" forall a b. (a -> b) -> a -> b
$ do
    -- Script will be invalid because slot 100 will be in the future
    ScriptHash
scriptHash <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
mkTimeStart SlotNo
100
    TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
    let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody 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) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [ScriptHash
scriptHash]]

  let resetAddrWits :: Tx era -> ImpTestM era (Tx era)
resetAddrWits Tx era
tx = forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits 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) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
      fixupResetAddrWits :: Tx era -> ImpM (LedgerSpec era) (Tx era)
fixupResetAddrWits = 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 => Tx era -> ImpTestM era (Tx era)
resetAddrWits
      redeemersL :: Lens' (Redeemers era) (Map.Map (PlutusPurpose AsIx era) (Data era, ExUnits))
      redeemersL :: Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
redeemersL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers @era)
      -- PlutusPurpose serialization wasn't fixed until Conway
      withPlutusPurposeRoundTripFailures :: ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
withPlutusPurposeRoundTripFailures =
        if forall era. Era era => Version
eraProtVerLow @era forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
          then forall era a. ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures
          else forall a. a -> a
id

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall era. AlonzoEraScript era => [Language]
eraLanguages @era) forall a b. (a -> b) -> a -> b
$ \Language
lang ->
    forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang forall a b. (a -> b) -> a -> b
$ \SLanguage l
slang ->
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall a. Show a => a -> String
show Language
lang) forall a b. (a -> b) -> a -> b
$ do
        let redeemerSameAsDatumHash :: ScriptHash
redeemerSameAsDatumHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
slang
            alwaysSucceedsWithDatumHash :: ScriptHash
alwaysSucceedsWithDatumHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
            alwaysSucceedsNoDatumHash :: ScriptHash
alwaysSucceedsNoDatumHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage l
slang

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingRedeemers" forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
redeemerSameAsDatumHash
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          let missingRedeemer :: PlutusPurpose AsItem era
missingRedeemer = forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. it -> AsItem ix it
AsItem TxIn
txIn
          let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody 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) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
          forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpM (LedgerSpec era) (Tx era)
fixupResetAddrWits forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 a. Monoid a => a
mempty)) forall a b. (a -> b) -> a -> b
$
            forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
              Tx era
tx
              [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                  forall era.
[(PlutusPurpose AsItem era, ScriptHash)]
-> AlonzoUtxowPredFailure era
MissingRedeemers [(PlutusPurpose AsItem era
missingRedeemer, ScriptHash
scriptHash)]
              , forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                  forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [forall era. PlutusPurpose AsItem era -> CollectError era
NoRedeemer PlutusPurpose AsItem era
missingRedeemer]
              ]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"MissingRequiredDatums" forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
          let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody 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) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
          let missingDatum :: DataHash
missingDatum = forall era. Data era -> DataHash
hashData @era (forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
3))
          forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpM (LedgerSpec era) (Tx era)
fixupResetAddrWits forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 a. Monoid a => a
mempty)) forall a b. (a -> b) -> a -> b
$
            forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
              Tx era
tx
              [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Set DataHash -> Set DataHash -> AlonzoUtxowPredFailure era
MissingRequiredDatums [DataHash
missingDatum] []]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"NotAllowedSupplementalDatums" forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
          let extraDatumHash :: DataHash
extraDatumHash = forall era. Data era -> DataHash
hashData @era (forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
30))
          let extraDatum :: Data era
extraDatum = forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
30)
          let tx :: Tx era
tx =
                forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  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) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
                  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 (Data era) -> TxDats era
TxDats (forall k a. k -> a -> Map k a
Map.singleton DataHash
extraDatumHash Data era
extraDatum)
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
            Tx era
tx
            [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Set DataHash -> Set DataHash -> AlonzoUtxowPredFailure era
NotAllowedSupplementalDatums [DataHash
extraDatumHash] []]

        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PPViewHashesDontMatch" forall a b. (a -> b) -> a -> b
$ do
          let
            testHashMismatch :: StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ()
testHashMismatch StrictMaybe ScriptIntegrityHash
badHash = do
              TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
              Tx era
goodHashTx <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody 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) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
              Tx era
badHashTx <-
                forall {era}. ShelleyEraImp era => Tx era -> ImpTestM era (Tx era)
resetAddrWits forall a b. (a -> b) -> a -> b
$ Tx era
goodHashTx 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)
scriptIntegrityHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe ScriptIntegrityHash
badHash
              let goodHash :: StrictMaybe ScriptIntegrityHash
goodHash = Tx era
goodHashTx 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) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL
              forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup forall a b. (a -> b) -> a -> b
$
                forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                  Tx era
badHashTx
                  [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                      forall era.
Mismatch 'RelEQ (StrictMaybe ScriptIntegrityHash)
-> AlonzoUtxowPredFailure era
PPViewHashesDontMatch Mismatch {mismatchSupplied :: StrictMaybe ScriptIntegrityHash
mismatchSupplied = StrictMaybe ScriptIntegrityHash
badHash, mismatchExpected :: StrictMaybe ScriptIntegrityHash
mismatchExpected = StrictMaybe ScriptIntegrityHash
goodHash}
                  ]

          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Mismatched" forall a b. (a -> b) -> a -> b
$
            StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ()
testHashMismatch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> StrictMaybe a
SJust forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Missing" forall a b. (a -> b) -> a -> b
$
            StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ()
testHashMismatch forall a. StrictMaybe a
SNothing

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"UnspendableUTxONoDatumHash" forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
redeemerSameAsDatumHash

          TxIn
txIn <- forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Produce script at a txout with a missing datahash" forall a b. (a -> b) -> a -> b
$ do
            let addr :: Addr
addr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) StakeReference
StakeRefNull
            let tx :: Tx era
tx =
                  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                    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 -> b -> s -> t
.~ [forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr forall a. Monoid a => a
mempty]
            let resetDataHash :: TxOut era -> TxOut era
resetDataHash = forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. StrictMaybe a
SNothing
            let resetTxOutDataHash :: Tx era -> Tx era
resetTxOutDataHash =
                  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
%~ ( \case
                          TxOut era
h :<| StrictSeq (TxOut era)
r -> TxOut era -> TxOut era
resetDataHash TxOut era
h forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq (TxOut era)
r
                          StrictSeq (TxOut era)
_ -> forall a. HasCallStack => String -> a
error String
"Expected non-empty outputs"
                       )

            forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int)
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup
                (Tx era -> ImpM (LedgerSpec era) (Tx era)
fixupResetAddrWits forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx era -> Tx era
resetTxOutDataHash)
                (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx)
          let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn])
          -- PlutusV3 no longer requires a spending Datum, but it should still fail since the
          -- actual script expects it
          if Language
lang forall a. Ord a => a -> a -> Bool
>= Language
PlutusV3
            then forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ Tx era
tx
            else forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set TxIn -> AlonzoUtxowPredFailure era
UnspendableUTxONoDatumHash [TxIn
txIn]]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"No ExtraRedeemers on same script certificates" forall a b. (a -> b) -> a -> b
$ do
          Positive Int
n <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
          forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> ImpTestM era ()
registerPool
          Map (KeyHash 'StakePool) PoolParams
pools <- 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) (Map (KeyHash 'StakePool) PoolParams)
epochStatePoolParamsL
          KeyHash 'StakePool
poolId <- forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map (KeyHash 'StakePool) PoolParams
pools
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsNoDatumHash
              cred :: Credential 'Staking
cred = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash
              certs :: StrictSeq (TxCert era)
certs =
                [ forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
mkRegTxCert Credential 'Staking
cred
                , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
mkDelegStakeTxCert Credential 'Staking
cred KeyHash 'StakePool
poolId
                , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
mkUnRegTxCert Credential 'Staking
cred
                ]
          Tx era
tx <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictSeq (TxCert era)
certs)
          let redeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
redeemers = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
redeemersL
          forall k a. Map k a -> [k]
Map.keys Map (PlutusPurpose AsIx era) (Data era, ExUnits)
redeemers
            forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` [ forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxCert era) -> PlutusPurpose f era
mkCertifyingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
1
                       , forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxCert era) -> PlutusPurpose f era
mkCertifyingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
2
                       ]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Missing phase-2 script witness" forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsWithDatumHash
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody 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) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
              dropScriptWitnesses :: Tx era -> ImpM (LedgerSpec era) (Tx era)
dropScriptWitnesses =
                forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty)
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 a. Monoid a => a
mempty)
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 a. Monoid a => a
mempty)
              resetScriptHash :: Tx era -> ImpM (LedgerSpec era) (Tx era)
resetScriptHash = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
scriptIntegrityHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. StrictMaybe a
SNothing)
          forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpM (LedgerSpec era) (Tx era)
dropScriptWitnesses forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
resetScriptHash 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)
resetAddrWits) forall a b. (a -> b) -> a -> b
$
            forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
MissingScriptWitnessesUTXOW [ScriptHash
scriptHash]]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Redeemer with incorrect purpose" forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsWithDatumHash
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          let tx :: Tx era
tx =
                forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  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) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
                  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 b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
redeemersL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (PlutusPurpose AsIx era) (Data era, ExUnits)
mintingRedeemers
              mintingRedeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
mintingRedeemers = forall k a. k -> a -> Map k a
Map.singleton (forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
mkMintingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
0) (forall era. Era era => Data -> Data era
Data forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
32, Natural -> Natural -> ExUnits
ExUnits Natural
0 Natural
0)
              isSpender :: PlutusPurpose AsIx era -> Bool
isSpender = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era (f :: * -> * -> *).
AlonzoEraScript era =>
PlutusPurpose f era -> Maybe (f Word32 TxIn)
toSpendingPurpose @era @AsIx
              removeSpenders :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
removeSpenders = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusPurpose AsIx era -> Bool
isSpender)
              dropSpendingRedeemers :: Tx era -> ImpM (LedgerSpec era) (Tx era)
dropSpendingRedeemers = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
redeemersL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
removeSpenders)
          forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpM (LedgerSpec era) (Tx era)
dropSpendingRedeemers 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 => Tx era -> ImpTestM era (Tx era)
resetAddrWits) forall a b. (a -> b) -> a -> b
$
            ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
withPlutusPurposeRoundTripFailures forall a b. (a -> b) -> a -> b
$
              forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                Tx era
tx
                [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                    forall era. [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
ExtraRedeemers [forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
mkMintingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
0]
                , forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                    forall era.
[(PlutusPurpose AsItem era, ScriptHash)]
-> AlonzoUtxowPredFailure era
MissingRedeemers [(forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. it -> AsItem ix it
AsItem TxIn
txIn, ScriptHash
scriptHash)]
                , forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                    forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [forall era. PlutusPurpose AsItem era -> CollectError era
NoRedeemer forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. it -> AsItem ix it
AsItem TxIn
txIn]
                ]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Missing witness for collateral input" forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsWithDatumHash
          TxIn
scriptInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          (KeyHash Any
collateralHash, Addr
collateralAddr) <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r, Addr)
freshKeyAddr
          TxIn
collateralInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
collateralAddr forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
3_000_000
          let
            tx :: Tx era
tx =
              forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                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) (Set TxIn)
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn
scriptInput]
                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)
collateralInputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn
collateralInput]
            isOtherWitness :: WitVKey 'Witness -> Bool
isOtherWitness WitVKey 'Witness
wit = forall (kr :: KeyRole). WitVKey kr -> KeyHash 'Witness
witVKeyHash WitVKey 'Witness
wit forall a. Eq a => a -> a -> Bool
/= forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash Any
collateralHash
            dropCollateralWitness :: Tx era -> Tx era
dropCollateralWitness = 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) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. (a -> Bool) -> Set a -> Set a
Set.filter WitVKey 'Witness -> Bool
isOtherWitness
          forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> Tx era
dropCollateralWitness) forall a b. (a -> b) -> a -> b
$
            forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
              Tx era
tx
              [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set (KeyHash 'Witness) -> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash Any
collateralHash]]

        -- Post-Alonzo eras produce additional post-Alonzo predicate failures that we can't include here
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Language
lang forall a. Ord a => a -> a -> Bool
> forall era. AlonzoEraScript era => Language
eraMaxLanguage @AlonzoEra) forall a b. (a -> b) -> a -> b
$ do
          forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Extra Redeemer" forall a b. (a -> b) -> a -> b
$ do
            let
              testPurpose :: PlutusPurpose AsIx era -> ImpM (LedgerSpec era) ()
testPurpose PlutusPurpose AsIx era
purpose = do
                TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
                let redeemer :: (Data era, ExUnits)
redeemer = (forall era. Era era => Data -> Data era
Data forall a b. (a -> b) -> a -> b
$ Integer -> Data
P.I Integer
442, Natural -> Natural -> ExUnits
ExUnits Natural
443 Natural
444) -- Needs to be unique
                    tx :: Tx era
tx =
                      forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                        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) (Set TxIn)
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn
txIn]
                        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 b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
redeemersL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall k a. k -> a -> Map k a
Map.singleton PlutusPurpose AsIx era
purpose (Data era, ExUnits)
redeemer
                Tx era
txFixed <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx Tx era
tx
                -- The `Ix` of the redeemer may have been changed by `fixupRedeemerIndices`
                let fixedRedeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
fixedRedeemers = Tx era
txFixed 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
redeemersL
                    extraRedeemers :: [PlutusPurpose AsIx era]
extraRedeemers = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
== (Data era, ExUnits)
redeemer) Map (PlutusPurpose AsIx era) (Data era, ExUnits)
fixedRedeemers
                forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup forall a b. (a -> b) -> a -> b
$
                  ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
withPlutusPurposeRoundTripFailures forall a b. (a -> b) -> a -> b
$
                    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                      Tx era
txFixed
                      [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
ExtraRedeemers [PlutusPurpose AsIx era]
extraRedeemers]

            forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Minting" forall a b. (a -> b) -> a -> b
$
              PlutusPurpose AsIx era -> ImpM (LedgerSpec era) ()
testPurpose (forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
mkMintingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
2)
            forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Spending" forall a b. (a -> b) -> a -> b
$
              PlutusPurpose AsIx era -> ImpM (LedgerSpec era) ()
testPurpose (forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. ix -> AsIx ix it
AsIx Word32
99)

            forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Multiple equal plutus-locked certs" forall a b. (a -> b) -> a -> b
$ do
              let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsWithDatumHash
              Positive Int
n <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
              forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
ShelleyEraImp era =>
KeyHash 'StakePool -> ImpTestM era ()
registerPool
              Map (KeyHash 'StakePool) PoolParams
pools <- 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) (Map (KeyHash 'StakePool) PoolParams)
epochStatePoolParamsL
              KeyHash 'StakePool
poolId <- forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map (KeyHash 'StakePool) PoolParams
pools
              let cred :: Credential 'Staking
cred = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash
                  certs :: StrictSeq (TxCert era)
certs =
                    [ forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> TxCert era
mkRegTxCert Credential 'Staking
cred --               0: Doesn't require a redeemer
                    , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
mkDelegStakeTxCert Credential 'Staking
cred KeyHash 'StakePool
poolId -- 1: Needs a redeemer
                    , forall era.
ShelleyEraTxCert era =>
Credential 'Staking -> KeyHash 'StakePool -> TxCert era
mkDelegStakeTxCert Credential 'Staking
cred KeyHash 'StakePool
poolId -- 2: Duplicate, ignored, no redeemer needed
                    ]
                  redeemer :: (Data era, ExUnits)
redeemer = (forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
32), Natural -> Natural -> ExUnits
ExUnits Natural
5000 Natural
1_000_000)
                  redeemers :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
redeemers = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxCert era) -> PlutusPurpose f era
mkCertifyingPurpose (forall ix it. ix -> AsIx ix it
AsIx Word32
i), (Data era, ExUnits)
redeemer) | Word32
i <- [Word32
1 .. Word32
2]]
                  tx :: Tx era
tx =
                    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                      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 (TxCert era))
certsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ StrictSeq (TxCert era)
certs
                      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 b c a. (b -> c) -> (a -> b) -> a -> c
. Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
redeemersL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ Map (PlutusPurpose AsIx era) (Data era, ExUnits)
redeemers
              ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
withPlutusPurposeRoundTripFailures forall a b. (a -> b) -> a -> b
$
                forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                  Tx era
tx
                  [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
ExtraRedeemers [forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxCert era) -> PlutusPurpose f era
mkCertifyingPurpose (forall ix it. ix -> AsIx ix it
AsIx Word32
2)]]