{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Conway.Imp.UtxosSpec (spec) where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Allegra.Scripts (
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..), AlonzoUtxowPredFailure (..))
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Conway.TxInfo
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial)
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import qualified PlutusLedgerApi.V1 as P1
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.KeyPair (mkAddr)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus (testingCostModels)
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysFailsNoDatum,
  alwaysSucceedsNoDatum,
  evenRedeemerNoDatum,
  redeemerSameAsDatum,
 )

spec ::
  forall era.
  ( ConwayEraImp era
  , Inject (BabbageContextError era) (ContextError era)
  , Inject (ConwayContextError era) (ContextError era)
  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 Inject (BabbageContextError era) (ContextError era),
 Inject (ConwayContextError era) (ContextError era),
 InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
govPolicySpec
  forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
costModelsSpec
  forall era.
(Inject (BabbageContextError era) (ContextError era),
 InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec
  forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 Inject (ConwayContextError era) (ContextError era)) =>
SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Spending script without a Datum" forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([forall a. Bounded a => a
minBound .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era] :: [Language]) forall a b. (a -> b) -> a -> b
$ \Language
lang -> do
      forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (forall a. Show a => a -> String
show Language
lang) forall a b. (a -> b) -> a -> b
$ do
        let scriptHash :: ScriptHash
scriptHash = forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum)
            addr :: Addr
addr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) StakeReference
StakeRefNull
        Coin
amount <- forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
10_000_000, Integer -> Coin
Coin Integer
100_000_000)
        TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr Coin
amount
        let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
txIn])
        if Language
lang forall a. Ord a => a -> a -> Bool
>= Language
PlutusV3
          then forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
          else
            forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
              Tx era
tx
              [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set TxIn -> AlonzoUtxowPredFailure era
UnspendableUTxONoDatumHash [TxIn
txIn]
              ]

datumAndReferenceInputsSpec ::
  forall era.
  ( Inject (BabbageContextError era) (ContextError era)
  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , ConwayEraImp era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec :: forall era.
(Inject (BabbageContextError era) (ContextError era),
 InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec = do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"can use reference scripts" forall a b. (a -> b) -> a -> b
$ do
    TxId
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era TxId
setupRefTx
    Tx era
referringTx <-
      forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Transaction that refers to the script" forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1)
          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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
    (Tx era
referringTx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. Monoid a => a
mempty
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"can use regular inputs for reference" forall a b. (a -> b) -> a -> b
$ do
    TxId
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era TxId
setupRefTx
    Tx era
referringTx <-
      forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Consuming transaction" forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList
              [ HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0
              , HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
              ]
    (Tx era
referringTx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. Monoid a => a
mempty
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails with same txIn in regular inputs and reference inputs" forall a b. (a -> b) -> a -> b
$ do
    TxId
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era TxId
setupRefTx
    let
      consumingTx :: Tx era
consumingTx =
        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
.~ forall a. Ord a => [a] -> Set a
Set.fromList
              [ HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0
              , HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
              ]
          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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx era
consumingTx
      ( forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmpty TxIn -> BabbageUtxoPredFailure era
BabbageNonDisjointRefInputs forall a b. (a -> b) -> a -> b
$
          HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0 forall a. a -> [a] -> NonEmpty a
:| []
      )
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails when using inline datums for PlutusV1" forall a b. (a -> b) -> a -> b
$ do
    let shSpending :: ScriptHash
shSpending = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
    TxOut era
refTxOut <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
    let producingTx :: Tx era
producingTx =
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
                [ TxOut era
refTxOut
                , forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Data era))
dataTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall era. Era era => Data -> Data era
Data Data
spendDatum)
                ]
    forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
producingTx
    TxId
producingTxId <- forall era. EraTx era => Tx era -> TxId
txIdTx forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Producing transaction" Tx era
producingTx
    let
      lockedTxIn :: TxIn
lockedTxIn = HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTxId Integer
1
      consumingTx :: Tx era
consumingTx =
        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
.~ forall a. a -> Set a
Set.singleton TxIn
lockedTxIn
          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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTxId Integer
0)
    forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Consuming transaction" forall a b. (a -> b) -> a -> b
$
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        Tx era
consumingTx
        ( forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
            forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors
              [forall era. ContextError era -> CollectError era
BadTranslation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t s. Inject t s => t -> s
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. TxOutSource -> BabbageContextError era
InlineDatumsNotSupported @era forall a b. (a -> b) -> a -> b
$ TxIn -> TxOutSource
TxOutFromInput TxIn
lockedTxIn]
        )
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails with same txIn in regular inputs and reference inputs" forall a b. (a -> b) -> a -> b
$ do
    TxId
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era TxId
setupRefTx
    let
      consumingTx :: Tx era
consumingTx =
        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
.~ forall a. Ord a => [a] -> Set a
Set.fromList
              [ HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0
              , HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
              ]
          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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx era
consumingTx
      ( forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmpty TxIn -> BabbageUtxoPredFailure era
BabbageNonDisjointRefInputs forall a b. (a -> b) -> a -> b
$
          HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0 forall a. a -> [a] -> NonEmpty a
:| []
      )
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails when using inline datums for PlutusV1" forall a b. (a -> b) -> a -> b
$ do
    let shSpending :: ScriptHash
shSpending = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1
    TxOut era
refTxOut <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
    TxId
producingTx <-
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era. EraTx era => Tx era -> TxId
txIdTx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Producing transaction" forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
              [ TxOut era
refTxOut
              , forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Data era))
dataTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall era. Era era => Data -> Data era
Data Data
spendDatum)
              ]
    let
      lockedTxIn :: TxIn
lockedTxIn = HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
      consumingTx :: Tx era
consumingTx =
        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
.~ forall a. a -> Set a
Set.singleton TxIn
lockedTxIn
          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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
    forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Consuming transaction" forall a b. (a -> b) -> a -> b
$
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        Tx era
consumingTx
        ( forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
            forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors
              [forall era. ContextError era -> CollectError era
BadTranslation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t s. Inject t s => t -> s
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. TxOutSource -> BabbageContextError era
InlineDatumsNotSupported @era forall a b. (a -> b) -> a -> b
$ TxIn -> TxOutSource
TxOutFromInput TxIn
lockedTxIn]
        )

conwayFeaturesPlutusV1V2FailureSpec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , Inject (ConwayContextError era) (ContextError era)
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 Inject (ConwayContextError era) (ContextError era)) =>
SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Conway features fail in Plutusdescribe v1 and v2" forall a b. (a -> b) -> a -> b
$ do
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Unsupported Fields" forall a b. (a -> b) -> a -> b
$ do
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CurrentTreasuryValue" forall a b. (a -> b) -> a -> b
$ do
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
          Coin
donation <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
          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 era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
donation)
          forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
            (forall a. a -> StrictMaybe a
SJust Coin
donation)
            forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (StrictMaybe Coin)
currentTreasuryValueTxBodyL
            forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject (forall era. Coin -> ConwayContextError era
CurrentTreasuryFieldNotSupported @era Coin
donation)
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
          Coin
donation <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
          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 era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
donation)
          forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
            (forall a. a -> StrictMaybe a
SJust Coin
donation)
            forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (StrictMaybe Coin)
currentTreasuryValueTxBodyL
            forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject (forall era. Coin -> ConwayContextError era
CurrentTreasuryFieldNotSupported @era Coin
donation)
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"VotingProcedures" forall a b. (a -> b) -> a -> b
$ do
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
          GovAction era
action <- forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing
          (Credential 'HotCommitteeRole
ccCred :| [Credential 'HotCommitteeRole]
_) <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
          GovActionId
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
action
          let badField :: VotingProcedures era
badField =
                forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton
                    (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
ccCred)
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton GovActionId
proposal
                  forall a b. (a -> b) -> a -> b
$ forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes forall a. StrictMaybe a
SNothing
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
            VotingProcedures era
badField
            forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
            forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject
            forall a b. (a -> b) -> a -> b
$ forall era. VotingProcedures era -> ConwayContextError era
VotingProceduresFieldNotSupported VotingProcedures era
badField
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
          GovAction era
action <- forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing
          (Credential 'HotCommitteeRole
ccCred :| [Credential 'HotCommitteeRole]
_) <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
          GovActionId
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
action
          let badField :: VotingProcedures era
badField =
                forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton
                    (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
ccCred)
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton GovActionId
proposal
                  forall a b. (a -> b) -> a -> b
$ forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes forall a. StrictMaybe a
SNothing
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
            VotingProcedures era
badField
            forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
            forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject
            forall a b. (a -> b) -> a -> b
$ forall era. VotingProcedures era -> ConwayContextError era
VotingProceduresFieldNotSupported VotingProcedures era
badField
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ProposalProcedures" forall a b. (a -> b) -> a -> b
$ do
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
          Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL
          RewardAccount
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
          let badField :: OSet (ProposalProcedure era)
badField = forall a. a -> OSet a
OSet.singleton forall a b. (a -> b) -> a -> b
$ forall era.
Coin
-> RewardAccount
-> GovAction era
-> Anchor
-> ProposalProcedure era
ProposalProcedure Coin
deposit RewardAccount
rewardAccount forall era. GovAction era
InfoAction forall a. Default a => a
def
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
            OSet (ProposalProcedure era)
badField
            forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL
            forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject
            forall a b. (a -> b) -> a -> b
$ forall era. OSet (ProposalProcedure era) -> ConwayContextError era
ProposalProceduresFieldNotSupported OSet (ProposalProcedure era)
badField
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
          Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL
          RewardAccount
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
          let badField :: OSet (ProposalProcedure era)
badField = forall a. a -> OSet a
OSet.singleton forall a b. (a -> b) -> a -> b
$ forall era.
Coin
-> RewardAccount
-> GovAction era
-> Anchor
-> ProposalProcedure era
ProposalProcedure Coin
deposit RewardAccount
rewardAccount forall era. GovAction era
InfoAction forall a. Default a => a
def
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
            OSet (ProposalProcedure era)
badField
            forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL
            forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject
            forall a b. (a -> b) -> a -> b
$ forall era. OSet (ProposalProcedure era) -> ConwayContextError era
ProposalProceduresFieldNotSupported OSet (ProposalProcedure era)
badField
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TreasuryDonation" forall a b. (a -> b) -> a -> b
$ do
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1"
          forall a b. (a -> b) -> a -> b
$ forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
            (Integer -> Coin
Coin Integer
10_000)
            forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL
          forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject
          forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayContextError era
TreasuryDonationFieldNotSupported @era
          forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2"
          forall a b. (a -> b) -> a -> b
$ forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
            (Integer -> Coin
Coin Integer
10_000)
            forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL
          forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject
          forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayContextError era
TreasuryDonationFieldNotSupported @era
          forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Certificates" forall a b. (a -> b) -> a -> b
$ do
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Translated" forall a b. (a -> b) -> a -> b
$ do
        let testCertificateTranslated :: TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
okCert TxIn
txIn = do
              forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
                ( 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
.~ forall a. a -> Set a
Set.singleton TxIn
txIn
                    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 a. a -> StrictSeq a
SSeq.singleton TxCert era
okCert
                )
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RegDepositTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            Credential 'Staking
stakingC <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
            let regDepositTxCert :: TxCert era
regDepositTxCert = forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
regDepositTxCert
              forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            Credential 'Staking
stakingC <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
            let regDepositTxCert :: TxCert era
regDepositTxCert = forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
regDepositTxCert
              forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UnRegDepositTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            (KeyHash 'StakePool
_poolKH, PaymentCredential
_spendingC, Credential 'Staking
stakingC) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
            Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
            let unRegDepositTxCert :: TxCert era
unRegDepositTxCert = forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
unRegDepositTxCert
              forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            (KeyHash 'StakePool
_poolKH, PaymentCredential
_spendingC, Credential 'Staking
stakingC) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
            Coin
deposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
            let unRegDepositTxCert :: TxCert era
unRegDepositTxCert = forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
unRegDepositTxCert
              forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Unsupported" forall a b. (a -> b) -> a -> b
$ do
        let testCertificateNotSupportedV1 :: TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
badCert =
              forall {rule :: Symbol} {era} {era}.
(EraRuleFailure rule era ~ PredicateFailure (EraRule "LEDGER" era),
 ShelleyEraImp era,
 InjectRuleFailure rule AlonzoUtxosPredFailure era,
 Inject (ConwayContextError era) (ContextError era)) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateNotSupported TxCert era
badCert
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
            testCertificateNotSupportedV2 :: TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
badCert =
              forall {rule :: Symbol} {era} {era}.
(EraRuleFailure rule era ~ PredicateFailure (EraRule "LEDGER" era),
 ShelleyEraImp era,
 InjectRuleFailure rule AlonzoUtxosPredFailure era,
 Inject (ConwayContextError era) (ContextError era)) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateNotSupported TxCert era
badCert
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era (forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
            testCertificateNotSupported :: TxCert era -> TxIn -> ImpTestM era ()
testCertificateNotSupported TxCert era
badCert TxIn
txIn = do
              forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
                ( 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
.~ forall a. a -> Set a
Set.singleton TxIn
txIn
                    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 a. a -> StrictSeq a
SSeq.singleton TxCert era
badCert
                )
                ( forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                    forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors
                      [ forall era. ContextError era -> CollectError era
BadTranslation forall a b. (a -> b) -> a -> b
$
                          forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$
                            forall era. TxCert era -> ConwayContextError era
CertificateNotSupported TxCert era
badCert
                      ]
                )
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DelegTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drep, Credential 'Staking
delegator, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            let delegTxCert :: TxCert era
delegTxCert =
                  forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> TxCert era
DelegTxCert @era
                    Credential 'Staking
delegator
                    (DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
delegTxCert
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drep, Credential 'Staking
delegator, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            let delegTxCert :: TxCert era
delegTxCert =
                  forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> TxCert era
DelegTxCert @era
                    Credential 'Staking
delegator
                    (DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
delegTxCert
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RegDepositDelegTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            KeyHash 'Staking
unregisteredDelegatorKH <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
            let regDepositDelegTxCert :: TxCert era
regDepositDelegTxCert =
                  forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert @era
                    (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
unregisteredDelegatorKH)
                    (DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
                    (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL)
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
regDepositDelegTxCert
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            KeyHash 'Staking
unregisteredDelegatorKH <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
            let regDepositDelegTxCert :: TxCert era
regDepositDelegTxCert =
                  forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert @era
                    (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
unregisteredDelegatorKH)
                    (DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
                    (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL)
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
regDepositDelegTxCert
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AuthCommitteeHotKeyTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            Credential 'ColdCommitteeRole
coldKey <- forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
            Credential 'HotCommitteeRole
hotKey <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            let authCommitteeHotKeyTxCert :: TxCert era
authCommitteeHotKeyTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole
-> Credential 'HotCommitteeRole -> TxCert era
AuthCommitteeHotKeyTxCert @era Credential 'ColdCommitteeRole
coldKey Credential 'HotCommitteeRole
hotKey
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
authCommitteeHotKeyTxCert
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            Credential 'ColdCommitteeRole
coldKey <- forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
            Credential 'HotCommitteeRole
hotKey <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            let authCommitteeHotKeyTxCert :: TxCert era
authCommitteeHotKeyTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole
-> Credential 'HotCommitteeRole -> TxCert era
AuthCommitteeHotKeyTxCert @era Credential 'ColdCommitteeRole
coldKey Credential 'HotCommitteeRole
hotKey
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
authCommitteeHotKeyTxCert
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ResignCommitteeColdTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            Credential 'ColdCommitteeRole
coldKey <- forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
            let resignCommitteeColdTxCert :: TxCert era
resignCommitteeColdTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole -> StrictMaybe Anchor -> TxCert era
ResignCommitteeColdTxCert @era Credential 'ColdCommitteeRole
coldKey forall a. StrictMaybe a
SNothing
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
resignCommitteeColdTxCert
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            Credential 'ColdCommitteeRole
coldKey <- forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
            let resignCommitteeColdTxCert :: TxCert era
resignCommitteeColdTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole -> StrictMaybe Anchor -> TxCert era
ResignCommitteeColdTxCert @era Credential 'ColdCommitteeRole
coldKey forall a. StrictMaybe a
SNothing
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
resignCommitteeColdTxCert
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RegDRepTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            KeyHash 'DRepRole
unregisteredDRepKH <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 forall a b. (a -> b) -> a -> b
$
              forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
RegDRepTxCert @era (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
unregisteredDRepKH) (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL) forall a. StrictMaybe a
SNothing
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            KeyHash 'DRepRole
unregisteredDRepKH <- forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 forall a b. (a -> b) -> a -> b
$
              forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
RegDRepTxCert @era (forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
unregisteredDRepKH) (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL) forall a. StrictMaybe a
SNothing
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UnRegDRepTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
            let unRegDRepTxCert :: TxCert era
unRegDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> TxCert era
UnRegDRepTxCert @era Credential 'DRepRole
drepKH (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL)
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
unRegDRepTxCert
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            PParams era
pp <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
            let unRegDRepTxCert :: TxCert era
unRegDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> TxCert era
UnRegDRepTxCert @era Credential 'DRepRole
drepKH (PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppDRepDepositL)
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
unRegDRepTxCert
        forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UpdateDRepTxCert" forall a b. (a -> b) -> a -> b
$ do
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            let updateDRepTxCert :: TxCert era
updateDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> StrictMaybe Anchor -> TxCert era
UpdateDRepTxCert @era Credential 'DRepRole
drepKH forall a. StrictMaybe a
SNothing
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
updateDRepTxCert
          forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" forall a b. (a -> b) -> a -> b
$ do
            (Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
            let updateDRepTxCert :: TxCert era
updateDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> StrictMaybe Anchor -> TxCert era
UpdateDRepTxCert @era Credential 'DRepRole
drepKH forall a. StrictMaybe a
SNothing
            TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
updateDRepTxCert

govPolicySpec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
govPolicySpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
govPolicySpec = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Gov policy scripts" forall a b. (a -> b) -> a -> b
$ do
    -- These tests rely on the script in the constitution, but we can only change the constitution after bootstrap.
    -- So we cannot run these tests during bootstrap
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failing native script govPolicy" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      (Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
      ScriptHash
scriptHash <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (Word64 -> SlotNo
SlotNo Word64
1)
      Anchor
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution forall a. StrictMaybe a
SNothing (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"ParameterChange" forall a b. (a -> b) -> a -> b
$ do
        let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCommitteeMinSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Natural
1
        let govAction :: GovAction era
govAction = forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)
        ProposalProcedure era
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
        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.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ProposalProcedure era
proposal]
                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.
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. StrictMaybe a
SNothing
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [ScriptHash
scriptHash]]

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"TreasuryWithdrawals" forall a b. (a -> b) -> a -> b
$ do
        RewardAccount
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
        let withdrawals :: Map RewardAccount Coin
withdrawals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1000)]
        let govAction :: GovAction era
govAction = forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map RewardAccount Coin
withdrawals (forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)
        ProposalProcedure era
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
        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.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ProposalProcedure era
proposal]
                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.
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. StrictMaybe a
SNothing
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [ScriptHash
scriptHash]]

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"alwaysSucceeds Plutus govPolicy validates" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      let alwaysSucceedsSh :: ScriptHash
alwaysSucceedsSh = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      (Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
      Anchor
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
          forall a. StrictMaybe a
SNothing
          (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh))
          Credential 'DRepRole
dRep
          NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
      RewardAccount
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"ParameterChange" forall a b. (a -> b) -> a -> b
$ do
        let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCommitteeMinSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Natural
1
        let govAction :: GovAction era
govAction = forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era ()
submitProposal_
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"TreasuryWithdrawals" forall a b. (a -> b) -> a -> b
$ do
        let withdrawals :: Map RewardAccount Coin
withdrawals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1000)]
        let govAction :: GovAction era
govAction = forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map RewardAccount Coin
withdrawals (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era ()
submitProposal_

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"alwaysFails Plutus govPolicy does not validate" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      let alwaysFailsSh :: ScriptHash
alwaysFailsSh = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      (Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
      Anchor
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution forall a. StrictMaybe a
SNothing (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"ParameterChange" forall a b. (a -> b) -> a -> b
$ do
        let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCommitteeMinSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Natural
1
        let govAction :: GovAction era
govAction = forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
        ProposalProcedure era
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
        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.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ProposalProcedure era
proposal]
        forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ Tx era
tx

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"TreasuryWithdrawals" forall a b. (a -> b) -> a -> b
$ do
        RewardAccount
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
        let withdrawals :: Map RewardAccount Coin
withdrawals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1000)]
        let govAction :: GovAction era
govAction = forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map RewardAccount Coin
withdrawals (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
        ProposalProcedure era
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
        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.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ProposalProcedure era
proposal]
        forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ Tx era
tx

costModelsSpec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
costModelsSpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
costModelsSpec =
  -- These tests rely on the script in the constitution, but we can only change the constitution after bootstrap.
  -- So we cannot run these tests during bootstrap
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PlutusV3 Initialization" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels with alwaysFails govPolicy does not validate" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      -- no initial PlutusV3 CostModels
      forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV1 .. Language
PlutusV2]

      NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      (Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
      Anchor
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      GovActionId
govIdConstitution1 <-
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution forall a. StrictMaybe a
SNothing (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor forall a. StrictMaybe a
SNothing) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
      -- propose and enact PlutusV3 Costmodels
      GovPurposeId 'PParamUpdatePurpose era
govIdPPUpdate1 <-
        forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels forall a. StrictMaybe a
SNothing (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3]) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

      let alwaysFailsSh :: ScriptHash
alwaysFailsSh = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
          (forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
govIdConstitution1))
          (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh))
          Credential 'DRepRole
dRep
          NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Fail to update V3 Costmodels" forall a b. (a -> b) -> a -> b
$ do
        let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3])
        let govAction :: GovAction era
govAction = forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange (forall a. a -> StrictMaybe a
SJust GovPurposeId 'PParamUpdatePurpose era
govIdPPUpdate1) PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
        ProposalProcedure era
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
        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.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ProposalProcedure era
proposal]
        forall era.
(HasCallStack, AlonzoEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ Tx era
tx

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels with alwaysSucceeds govPolicy but no PlutusV3 CostModels fails" forall a b. (a -> b) -> a -> b
$
      forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
        forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV1 .. Language
PlutusV2]

        NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
        (Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
        Anchor
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
        let alwaysSucceedsSh :: ScriptHash
alwaysSucceedsSh = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
          forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
            forall a. StrictMaybe a
SNothing
            (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh))
            Credential 'DRepRole
dRep
            NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

        let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3])
        let govAction :: GovAction era
govAction = forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)

        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingGovAction GovAction era
govAction [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [forall era. Language -> CollectError era
NoCostModel Language
PlutusV3]]

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels and setting the govPolicy afterwards succeeds" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV1 .. Language
PlutusV2]

      NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      (Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
      Anchor
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      GovActionId
govIdConstitution1 <-
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution forall a. StrictMaybe a
SNothing (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor forall a. StrictMaybe a
SNothing) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

      Tx era
mintingTokenTx <- forall era. MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx forall a b. (a -> b) -> a -> b
$ forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage 'PlutusV3
SPlutusV3)

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Minting token fails" forall a b. (a -> b) -> a -> b
$ do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
mintingTokenTx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [forall era. Language -> CollectError era
NoCostModel Language
PlutusV3]]

      GovPurposeId 'PParamUpdatePurpose era
govIdPPUpdate1 <-
        forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels
          forall a. StrictMaybe a
SNothing
          (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3])
          Credential 'DRepRole
dRep
          NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

      let alwaysSucceedsSh :: ScriptHash
alwaysSucceedsSh = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
          (forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
govIdConstitution1))
          (forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh))
          Credential 'DRepRole
dRep
          NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Minting token succeeds" forall a b. (a -> b) -> a -> b
$ do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
mintingTokenTx

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Updating CostModels succeeds" forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$
          forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels
            (forall a. a -> StrictMaybe a
SJust GovPurposeId 'PParamUpdatePurpose era
govIdPPUpdate1)
            (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3])
            Credential 'DRepRole
dRep
            NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'

scriptLockedTxOut ::
  forall era.
  AlonzoEraTxOut era =>
  ScriptHash ->
  TxOut era
scriptLockedTxOut :: forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending =
  forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
    (Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
shSpending) StakeReference
StakeRefNull)
    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 (forall era. Data era -> DataHash
hashData @era forall a b. (a -> b) -> a -> b
$ forall era. Era era => Data -> Data era
Data Data
spendDatum)

mkRefTxOut ::
  ( BabbageEraTxOut era
  , AlonzoEraImp era
  ) =>
  ScriptHash ->
  ImpTestM era (TxOut era)
mkRefTxOut :: forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
sh = do
  KeyPair 'Payment
kpPayment <- forall s (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
KeyHash r -> m (KeyPair r)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  KeyPair 'Staking
kpStaking <- forall s (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s, MonadState s m) =>
KeyHash r -> m (KeyPair r)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  let mbyPlutusScript :: Maybe (PlutusScript era)
mbyPlutusScript = forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash
sh
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut ((KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr (KeyPair 'Payment
kpPayment, KeyPair 'Staking
kpStaking)) forall a. Monoid a => a
mempty
      forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PlutusScript era)
mbyPlutusScript)

setupRefTx ::
  forall era.
  ( BabbageEraTxOut era
  , AlonzoEraImp era
  ) =>
  ImpTestM era TxId
setupRefTx :: forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era TxId
setupRefTx = do
  let shSpending :: ScriptHash
shSpending = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
  TxOut era
refTxOut <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era. EraTx era => Tx era -> TxId
txIdTx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Producing transaction" forall a b. (a -> b) -> a -> b
$
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
        forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
SSeq.fromList
          [ TxOut era
refTxOut
          , forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending
          , forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending
          ]

testPlutusV1V2Failure ::
  forall era a.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , HasCallStack
  ) =>
  ScriptHash ->
  a ->
  Lens' (TxBody era) a ->
  ContextError era ->
  ImpTestM era ()
testPlutusV1V2Failure :: forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure ScriptHash
sh a
badField Lens' (TxBody era) a
lenz ContextError era
errorField = do
  TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era ScriptHash
sh
  forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
    ( 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
.~ forall a. a -> Set a
Set.singleton TxIn
txIn
        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
. Lens' (TxBody era) a
lenz forall s t a b. ASetter s t a b -> b -> s -> t
.~ a
badField
    )
    ( forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
        forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [forall era. ContextError era -> CollectError era
BadTranslation ContextError era
errorField]
    )

enactCostModels ::
  ConwayEraImp era =>
  StrictMaybe (GovPurposeId 'PParamUpdatePurpose era) ->
  CostModels ->
  Credential 'DRepRole ->
  NonEmpty (Credential 'HotCommitteeRole) ->
  ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels :: forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
prevGovId CostModels
cms Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' = do
  CostModels
initialCms <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL
  let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust CostModels
cms
  GovActionId
govId <- forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
submitParameterChange (forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId
unGovPurposeId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
prevGovId) PParamsUpdate era
pparamsUpdate
  forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep) GovActionId
govId
  forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' GovActionId
govId
  forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
  CostModels
enactedCms <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL
  CostModels
enactedCms forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` (CostModels
initialCms forall a. Semigroup a => a -> a -> a
<> CostModels
cms)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: GovActionPurpose) era.
GovActionId -> GovPurposeId p era
GovPurposeId GovActionId
govId

spendDatum :: P1.Data
spendDatum :: Data
spendDatum = Integer -> Data
P1.I Integer
3