{-# 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.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 (TxDats (..), unRedeemersL)
import Cardano.Ledger.BaseTypes (Mismatch (..), 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 ((%~), (&), (.~), (<>~), (^.))
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 = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Invalid transactions" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Phase 1 script failure" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Script will be invalid because slot 100 will be in the future
    ScriptHash
scriptHash <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpTestM era ScriptHash)
-> NativeScript era -> ImpTestM era ScriptHash
forall a b. (a -> b) -> a -> b
$ SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
mkTimeStart SlotNo
100
    TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
    let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
    Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]]

  let resetAddrWits :: Tx era -> ImpTestM era (Tx era)
resetAddrWits Tx era
tx = Tx era -> ImpTestM era (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits (Tx era -> ImpTestM era (Tx era))
-> Tx era -> ImpTestM era (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
tx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
    -> TxWits era -> Identity (TxWits era))
-> (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> Tx era -> Identity (Tx era))
-> Set (WitVKey 'Witness) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []
      fixupResetAddrWits :: Tx era -> ImpM (LedgerSpec era) (Tx era)
fixupResetAddrWits = Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
Tx era -> ImpTestM era (Tx era)
resetAddrWits
      -- PlutusPurpose serialization wasn't fixed until Conway
      withPlutusPurposeRoundTripFailures :: ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
withPlutusPurposeRoundTripFailures =
        if forall era. Era era => Version
eraProtVerLow @era Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
          then ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a. ImpTestM era a -> ImpTestM era a
withCborRoundTripFailures
          else ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a. a -> a
id

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

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

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

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

        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PPViewHashesDontMatch" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          let
            testHashMismatch :: StrictMaybe ScriptIntegrityHash -> ImpM (LedgerSpec era) ()
testHashMismatch StrictMaybe ScriptIntegrityHash
badHash = do
              TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
redeemerSameAsDatumHash
              Tx era
goodHashTx <- Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
              Tx era
badHashTx <-
                Tx era -> ImpM (LedgerSpec era) (Tx era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
Tx era -> ImpTestM era (Tx era)
resetAddrWits (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ Tx era
goodHashTx Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody era -> Identity (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe ScriptIntegrityHash -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe ScriptIntegrityHash
badHash
              let goodHash :: StrictMaybe ScriptIntegrityHash
goodHash = Tx era
goodHashTx Tx era
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx era)
     (StrictMaybe ScriptIntegrityHash)
-> StrictMaybe ScriptIntegrityHash
forall s a. s -> Getting a s a -> a
^. (TxBody era
 -> Const (StrictMaybe ScriptIntegrityHash) (TxBody era))
-> Tx era -> Const (StrictMaybe ScriptIntegrityHash) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era
  -> Const (StrictMaybe ScriptIntegrityHash) (TxBody era))
 -> Tx era -> Const (StrictMaybe ScriptIntegrityHash) (Tx era))
-> ((StrictMaybe ScriptIntegrityHash
     -> Const
          (StrictMaybe ScriptIntegrityHash)
          (StrictMaybe ScriptIntegrityHash))
    -> TxBody era
    -> Const (StrictMaybe ScriptIntegrityHash) (TxBody era))
-> Getting
     (StrictMaybe ScriptIntegrityHash)
     (Tx era)
     (StrictMaybe ScriptIntegrityHash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Const
      (StrictMaybe ScriptIntegrityHash)
      (StrictMaybe ScriptIntegrityHash))
-> TxBody era
-> Const (StrictMaybe ScriptIntegrityHash) (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL
              ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                  Tx era
badHashTx
                  [ AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
                      Mismatch 'RelEQ (StrictMaybe ScriptIntegrityHash)
-> AlonzoUtxowPredFailure era
forall era.
Mismatch 'RelEQ (StrictMaybe ScriptIntegrityHash)
-> AlonzoUtxowPredFailure era
PPViewHashesDontMatch Mismatch {mismatchSupplied :: StrictMaybe ScriptIntegrityHash
mismatchSupplied = StrictMaybe ScriptIntegrityHash
badHash, mismatchExpected :: StrictMaybe ScriptIntegrityHash
mismatchExpected = StrictMaybe ScriptIntegrityHash
goodHash}
                  ]

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

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"UnspendableUTxONoDatumHash" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- String -> ImpTestM era TxIn -> ImpTestM 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" (ImpTestM era TxIn -> ImpTestM era TxIn)
-> ImpTestM era TxIn -> ImpTestM era TxIn
forall a b. (a -> b) -> a -> b
$ do
            let scriptHash :: ScriptHash
scriptHash = ScriptHash
redeemerSameAsDatumHash
            let addr :: Addr
addr = ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
scriptHash StakeReference
StakeRefNull
            let tx :: Tx era
tx =
                  TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
                    Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty]
            let resetDataHash :: TxOut era -> TxOut era
resetDataHash = (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
 -> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe DataHash
forall a. StrictMaybe a
SNothing
            let resetTxOutDataHash :: Tx era -> Tx era
resetTxOutDataHash =
                  (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
    -> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
                    ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> Tx era -> Identity (Tx era))
-> (StrictSeq (TxOut era) -> StrictSeq (TxOut era))
-> Tx era
-> Tx era
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 TxOut era -> StrictSeq (TxOut era) -> StrictSeq (TxOut era)
forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq (TxOut era)
r
                           StrictSeq (TxOut era)
_ -> String -> StrictSeq (TxOut era)
forall a. HasCallStack => String -> a
error String
"Expected non-empty outputs"
                       )

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

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

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Missing phase-2 script witness" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsWithDatumHash
          TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
              dropScriptWitnesses :: Tx era -> ImpM (LedgerSpec era) (Tx era)
dropScriptWitnesses =
                Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> Tx era) -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map ScriptHash (Script era)
     -> Identity (Map ScriptHash (Script era)))
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era)
    -> Identity (Map ScriptHash (Script era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
 -> Identity (Map ScriptHash (Script era)))
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL ((Map ScriptHash (Script era)
  -> Identity (Map ScriptHash (Script era)))
 -> Tx era -> Identity (Tx era))
-> Map ScriptHash (Script era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Script era)
forall a. Monoid a => a
mempty)
                  (Tx era -> Tx era) -> (Tx era -> Tx era) -> Tx era -> Tx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((TxDats era -> Identity (TxDats era))
    -> TxWits era -> Identity (TxWits era))
-> (TxDats era -> Identity (TxDats era))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxDats era -> Identity (TxDats era))
-> TxWits era -> Identity (TxWits era)
forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
Lens' (TxWits era) (TxDats era)
datsTxWitsL ((TxDats era -> Identity (TxDats era))
 -> Tx era -> Identity (Tx era))
-> TxDats era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxDats era
forall a. Monoid a => a
mempty)
                  (Tx era -> Tx era) -> (Tx era -> Tx era) -> Tx era -> Tx era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Redeemers era -> Identity (Redeemers era))
    -> TxWits era -> Identity (TxWits era))
-> (Redeemers era -> Identity (Redeemers era))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> Tx era -> Identity (Tx era))
-> Redeemers era -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Redeemers era
forall a. Monoid a => a
mempty)
              resetScriptHash :: Tx era -> ImpM (LedgerSpec era) (Tx era)
resetScriptHash = Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> Tx era) -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe ScriptIntegrityHash
     -> Identity (StrictMaybe ScriptIntegrityHash))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe ScriptIntegrityHash
    -> Identity (StrictMaybe ScriptIntegrityHash))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe ScriptIntegrityHash
 -> Identity (StrictMaybe ScriptIntegrityHash))
-> TxBody era -> Identity (TxBody era)
forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
Lens' (TxBody era) (StrictMaybe ScriptIntegrityHash)
scriptIntegrityHashTxBodyL ((StrictMaybe ScriptIntegrityHash
  -> Identity (StrictMaybe ScriptIntegrityHash))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe ScriptIntegrityHash -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe ScriptIntegrityHash
forall a. StrictMaybe a
SNothing)
          (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpM (LedgerSpec era) (Tx era)
dropScriptWitnesses (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
resetScriptHash (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
Tx era -> ImpTestM era (Tx era)
resetAddrWits) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
MissingScriptWitnessesUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Redeemer with incorrect purpose" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsWithDatumHash
          TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
scriptHash
          let tx :: Tx era
tx =
                TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn]
                  Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx era -> Identity (Tx era))
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Tx era
-> Tx era
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 = PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. k -> a -> Map k a
Map.singleton (AsIx Word32 PolicyID -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 PolicyID -> PlutusPurpose f era
mkMintingPurpose (AsIx Word32 PolicyID -> PlutusPurpose AsIx era)
-> AsIx Word32 PolicyID -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
0) (Data -> Data era
forall era. Era era => Data -> Data era
Data (Data -> Data era) -> Data -> Data era
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 = Maybe (AsIx Word32 TxIn) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (AsIx Word32 TxIn) -> Bool)
-> (PlutusPurpose AsIx era -> Maybe (AsIx Word32 TxIn))
-> PlutusPurpose AsIx era
-> Bool
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 = (PlutusPurpose AsIx era -> (Data era, ExUnits) -> Bool)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Bool -> (Data era, ExUnits) -> Bool
forall a b. a -> b -> a
const (Bool -> (Data era, ExUnits) -> Bool)
-> (PlutusPurpose AsIx era -> Bool)
-> PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool)
-> (PlutusPurpose AsIx era -> Bool)
-> PlutusPurpose AsIx era
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusPurpose AsIx era -> Bool
isSpender)
              dropSpendingRedeemers :: Tx era -> ImpM (LedgerSpec era) (Tx era)
dropSpendingRedeemers = Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> Tx era) -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx era -> Identity (Tx era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx era
-> Tx era
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)
          (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (Tx era -> ImpM (LedgerSpec era) (Tx era)
dropSpendingRedeemers (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. AlonzoEraImp era => Tx era -> ImpTestM era (Tx era)
fixupPPHash (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
 Eq (Event (EraRule "LEDGER" era)),
 NFData (Event (EraRule "TICK" era)),
 NFData (Event (EraRule "LEDGER" era)),
 Typeable (Event (EraRule "TICK" era)),
 Typeable (Event (EraRule "LEDGER" era)),
 ToExpr (Event (EraRule "TICK" era)),
 ToExpr (Event (EraRule "LEDGER" era))) =>
Tx era -> ImpTestM era (Tx era)
resetAddrWits) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
withPlutusPurposeRoundTripFailures (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
              Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                Tx era
tx
                [ AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
                    [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
forall era. [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
ExtraRedeemers [AsIx Word32 PolicyID -> PlutusPurpose AsIx era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 PolicyID -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 PolicyID -> PlutusPurpose f era
mkMintingPurpose (AsIx Word32 PolicyID -> PlutusPurpose AsIx era)
-> AsIx Word32 PolicyID -> PlutusPurpose AsIx era
forall a b. (a -> b) -> a -> b
$ Word32 -> AsIx Word32 PolicyID
forall ix it. ix -> AsIx ix it
AsIx Word32
0]
                , AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
                    [(PlutusPurpose AsItem era, ScriptHash)]
-> AlonzoUtxowPredFailure era
forall era.
[(PlutusPurpose AsItem era, ScriptHash)]
-> AlonzoUtxowPredFailure era
MissingRedeemers [(AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (AsItem Word32 TxIn -> PlutusPurpose AsItem era)
-> AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall a b. (a -> b) -> a -> b
$ TxIn -> AsItem Word32 TxIn
forall ix it. it -> AsItem ix it
AsItem TxIn
txIn, ScriptHash
scriptHash)]
                , AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
                    [CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [PlutusPurpose AsItem era -> CollectError era
forall era. PlutusPurpose AsItem era -> CollectError era
NoRedeemer (PlutusPurpose AsItem era -> CollectError era)
-> PlutusPurpose AsItem era -> CollectError era
forall a b. (a -> b) -> a -> b
$ AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall era (f :: * -> * -> *).
AlonzoEraScript era =>
f Word32 TxIn -> PlutusPurpose f era
forall (f :: * -> * -> *). f Word32 TxIn -> PlutusPurpose f era
mkSpendingPurpose (AsItem Word32 TxIn -> PlutusPurpose AsItem era)
-> AsItem Word32 TxIn -> PlutusPurpose AsItem era
forall a b. (a -> b) -> a -> b
$ TxIn -> AsItem Word32 TxIn
forall ix it. it -> AsItem ix it
AsItem TxIn
txIn]
                ]

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

        -- Post-Alonzo eras produce additional post-Alonzo predicate failures that we can't include here
        Bool
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Language
lang Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
> forall era. AlonzoEraScript era => Language
eraMaxLanguage @AlonzoEra) (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Extra Redeemer" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
            let
              testPurpose :: PlutusPurpose AsIx era -> ImpM (LedgerSpec era) ()
testPurpose PlutusPurpose AsIx era
purpose = do
                TxIn
txIn <- ScriptHash -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
                let redeemer :: (Data era, ExUnits)
redeemer = (Data -> Data era
forall era. Era era => Data -> Data era
Data (Data -> Data era) -> Data -> Data era
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 =
                      TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
                        Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Item (Set TxIn)
TxIn
txIn]
                        Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx era -> Identity (Tx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era -> Identity (TxWits era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era -> Identity (Redeemers era))
-> TxWits era -> Identity (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era -> Identity (Redeemers era))
 -> TxWits era -> Identity (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era -> Identity (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era -> Identity (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
  -> Identity (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
 -> Tx era -> Identity (Tx era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx era
purpose (Data era, ExUnits)
redeemer
                Tx era
txFixed <- Tx era -> ImpM (LedgerSpec era) (Tx era)
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 Tx era
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx era)
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall s a. s -> Getting a s a -> a
^. (TxWits era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> Tx era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
 -> Tx era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Tx era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Const
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> TxWits era
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> Getting
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
     (Tx era)
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Redeemers era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
-> TxWits era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era)
forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL ((Redeemers era
  -> Const
       (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
 -> TxWits era
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era))
-> ((Map (PlutusPurpose AsIx era) (Data era, ExUnits)
     -> Const
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
          (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
    -> Redeemers era
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era))
-> (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
    -> Const
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
         (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> TxWits era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> Const
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
      (Map (PlutusPurpose AsIx era) (Data era, ExUnits)))
-> Redeemers era
-> Const
     (Map (PlutusPurpose AsIx era) (Data era, ExUnits)) (Redeemers era)
forall era.
AlonzoEraScript era =>
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
Lens'
  (Redeemers era) (Map (PlutusPurpose AsIx era) (Data era, ExUnits))
unRedeemersL
                    extraRedeemers :: [PlutusPurpose AsIx era]
extraRedeemers = Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> [PlutusPurpose AsIx era]
forall k a. Map k a -> [k]
Map.keys (Map (PlutusPurpose AsIx era) (Data era, ExUnits)
 -> [PlutusPurpose AsIx era])
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> [PlutusPurpose AsIx era]
forall a b. (a -> b) -> a -> b
$ ((Data era, ExUnits) -> Bool)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
-> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((Data era, ExUnits) -> (Data era, ExUnits) -> Bool
forall a. Eq a => a -> a -> Bool
== (Data era, ExUnits)
redeemer) Map (PlutusPurpose AsIx era) (Data era, ExUnits)
fixedRedeemers
                ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                  ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
withPlutusPurposeRoundTripFailures (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                    Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                      Tx era
txFixed
                      [AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
forall era. [PlutusPurpose AsIx era] -> AlonzoUtxowPredFailure era
ExtraRedeemers [PlutusPurpose AsIx era]
extraRedeemers]

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

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