{-# 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 (Alonzo)
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 (EraCrypto era)
scriptHash <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era (ScriptHash (EraCrypto era))
impAddNativeScript forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
mkTimeStart SlotNo
100
    TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)) -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [ScriptHash (EraCrypto era)
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 (EraCrypto era)))
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 (EraCrypto era)
redeemerSameAsDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
slang
            alwaysSucceedsWithDatumHash :: ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsWithDatum SLanguage l
slang
            alwaysSucceedsNoDatumHash :: ScriptHash (EraCrypto era)
alwaysSucceedsNoDatumHash = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
scriptHash = ScriptHash (EraCrypto era)
redeemerSameAsDatumHash
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
scriptHash
          let missingRedeemer :: PlutusPurpose AsItem era
missingRedeemer = forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxIn (EraCrypto era)) -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. it -> AsItem ix it
AsItem TxIn (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era))]
-> AlonzoUtxowPredFailure era
MissingRedeemers [(PlutusPurpose AsItem era
missingRedeemer, ScriptHash (EraCrypto era)
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 (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
txIn]
          let missingDatum :: DataHash (EraCrypto era)
missingDatum = forall era. Era era => Data era -> DataHash (EraCrypto era)
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 (EraCrypto era))
-> Set (DataHash (EraCrypto era)) -> AlonzoUtxowPredFailure era
MissingRequiredDatums [DataHash (EraCrypto era)
missingDatum] []]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"NotAllowedSupplementalDatums" forall a b. (a -> b) -> a -> b
$ do
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
redeemerSameAsDatumHash
          let extraDatumHash :: DataHash (EraCrypto era)
extraDatumHash = forall era. Era era => Data era -> DataHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)) (Data era) -> TxDats era
TxDats (forall k a. k -> a -> Map k a
Map.singleton DataHash (EraCrypto era)
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 (EraCrypto era))
-> Set (DataHash (EraCrypto era)) -> AlonzoUtxowPredFailure era
NotAllowedSupplementalDatums [DataHash (EraCrypto era)
extraDatumHash] []]

        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PPViewHashesDontMatch" forall a b. (a -> b) -> a -> b
$ do
          let
            testHashMismatch :: StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> ImpM (LedgerSpec era) ()
testHashMismatch StrictMaybe (ScriptIntegrityHash (EraCrypto era))
badHash = do
              TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)))
scriptIntegrityHashTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (ScriptIntegrityHash (EraCrypto era))
badHash
              let goodHash :: StrictMaybe (ScriptIntegrityHash (EraCrypto era))
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 (EraCrypto era)))
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 (EraCrypto era)))
-> AlonzoUtxowPredFailure era
PPViewHashesDontMatch Mismatch {mismatchSupplied :: StrictMaybe (ScriptIntegrityHash (EraCrypto era))
mismatchSupplied = StrictMaybe (ScriptIntegrityHash (EraCrypto era))
badHash, mismatchExpected :: StrictMaybe (ScriptIntegrityHash (EraCrypto era))
mismatchExpected = StrictMaybe (ScriptIntegrityHash (EraCrypto era))
goodHash}
                  ]

          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Mismatched" forall a b. (a -> b) -> a -> b
$
            StrictMaybe (ScriptIntegrityHash (EraCrypto era))
-> 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 (EraCrypto era))
-> 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 (EraCrypto era)
scriptHash = ScriptHash (EraCrypto era)
redeemerSameAsDatumHash

          TxIn (EraCrypto era)
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 (EraCrypto era)
addr = forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
scriptHash) forall c. StakeReference c
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 (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
addr forall a. Monoid a => a
mempty]
            let resetDataHash :: TxOut era -> TxOut era
resetDataHash = 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. 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 (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)) -> AlonzoUtxowPredFailure era
UnspendableUTxONoDatumHash [TxIn (EraCrypto era)
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 c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool
          Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
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 (EraCrypto era)) (PoolParams (EraCrypto era)))
epochStatePoolParamsL
          KeyHash 'StakePool (EraCrypto era)
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 (EraCrypto era)) (PoolParams (EraCrypto era))
pools
          let scriptHash :: ScriptHash (EraCrypto era)
scriptHash = ScriptHash (EraCrypto era)
alwaysSucceedsNoDatumHash
              cred :: Credential 'Staking (EraCrypto era)
cred = forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
scriptHash
              certs :: StrictSeq (TxCert era)
certs =
                [ forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
mkRegTxCert Credential 'Staking (EraCrypto era)
cred
                , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
mkDelegStakeTxCert Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolId
                , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
mkUnRegTxCert Credential 'Staking (EraCrypto era)
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 (EraCrypto era)
scriptHash = ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)) (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 (EraCrypto era)))
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 (EraCrypto era)) -> ShelleyUtxowPredFailure era
MissingScriptWitnessesUTXOW [ScriptHash (EraCrypto era)
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 (EraCrypto era)
scriptHash = ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash
          TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)) -> 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 (EraCrypto era)))
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 (EraCrypto era)) -> 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 (EraCrypto era))]
-> AlonzoUtxowPredFailure era
MissingRedeemers [(forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 (TxIn (EraCrypto era)) -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. it -> AsItem ix it
AsItem TxIn (EraCrypto era)
txIn, ScriptHash (EraCrypto era)
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 (EraCrypto era)) -> PlutusPurpose f era
mkSpendingPurpose forall a b. (a -> b) -> a -> b
$ forall ix it. it -> AsItem ix it
AsItem TxIn (EraCrypto era)
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 (EraCrypto era)
scriptHash = ScriptHash (EraCrypto era)
alwaysSucceedsWithDatumHash
          TxIn (EraCrypto era)
scriptInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
scriptHash
          (KeyHash Any (EraCrypto era)
collateralHash, Addr (EraCrypto era)
collateralAddr) <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c, Addr c)
freshKeyAddr
          TxIn (EraCrypto era)
collateralInput <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo Addr (EraCrypto era)
collateralAddr forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_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 (EraCrypto era)))
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
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 (EraCrypto era)))
collateralInputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
collateralInput]
            isOtherWitness :: WitVKey 'Witness (EraCrypto era) -> Bool
isOtherWitness WitVKey 'Witness (EraCrypto era)
wit = forall (kr :: KeyRole) c. WitVKey kr c -> KeyHash 'Witness c
witVKeyHash WitVKey 'Witness (EraCrypto era)
wit forall a. Eq a => a -> a -> Bool
/= forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash Any (EraCrypto era)
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 (EraCrypto era)))
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 (EraCrypto era) -> 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 (EraCrypto era))
-> ShelleyUtxowPredFailure era
MissingVKeyWitnessesUTXOW [forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash Any (EraCrypto era)
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 @Alonzo) 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 (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [TxIn (EraCrypto era)
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 (EraCrypto era)) -> 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 (EraCrypto era)) -> 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 (EraCrypto era)
scriptHash = ScriptHash (EraCrypto era)
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 c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool
              Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
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 (EraCrypto era)) (PoolParams (EraCrypto era)))
epochStatePoolParamsL
              KeyHash 'StakePool (EraCrypto era)
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 (EraCrypto era)) (PoolParams (EraCrypto era))
pools
              let cred :: Credential 'Staking (EraCrypto era)
cred = forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
scriptHash
                  certs :: StrictSeq (TxCert era)
certs =
                    [ forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
mkRegTxCert Credential 'Staking (EraCrypto era)
cred --               0: Doesn't require a redeemer
                    , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
mkDelegStakeTxCert Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolId -- 1: Needs a redeemer
                    , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
mkDelegStakeTxCert Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
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
5000)
                  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)]]