{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Dijkstra.Imp.UtxowSpec (spec) where

import Cardano.Ledger.Conway.Rules
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Scripts
import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Scripts
import Lens.Micro
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Dijkstra.ImpTest

spec ::
  forall era.
  DijkstraEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp 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
"RequireGuard native scripts" (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
"Spending inputs locked by script requiring a keyhash guard" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      Credential 'Guard
guardKeyHash <- KeyHash 'Guard -> Credential 'Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Guard -> Credential 'Guard)
-> ImpM (LedgerSpec era) (KeyHash 'Guard)
-> ImpM (LedgerSpec era) (Credential 'Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      ScriptHash
scriptHash <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (Credential 'Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential 'Guard -> NativeScript era
RequireGuard Credential 'Guard
guardKeyHash)
      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 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])
      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 [ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ConwayUtxowPredFailure era
forall era. Set ScriptHash -> ConwayUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]]
      Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec 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
& (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))
-> ((OSet (Credential 'Guard)
     -> Identity (OSet (Credential 'Guard)))
    -> TxBody era -> Identity (TxBody era))
-> (OSet (Credential 'Guard)
    -> Identity (OSet (Credential 'Guard)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
-> TxBody era -> Identity (TxBody era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody era) (OSet (Credential 'Guard))
Lens' (TxBody era) (OSet (Credential 'Guard))
guardsTxBodyL ((OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
 -> Tx era -> Identity (Tx era))
-> OSet (Credential 'Guard) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (Credential 'Guard))
Credential 'Guard
guardKeyHash]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A native script required as guard needs to be witnessed " (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 guardScript :: NativeScript era
guardScript = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf []
      let guardScriptHash :: ScriptHash
guardScriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScript
      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
$ Credential 'Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential 'Guard -> NativeScript era
RequireGuard (ScriptHash -> Credential 'Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash)
      Tx era
tx <- ScriptHash -> ImpTestM era (Tx era)
forall era. MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx ScriptHash
scriptHash
      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 [ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ConwayUtxowPredFailure era
forall era. Set ScriptHash -> ConwayUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]]

      let txWithGuards :: Tx era
txWithGuards = Tx era
tx 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))
-> ((OSet (Credential 'Guard)
     -> Identity (OSet (Credential 'Guard)))
    -> TxBody era -> Identity (TxBody era))
-> (OSet (Credential 'Guard)
    -> Identity (OSet (Credential 'Guard)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
-> TxBody era -> Identity (TxBody era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody era) (OSet (Credential 'Guard))
Lens' (TxBody era) (OSet (Credential 'Guard))
guardsTxBodyL ((OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
 -> Tx era -> Identity (Tx era))
-> OSet (Credential 'Guard) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ScriptHash -> Credential 'Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash]
      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
txWithGuards [ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ConwayUtxowPredFailure era
forall era. Set ScriptHash -> ConwayUtxowPredFailure era
MissingScriptWitnessesUTXOW [Item (Set ScriptHash)
ScriptHash
guardScriptHash]]
      Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ Tx era
txWithGuards 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 ScriptHash (Script era) -> Identity [Script era])
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era) -> Identity [Script era])
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era) -> Identity [Script era])
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
hashScriptTxWitsL ((Map ScriptHash (Script era) -> Identity [Script era])
 -> Tx era -> Identity (Tx era))
-> [Script era] -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScript]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A failing native script required as guard results in a predicate 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
      let guardScriptFailing :: NativeScript era
guardScriptFailing = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf []
      let guardScriptHash :: ScriptHash
guardScriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScriptFailing
      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
$ Credential 'Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential 'Guard -> NativeScript era
RequireGuard (ScriptHash -> Credential 'Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash)
      Coin
expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
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))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      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 (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 s t a b. ASetter s t a b -> b -> s -> t
.~ [StakeCredential -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
StakeCredential -> Coin -> TxCert era
RegDepositTxCert (ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) Coin
expectedDeposit]
              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))
-> ((OSet (Credential 'Guard)
     -> Identity (OSet (Credential 'Guard)))
    -> TxBody era -> Identity (TxBody era))
-> (OSet (Credential 'Guard)
    -> Identity (OSet (Credential 'Guard)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
-> TxBody era -> Identity (TxBody era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody era) (OSet (Credential 'Guard))
Lens' (TxBody era) (OSet (Credential 'Guard))
guardsTxBodyL ((OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
 -> Tx era -> Identity (Tx era))
-> OSet (Credential 'Guard) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ScriptHash -> Credential 'Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash]
              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 ScriptHash (Script era) -> Identity [Script era])
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era) -> Identity [Script era])
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era) -> Identity [Script era])
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
hashScriptTxWitsL ((Map ScriptHash (Script era) -> Identity [Script era])
 -> Tx era -> Identity (Tx era))
-> [Script era] -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScriptFailing]
      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 [ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ConwayUtxowPredFailure era
forall era. Set ScriptHash -> ConwayUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
guardScriptHash]]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A redundant guard is ignored" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      Credential 'Guard
guardKeyHash <- KeyHash 'Guard -> Credential 'Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Guard -> Credential 'Guard)
-> ImpM (LedgerSpec era) (KeyHash 'Guard)
-> ImpM (LedgerSpec era) (Credential 'Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      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))
-> ((OSet (Credential 'Guard)
     -> Identity (OSet (Credential 'Guard)))
    -> TxBody era -> Identity (TxBody era))
-> (OSet (Credential 'Guard)
    -> Identity (OSet (Credential 'Guard)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
-> TxBody era -> Identity (TxBody era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody era) (OSet (Credential 'Guard))
Lens' (TxBody era) (OSet (Credential 'Guard))
guardsTxBodyL ((OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
 -> Tx era -> Identity (Tx era))
-> OSet (Credential 'Guard) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (Credential 'Guard))
Credential 'Guard
guardKeyHash]
      Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Nested RequiredGuard scripts" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      Credential 'Guard
guardKeyHash <- KeyHash 'Guard -> Credential 'Guard
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Guard -> Credential 'Guard)
-> ImpM (LedgerSpec era) (KeyHash 'Guard)
-> ImpM (LedgerSpec era) (Credential 'Guard)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'Guard)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      let guardScript :: NativeScript era
guardScript = Credential 'Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential 'Guard -> NativeScript era
RequireGuard Credential 'Guard
guardKeyHash
      let guardScriptHash :: ScriptHash
guardScriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @era (Script era -> ScriptHash) -> Script era -> ScriptHash
forall a b. (a -> b) -> a -> b
$ NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScript

      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
$ Credential 'Guard -> NativeScript era
forall era.
DijkstraEraScript era =>
Credential 'Guard -> NativeScript era
RequireGuard (ScriptHash -> Credential 'Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash)

      Tx era
tx <- ScriptHash -> ImpTestM era (Tx era)
forall era. MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx ScriptHash
scriptHash
      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 [ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ConwayUtxowPredFailure era
forall era. Set ScriptHash -> ConwayUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]]
      Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec 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
& (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))
-> ((OSet (Credential 'Guard)
     -> Identity (OSet (Credential 'Guard)))
    -> TxBody era -> Identity (TxBody era))
-> (OSet (Credential 'Guard)
    -> Identity (OSet (Credential 'Guard)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
-> TxBody era -> Identity (TxBody era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody era) (OSet (Credential 'Guard))
Lens' (TxBody era) (OSet (Credential 'Guard))
guardsTxBodyL ((OSet (Credential 'Guard) -> Identity (OSet (Credential 'Guard)))
 -> Tx era -> Identity (Tx era))
-> OSet (Credential 'Guard) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ScriptHash -> Credential 'Guard
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
guardScriptHash, Item (OSet (Credential 'Guard))
Credential 'Guard
guardKeyHash]
          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 ScriptHash (Script era) -> Identity [Script era])
    -> TxWits era -> Identity (TxWits era))
-> (Map ScriptHash (Script era) -> Identity [Script era])
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era) -> Identity [Script era])
-> TxWits era -> Identity (TxWits era)
forall era.
EraTxWits era =>
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
Lens
  (TxWits era)
  (TxWits era)
  (Map ScriptHash (Script era))
  [Script era]
hashScriptTxWitsL ((Map ScriptHash (Script era) -> Identity [Script era])
 -> Tx era -> Identity (Tx era))
-> [Script era] -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript NativeScript era
guardScript]