{-# 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 GHC.Exts (fromList)
import Lens.Micro ((%~), (&), (.~))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Core.Utils
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples

import qualified Data.Map.Strict as Map
import qualified PlutusLedgerApi.Common as P

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 = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Valid transactions" forall a b. (a -> b) -> a -> b
$ do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Non-script output with datum" 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 <- forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr 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 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure StakeReference
StakeRefNull
    Coin
amount <- Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
123)
      txOut :: TxOut era
txOut = forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (forall t s. Inject t s => t -> s
inject Coin
amount) forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust DataHash
datumHash
      tx1 :: Tx era
tx1 = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era
txOut]
    TxIn
txIn <- forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn
txInAt (Int
0 :: Int) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx Tx era
tx1
    let
      tx2 :: Tx era
tx2 = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx2

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

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating SPEND script" forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
              forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating SPEND script" forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysFailsWithDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ forall a b. (a -> b) -> a -> b
$
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
              forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Validating CERT script" forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysSucceedsWithDatumHash
          let txCert :: TxCert era
txCert = forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysSucceedsNoDatumHash
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
              forall era. EraTxBody era => TxBody era
mkBasicTxBody
                forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
                forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era
txCert]

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Not validating CERT script" forall a b. (a -> b) -> a -> b
$ do
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript ScriptHash
alwaysFailsWithDatumHash
          let txCert :: TxCert era
txCert = forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
RegTxCert forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
alwaysSucceedsNoDatumHash
          forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ forall a b. (a -> b) -> a -> b
$
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
              forall era. EraTxBody era => TxBody era
mkBasicTxBody
                forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
                forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxCert era
txCert]

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

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

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

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

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Acceptable supplementary datum" 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
2_000_000, Integer
8_000_000)
          TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo (forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr KeyHash 'Payment
inputAddr StakeReference
StakeRefNull) Coin
amount
          let
            datum :: Data era
datum = forall era. Era era => Data -> Data era
Data (Integer -> Data
P.I Integer
123)
            datumHash :: DataHash
datumHash = forall era. Data era -> DataHash
hashData Data era
datum
            txOut :: TxOut era
txOut =
              forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
                (forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
alwaysSucceedsWithDatumHash StakeReference
StakeRefNull)
                (Coin -> MultiAsset -> MaryValue
MaryValue Coin
amount forall a. Monoid a => a
mempty)
                forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust DataHash
datumHash
            txBody :: TxBody era
txBody =
              forall era. EraTxBody era => TxBody era
mkBasicTxBody
                forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn]
                forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era
txOut]
            tx :: Tx era
tx =
              forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Era era => Lens' (TxDats era) (Map DataHash (Data era))
unTxDatsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DataHash
datumHash Data era
datum
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx

        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Multiple identical certificates" forall a b. (a -> b) -> a -> b
$ do
          let scriptHash :: ScriptHash
scriptHash = ScriptHash
alwaysSucceedsNoDatumHash
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, ShelleyEraImp era) =>
StakeCredential -> ImpTestM era RewardAccount
registerStakeCredential forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash
          let tx :: Tx era
tx =
                forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                  forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall l. IsList l => [Item l] -> l
fromList (forall era. ShelleyEraTxCert era => StakeCredential -> TxCert era
UnRegTxCert forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> a -> [a]
replicate Int
2 ScriptHash
scriptHash)
          if forall era. Era era => Version
eraProtVerLow @era 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
              forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                Tx era
tx
                [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. StakeCredential -> ShelleyDelegPredFailure era
StakeKeyNotRegisteredDELEG (forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash)]
            else
              -- Conway fixed the bug that was causing DELEG to fail
              forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx