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

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

import Cardano.Ledger.Allegra.Scripts (
  pattern RequireTimeExpire,
 )
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosPredFailure,
 )
import Cardano.Ledger.Alonzo.Scripts (eraLanguages)
import Cardano.Ledger.Alonzo.TxWits (unTxDatsL)
import Cardano.Ledger.BaseTypes (StrictMaybe (..), inject, natVersion)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Mary.Value (AssetName (..), MaryValue (..), MultiAsset (..), PolicyID (..))
import Cardano.Ledger.Plutus (
  Data (..),
  hashData,
  hashPlutusScript,
  withSLanguage,
 )
import Cardano.Ledger.Shelley.Rules (ShelleyDelegPredFailure (..))
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireSignature,
 )
import qualified Data.Map.Strict as Map
import GHC.Exts (fromList)
import Lens.Micro ((%~), (&), (.~))
import Lens.Micro.Mtl (use)
import qualified PlutusLedgerApi.Common as P
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Core.Utils
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples

spec ::
  forall era.
  ( AlonzoEraImp era
  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(AlonzoEraImp era,
 InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure 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
"Valid 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
"Non-script output with datum" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Attach a datum (hash) to a non-script output and then spend it.
    -- Note that the datum cannot be supplied when spending the output,
    -- because it's considered extraneous.
    Addr
addr <- KeyHash 'Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr (KeyHash 'Payment -> StakeReference -> Addr)
-> ImpM (LedgerSpec era) (KeyHash 'Payment)
-> ImpM (LedgerSpec era) (StakeReference -> Addr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Payment ImpM (LedgerSpec era) (StakeReference -> Addr)
-> ImpM (LedgerSpec era) StakeReference
-> ImpM (LedgerSpec era) Addr
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StakeReference -> ImpM (LedgerSpec era) StakeReference
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StakeReference
StakeRefNull
    Coin
amount <- Integer -> Coin
Coin (Integer -> Coin)
-> ImpM (LedgerSpec era) Integer -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
2_000_000, Integer
8_000_000)
    let
      datumHash :: DataHash
datumHash = forall era. Data era -> DataHash
hashData @era (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
123)
      txOut :: TxOut era
txOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
amount) TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (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
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust DataHash
datumHash
      tx1 :: Tx era
tx1 = 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
.~ [Item (StrictSeq (TxOut era))
TxOut era
txOut]
    TxIn
txIn <- 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) -> ImpM (LedgerSpec era) TxIn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx1
    let
      tx2 :: Tx era
tx2 = 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) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx2

  [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
          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 :: ScriptHash
          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 :: ScriptHash
          alwaysFailsWithDatumHash :: ScriptHash
alwaysFailsWithDatumHash = 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
alwaysFailsWithDatum SLanguage l
slang :: ScriptHash
          alwaysFailsNoDatumHash :: ScriptHash
alwaysFailsNoDatumHash = 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
alwaysFailsNoDatum SLanguage l
slang :: ScriptHash

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating SPEND script" (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 -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          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
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
              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]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating SPEND script" (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 -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysFailsWithDatumHash
          Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
              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]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating CERT script" (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 -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          let txCert :: TxCert era
txCert = StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert (StakeCredential -> TxCert era) -> StakeCredential -> TxCert era
forall a b. (a -> b) -> a -> b
$ ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysSucceedsNoDatumHash
          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
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
              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]
                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
.~ [Item (StrictSeq (TxCert era))
TxCert era
txCert]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating CERT script" (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 -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysFailsWithDatumHash
          let txCert :: TxCert era
txCert = StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert (StakeCredential -> TxCert era) -> StakeCredential -> TxCert era
forall a b. (a -> b) -> a -> b
$ ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysSucceedsNoDatumHash
          Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
              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]
                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
.~ [Item (StrictSeq (TxCert era))
TxCert era
txCert]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating WITHDRAWAL script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          RewardAccount
account <- StakeCredential -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
StakeCredential -> ImpTestM era RewardAccount
registerStakeCredential (StakeCredential -> ImpTestM era RewardAccount)
-> StakeCredential -> ImpTestM era RewardAccount
forall a b. (a -> b) -> a -> b
$ ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysSucceedsNoDatumHash
          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
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
              TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
account, Coin
forall a. Monoid a => a
mempty)]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating WITHDRAWAL script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          RewardAccount
account <- StakeCredential -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
StakeCredential -> ImpTestM era RewardAccount
registerStakeCredential (StakeCredential -> ImpTestM era RewardAccount)
-> StakeCredential -> ImpTestM era RewardAccount
forall a b. (a -> b) -> a -> b
$ ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysFailsNoDatumHash
          Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
              TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
account, Coin
forall a. Monoid a => a
mempty)]

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating MINT script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptHash -> ImpM (LedgerSpec era) (Tx era)
forall era. MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx ScriptHash
alwaysSucceedsNoDatumHash

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating MINT script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ (Tx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptHash -> ImpM (LedgerSpec era) (Tx era)
forall era. MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx ScriptHash
alwaysFailsNoDatumHash

        --  Process a transaction with a succeeding script in every place possible,
        --  and also with succeeding timelock scripts.
        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating scripts everywhere" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          SlotNo
slotNo <- Getting SlotNo (ImpTestState era) SlotNo
-> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impLastTickG
          let
            timelockScriptHash :: SlotNo -> ImpM (LedgerSpec era) ScriptHash
timelockScriptHash SlotNo
i = do
              KeyHash 'Witness
addr <- ImpM (LedgerSpec era) (KeyHash 'Witness)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
              NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpM (LedgerSpec era) ScriptHash)
-> NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall a b. (a -> b) -> a -> b
$
                StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf [KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature KeyHash 'Witness
addr, SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire (SlotNo
slotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
100 SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
i)]
            scriptAsset :: ScriptHash -> m (PolicyID, b)
scriptAsset ScriptHash
scriptHash = do
              Positive b
amount <- m (Positive b)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
              (PolicyID, b) -> m (PolicyID, b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptHash -> PolicyID
PolicyID ScriptHash
scriptHash, [Item b] -> b
forall l. IsList l => [Item l] -> l
fromList [(ShortByteString -> AssetName
AssetName ShortByteString
"Test Asset", b
amount)])
          ScriptHash
timelockScriptHash0 <- SlotNo -> ImpM (LedgerSpec era) ScriptHash
timelockScriptHash SlotNo
0
          ScriptHash
timelockScriptHash1 <- SlotNo -> ImpM (LedgerSpec era) ScriptHash
timelockScriptHash SlotNo
1
          ScriptHash
timelockScriptHash2 <- SlotNo -> ImpM (LedgerSpec era) ScriptHash
timelockScriptHash SlotNo
2
          let
            inputScriptHashes :: [ScriptHash]
inputScriptHashes = [Item [ScriptHash]
ScriptHash
alwaysSucceedsWithDatumHash, Item [ScriptHash]
ScriptHash
timelockScriptHash0]
            assetScriptHashes :: [ScriptHash]
assetScriptHashes = [Item [ScriptHash]
ScriptHash
alwaysSucceedsNoDatumHash, Item [ScriptHash]
ScriptHash
timelockScriptHash1]
            rewardScriptHashes :: [ScriptHash]
rewardScriptHashes = [Item [ScriptHash]
ScriptHash
alwaysSucceedsNoDatumHash, Item [ScriptHash]
ScriptHash
timelockScriptHash2]
          [TxIn]
txIns <- (ScriptHash -> ImpM (LedgerSpec era) TxIn)
-> [ScriptHash] -> ImpM (LedgerSpec era) [TxIn]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript [ScriptHash]
inputScriptHashes
          MultiAsset
multiAsset <- Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset (Map PolicyID (Map AssetName Integer) -> MultiAsset)
-> ([(PolicyID, Map AssetName Integer)]
    -> Map PolicyID (Map AssetName Integer))
-> [(PolicyID, Map AssetName Integer)]
-> MultiAsset
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PolicyID, Map AssetName Integer)]
-> Map PolicyID (Map AssetName Integer)
[Item (Map PolicyID (Map AssetName Integer))]
-> Map PolicyID (Map AssetName Integer)
forall l. IsList l => [Item l] -> l
fromList ([(PolicyID, Map AssetName Integer)] -> MultiAsset)
-> ImpM (LedgerSpec era) [(PolicyID, Map AssetName Integer)]
-> ImpM (LedgerSpec era) MultiAsset
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ScriptHash
 -> ImpM (LedgerSpec era) (PolicyID, Map AssetName Integer))
-> [ScriptHash]
-> ImpM (LedgerSpec era) [(PolicyID, Map AssetName Integer)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ScriptHash
-> ImpM (LedgerSpec era) (PolicyID, Map AssetName Integer)
forall {b} {b} {m :: * -> *}.
(Item b ~ (AssetName, b), Num b, Ord b, Arbitrary b, MonadGen m,
 IsList b) =>
ScriptHash -> m (PolicyID, b)
scriptAsset [ScriptHash]
assetScriptHashes
          [RewardAccount]
rewardAccounts <- (ScriptHash -> ImpTestM era RewardAccount)
-> [ScriptHash] -> ImpM (LedgerSpec era) [RewardAccount]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (StakeCredential -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
StakeCredential -> ImpTestM era RewardAccount
registerStakeCredential (StakeCredential -> ImpTestM era RewardAccount)
-> (ScriptHash -> StakeCredential)
-> ScriptHash
-> ImpTestM era RewardAccount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj) [ScriptHash]
rewardScriptHashes
          KeyHash 'Payment
outputAddr <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Payment
          let
            txOut :: TxOut era
txOut =
              Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                (KeyHash 'Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash 'Payment
outputAddr StakeReference
StakeRefNull)
                (Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
multiAsset)
            txBody :: TxBody era
txBody =
              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)] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList [Item (Set TxIn)]
[TxIn]
txIns
                TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (ValidityInterval -> Identity ValidityInterval)
-> TxBody era -> Identity (TxBody era)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
 -> TxBody era -> Identity (TxBody era))
-> ValidityInterval -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing (SlotNo -> StrictMaybe SlotNo
forall a. a -> StrictMaybe a
SJust (SlotNo -> StrictMaybe SlotNo) -> SlotNo -> StrictMaybe SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo
slotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1)
                TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody era -> Identity (TxBody era)
forall era. MaryEraTxBody era => Lens' (TxBody era) MultiAsset
Lens' (TxBody era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody era -> Identity (TxBody era))
-> MultiAsset -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
multiAsset
                TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals ([Item (Map RewardAccount Coin)] -> Map RewardAccount Coin
forall l. IsList l => [Item l] -> l
fromList [(RewardAccount
acct, Coin
forall a. Monoid a => a
mempty) | RewardAccount
acct <- [RewardAccount]
rewardAccounts])
                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
.~ [Item (StrictSeq (TxCert era))] -> StrictSeq (TxCert era)
forall l. IsList l => [Item l] -> l
fromList (StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (StakeCredential -> TxCert era)
-> (ScriptHash -> StakeCredential) -> ScriptHash -> TxCert era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> TxCert era) -> [ScriptHash] -> [TxCert era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ScriptHash]
rewardScriptHashes)
                TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (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)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
txOut]
          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
$ TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody

        String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Acceptable supplementary datum" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
          KeyHash 'Payment
inputAddr <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash @'Payment
          Coin
amount <- Integer -> Coin
Coin (Integer -> Coin)
-> ImpM (LedgerSpec era) Integer -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
2_000_000, Integer
8_000_000)
          TxIn
txIn <- Addr -> Coin -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo (KeyHash 'Payment -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash 'Payment
inputAddr StakeReference
StakeRefNull) Coin
amount
          let
            datum :: Data era
datum = Data -> Data era
forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
123)
            datumHash :: DataHash
datumHash = Data era -> DataHash
forall era. Data era -> DataHash
hashData Data era
datum
            txOut :: TxOut era
txOut =
              Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                (ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
alwaysSucceedsWithDatumHash StakeReference
StakeRefNull)
                (Coin -> MultiAsset -> MaryValue
MaryValue Coin
amount MultiAsset
forall a. Monoid a => a
mempty)
                TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (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
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust DataHash
datumHash
            txBody :: TxBody era
txBody =
              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]
                TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (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)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxOut era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxOut era))
TxOut era
txOut]
            tx :: Tx era
tx =
              TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody
                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 DataHash (Data era) -> Identity (Map DataHash (Data era)))
    -> TxWits era -> Identity (TxWits era))
-> (Map DataHash (Data era) -> Identity (Map DataHash (Data 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))
 -> TxWits era -> Identity (TxWits era))
-> ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
    -> TxDats era -> Identity (TxDats era))
-> (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> TxWits era
-> Identity (TxWits era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
-> TxDats era -> Identity (TxDats era)
forall era. Era era => Lens' (TxDats era) (Map DataHash (Data era))
Lens' (TxDats era) (Map DataHash (Data era))
unTxDatsL ((Map DataHash (Data era) -> Identity (Map DataHash (Data era)))
 -> Tx era -> Identity (Tx era))
-> (Map DataHash (Data era) -> Map DataHash (Data era))
-> Tx era
-> Tx era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DataHash
-> Data era -> Map DataHash (Data era) -> Map DataHash (Data era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DataHash
datumHash Data era
datum
          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
"Multiple identical 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
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsNoDatumHash
          ImpTestM era RewardAccount -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era RewardAccount -> ImpM (LedgerSpec era) ())
-> (StakeCredential -> ImpTestM era RewardAccount)
-> StakeCredential
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakeCredential -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
StakeCredential -> ImpTestM era RewardAccount
registerStakeCredential (StakeCredential -> ImpM (LedgerSpec era) ())
-> StakeCredential -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj 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))
-> ((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
.~ [Item (StrictSeq (TxCert era))] -> StrictSeq (TxCert era)
forall l. IsList l => [Item l] -> l
fromList (StakeCredential -> TxCert era
forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert (StakeCredential -> TxCert era)
-> (ScriptHash -> StakeCredential) -> ScriptHash -> TxCert era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> TxCert era) -> [ScriptHash] -> [TxCert era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ScriptHash -> [ScriptHash]
forall a. Int -> a -> [a]
replicate Int
2 ScriptHash
scriptHash)
          if forall era. Era era => Version
eraProtVerLow @era Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< forall (v :: Nat).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9
            then
              -- This passes UTXOW rules but not DELEG rules; however, we care about only UTXOW rules here
              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
                [ShelleyDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyDelegPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ StakeCredential -> ShelleyDelegPredFailure era
forall era. StakeCredential -> ShelleyDelegPredFailure era
StakeKeyNotRegisteredDELEG (ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash)]
            else
              -- Conway fixed the bug that was causing DELEG to fail
              Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx