{-# 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.Keys (KeyRole (..))
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 (EraCrypto era)
scriptHash = forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum)
            addr :: Addr (EraCrypto era)
addr = forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
scriptHash) forall c. StakeReference c
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 (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo Addr (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
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 (EraCrypto era)) -> AlonzoUtxowPredFailure era
UnspendableUTxONoDatumHash [TxIn (EraCrypto era)
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 (EraCrypto era)
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era (TxId (EraCrypto era))
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)))
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)) (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 (EraCrypto era)
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era (TxId (EraCrypto era))
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 (EraCrypto era)))
inputsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList
              [ forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
producingTx Integer
0
              , forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)) (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 (EraCrypto era)
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era (TxId (EraCrypto era))
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 (EraCrypto era)))
inputsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList
              [ forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
producingTx Integer
0
              , forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)))
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)) -> BabbageUtxoPredFailure era
BabbageNonDisjointRefInputs forall a b. (a -> b) -> a -> b
$
          forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)
shSpending = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
    TxOut era
refTxOut <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash (EraCrypto era)
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 (EraCrypto era) -> TxOut era
scriptLockedTxOut ScriptHash (EraCrypto era)
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 era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Tx era
producingTx
    TxId (EraCrypto era)
producingTxId <- forall era. EraTx era => Tx era -> TxId (EraCrypto era)
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 (EraCrypto era)
lockedTxIn = forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
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 (EraCrypto era)))
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era) -> BabbageContextError era
InlineDatumsNotSupported @era forall a b. (a -> b) -> a -> b
$ forall c. TxIn c -> TxOutSource c
TxOutFromInput TxIn (EraCrypto era)
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 (EraCrypto era)
producingTx <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era (TxId (EraCrypto era))
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 (EraCrypto era)))
inputsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList
              [ forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
producingTx Integer
0
              , forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)))
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)) -> BabbageUtxoPredFailure era
BabbageNonDisjointRefInputs forall a b. (a -> b) -> a -> b
$
          forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)
shSpending = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era) -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash (EraCrypto era)
shSpending
    TxId (EraCrypto era)
producingTx <-
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era. EraTx era => Tx era -> TxId (EraCrypto era)
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 (EraCrypto era) -> TxOut era
scriptLockedTxOut ScriptHash (EraCrypto era)
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 (EraCrypto era)
lockedTxIn = forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
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 (EraCrypto era)))
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton (forall c. HasCallStack => TxId c -> Integer -> TxIn c
mkTxInPartial TxId (EraCrypto era)
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 (EraCrypto era) -> BabbageContextError era
InlineDatumsNotSupported @era forall a b. (a -> b) -> a -> b
$ forall c. TxIn c -> TxOutSource c
TxOutFromInput TxIn (EraCrypto era)
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 (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era))
-> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing
          (Credential 'HotCommitteeRole (EraCrypto era)
ccCred :| [Credential 'HotCommitteeRole (EraCrypto era)]
_) <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
          GovActionId (EraCrypto era)
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction GovAction era
action
          let badField :: VotingProcedures era
badField =
                forall era.
Map
  (Voter (EraCrypto era))
  (Map (GovActionId (EraCrypto era)) (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton
                    (forall c. Credential 'HotCommitteeRole c -> Voter c
CommitteeVoter Credential 'HotCommitteeRole (EraCrypto era)
ccCred)
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton GovActionId (EraCrypto era)
proposal
                  forall a b. (a -> b) -> a -> b
$ forall era.
Vote -> StrictMaybe (Anchor (EraCrypto era)) -> VotingProcedure era
VotingProcedure Vote
VoteYes forall a. StrictMaybe a
SNothing
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era))
-> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing
          (Credential 'HotCommitteeRole (EraCrypto era)
ccCred :| [Credential 'HotCommitteeRole (EraCrypto era)]
_) <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
          GovActionId (EraCrypto era)
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction GovAction era
action
          let badField :: VotingProcedures era
badField =
                forall era.
Map
  (Voter (EraCrypto era))
  (Map (GovActionId (EraCrypto era)) (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton
                    (forall c. Credential 'HotCommitteeRole c -> Voter c
CommitteeVoter Credential 'HotCommitteeRole (EraCrypto era)
ccCred)
                  forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton GovActionId (EraCrypto era)
proposal
                  forall a b. (a -> b) -> a -> b
$ forall era.
Vote -> StrictMaybe (Anchor (EraCrypto era)) -> VotingProcedure era
VotingProcedure Vote
VoteYes forall a. StrictMaybe a
SNothing
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
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 (EraCrypto era)
-> GovAction era
-> Anchor (EraCrypto era)
-> ProposalProcedure era
ProposalProcedure Coin
deposit RewardAccount (EraCrypto era)
rewardAccount forall era. GovAction era
InfoAction forall a. Default a => a
def
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
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 (EraCrypto era)
-> GovAction era
-> Anchor (EraCrypto era)
-> ProposalProcedure era
ProposalProcedure Coin
deposit RewardAccount (EraCrypto era)
rewardAccount forall era. GovAction era
InfoAction forall a. Default a => a
def
          forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
            (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era) -> ImpTestM era ()
testCertificateTranslated TxCert era
okCert TxIn (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL
                      forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
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 (EraCrypto era)
stakingC <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
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 =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn (EraCrypto era) -> 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 (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
stakingC <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
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 =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn (EraCrypto era) -> 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 (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
_poolKH, Credential 'Payment (EraCrypto era)
_spendingC, Credential 'Staking (EraCrypto era)
stakingC) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
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 =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking (EraCrypto era)
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn (EraCrypto era) -> 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 (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
_poolKH, Credential 'Payment (EraCrypto era)
_spendingC, Credential 'Staking (EraCrypto era)
stakingC) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
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 =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking (EraCrypto era)
stakingC Coin
deposit
            forall {era}.
ShelleyEraImp era =>
TxCert era -> TxIn (EraCrypto era) -> 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 (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era) -> 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 (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript @era (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era) -> 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 (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript @era (forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
            testCertificateNotSupported :: TxCert era -> TxIn (EraCrypto era) -> ImpTestM era ()
testCertificateNotSupported TxCert era
badCert TxIn (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL
                      forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
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 (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
delegator, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000_000
            let delegTxCert :: TxCert era
delegTxCert =
                  forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert @era
                    Credential 'Staking (EraCrypto era)
delegator
                    (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
delegator, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000_000
            let delegTxCert :: TxCert era
delegTxCert =
                  forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert @era
                    Credential 'Staking (EraCrypto era)
delegator
                    (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000_000
            KeyHash 'Staking (EraCrypto era)
unregisteredDelegatorKH <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
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 =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert @era
                    (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
unregisteredDelegatorKH)
                    (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000_000
            KeyHash 'Staking (EraCrypto era)
unregisteredDelegatorKH <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
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 =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert @era
                    (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
unregisteredDelegatorKH)
                    (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era)
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 (EraCrypto era)))
getCommitteeMembers
            Credential 'HotCommitteeRole (EraCrypto era)
hotKey <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
            let authCommitteeHotKeyTxCert :: TxCert era
authCommitteeHotKeyTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> Credential 'HotCommitteeRole (EraCrypto era) -> TxCert era
AuthCommitteeHotKeyTxCert @era Credential 'ColdCommitteeRole (EraCrypto era)
coldKey Credential 'HotCommitteeRole (EraCrypto era)
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 (EraCrypto era)
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 (EraCrypto era)))
getCommitteeMembers
            Credential 'HotCommitteeRole (EraCrypto era)
hotKey <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
            let authCommitteeHotKeyTxCert :: TxCert era
authCommitteeHotKeyTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> Credential 'HotCommitteeRole (EraCrypto era) -> TxCert era
AuthCommitteeHotKeyTxCert @era Credential 'ColdCommitteeRole (EraCrypto era)
coldKey Credential 'HotCommitteeRole (EraCrypto era)
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 (EraCrypto era)
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 (EraCrypto era)))
getCommitteeMembers
            let resignCommitteeColdTxCert :: TxCert era
resignCommitteeColdTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
ResignCommitteeColdTxCert @era Credential 'ColdCommitteeRole (EraCrypto era)
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 (EraCrypto era)
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 (EraCrypto era)))
getCommitteeMembers
            let resignCommitteeColdTxCert :: TxCert era
resignCommitteeColdTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
ResignCommitteeColdTxCert @era Credential 'ColdCommitteeRole (EraCrypto era)
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 (EraCrypto era)
unregisteredDRepKH <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
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 (EraCrypto era)
-> Coin -> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
RegDRepTxCert @era (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'DRepRole (EraCrypto era)
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 (EraCrypto era)
unregisteredDRepKH <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
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 (EraCrypto era)
-> Coin -> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
RegDRepTxCert @era (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'DRepRole (EraCrypto era)
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 (EraCrypto era)
drepKH, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
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 (EraCrypto era) -> Coin -> TxCert era
UnRegDRepTxCert @era Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era)
drepKH, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
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 (EraCrypto era) -> Coin -> TxCert era
UnRegDRepTxCert @era Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era)
drepKH, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000_000
            let updateDRepTxCert :: TxCert era
updateDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
UpdateDRepTxCert @era Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era)
drepKH, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000_000
            let updateDRepTxCert :: TxCert era
updateDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era)) -> TxCert era
UpdateDRepTxCert @era Credential 'DRepRole (EraCrypto era)
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 (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (Credential 'DRepRole (EraCrypto era)
dRep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      ScriptHash (EraCrypto era)
scriptHash <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era (ScriptHash (EraCrypto era))
impAddNativeScript forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (Word64 -> SlotNo
SlotNo Word64
1)
      Anchor (EraCrypto era)
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution forall a. StrictMaybe a
SNothing (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
scriptHash)) Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
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 (EraCrypto era))
-> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era)) -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [ScriptHash (EraCrypto era)
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 (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount
        let withdrawals :: Map (RewardAccount (EraCrypto era)) Coin
withdrawals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount (EraCrypto era)
rewardAccount, Integer -> Coin
Coin Integer
1000)]
        let govAction :: GovAction era
govAction = forall era.
Map (RewardAccount (EraCrypto era)) Coin
-> StrictMaybe (ScriptHash (EraCrypto era)) -> GovAction era
TreasuryWithdrawals Map (RewardAccount (EraCrypto era)) Coin
withdrawals (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era)) -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [ScriptHash (EraCrypto era)
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 (EraCrypto era)
alwaysSucceedsSh = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (Credential 'DRepRole (EraCrypto era)
dRep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      Anchor (EraCrypto era)
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution
          forall a. StrictMaybe a
SNothing
          (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
alwaysSucceedsSh))
          Credential 'DRepRole (EraCrypto era)
dRep
          NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers'
      RewardAccount (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
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 (EraCrypto era))
-> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era)) Coin
withdrawals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount (EraCrypto era)
rewardAccount, Integer -> Coin
Coin Integer
1000)]
        let govAction :: GovAction era
govAction = forall era.
Map (RewardAccount (EraCrypto era)) Coin
-> StrictMaybe (ScriptHash (EraCrypto era)) -> GovAction era
TreasuryWithdrawals Map (RewardAccount (EraCrypto era)) Coin
withdrawals (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era)
alwaysFailsSh = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3)
      NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (Credential 'DRepRole (EraCrypto era)
dRep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      Anchor (EraCrypto era)
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution forall a. StrictMaybe a
SNothing (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
alwaysFailsSh)) Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
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 (EraCrypto era))
-> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount
        let withdrawals :: Map (RewardAccount (EraCrypto era)) Coin
withdrawals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount (EraCrypto era)
rewardAccount, Integer -> Coin
Coin Integer
1000)]
        let govAction :: GovAction era
govAction = forall era.
Map (RewardAccount (EraCrypto era)) Coin
-> StrictMaybe (ScriptHash (EraCrypto era)) -> GovAction era
TreasuryWithdrawals Map (RewardAccount (EraCrypto era)) Coin
withdrawals (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (Credential 'DRepRole (EraCrypto era)
dRep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      Anchor (EraCrypto era)
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      GovActionId (EraCrypto era)
govIdConstitution1 <-
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution forall a. StrictMaybe a
SNothing (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor forall a. StrictMaybe a
SNothing) Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers'
      -- propose and enact PlutusV3 Costmodels
      GovPurposeId 'PParamUpdatePurpose era
govIdPPUpdate1 <-
        forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> CostModels
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels forall a. StrictMaybe a
SNothing (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3]) Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers'

      let alwaysFailsSh :: ScriptHash (EraCrypto era)
alwaysFailsSh = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution
          (forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
govIdConstitution1))
          (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
alwaysFailsSh))
          Credential 'DRepRole (EraCrypto era)
dRep
          NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
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 (EraCrypto era))
-> GovAction era
ParameterChange (forall a. a -> StrictMaybe a
SJust GovPurposeId 'PParamUpdatePurpose era
govIdPPUpdate1) PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
        (Credential 'DRepRole (EraCrypto era)
dRep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
        Anchor (EraCrypto era)
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
        let alwaysSucceedsSh :: ScriptHash (EraCrypto era)
alwaysSucceedsSh = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution
            forall a. StrictMaybe a
SNothing
            (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
alwaysSucceedsSh))
            Credential 'DRepRole (EraCrypto era)
dRep
            NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
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 (EraCrypto era))
-> GovAction era
ParameterChange forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
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 (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (Credential 'DRepRole (EraCrypto era)
dRep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000_000
      Anchor (EraCrypto era)
anchor <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      GovActionId (EraCrypto era)
govIdConstitution1 <-
        forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> Constitution era
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution forall a. StrictMaybe a
SNothing (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor forall a. StrictMaybe a
SNothing) Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers'

      Tx era
mintingTokenTx <- forall era.
MaryEraImp era =>
ScriptHash (EraCrypto era) -> ImpTestM era (Tx era)
mkTokenMintingTx forall a b. (a -> b) -> a -> b
$ forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels
          forall a. StrictMaybe a
SNothing
          (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3])
          Credential 'DRepRole (EraCrypto era)
dRep
          NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers'

      let alwaysSucceedsSh :: ScriptHash (EraCrypto era)
alwaysSucceedsSh = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactConstitution
          (forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
govIdConstitution1))
          (forall era.
Anchor (EraCrypto era)
-> StrictMaybe (ScriptHash (EraCrypto era)) -> Constitution era
Constitution Anchor (EraCrypto era)
anchor (forall a. a -> StrictMaybe a
SJust ScriptHash (EraCrypto era)
alwaysSucceedsSh))
          Credential 'DRepRole (EraCrypto era)
dRep
          NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
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 (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels
            (forall a. a -> StrictMaybe a
SJust GovPurposeId 'PParamUpdatePurpose era
govIdPPUpdate1)
            (HasCallStack => [Language] -> CostModels
testingCostModels [Language
PlutusV3])
            Credential 'DRepRole (EraCrypto era)
dRep
            NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers'

scriptLockedTxOut ::
  forall era.
  AlonzoEraTxOut era =>
  ScriptHash (EraCrypto era) ->
  TxOut era
scriptLockedTxOut :: forall era.
AlonzoEraTxOut era =>
ScriptHash (EraCrypto era) -> TxOut era
scriptLockedTxOut ScriptHash (EraCrypto era)
shSpending =
  forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut
    (forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
Addr Network
Testnet (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
shSpending) forall c. StakeReference c
StakeRefNull)
    forall a. Monoid a => a
mempty
    forall a b. a -> (a -> b) -> b
& forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (DataHash (EraCrypto era)))
dataHashTxOutL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust (forall era. Era era => Data era -> DataHash (EraCrypto era)
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 (EraCrypto era) ->
  ImpTestM era (TxOut era)
mkRefTxOut :: forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash (EraCrypto era)
sh = do
  KeyPair 'Payment (EraCrypto era)
kpPayment <- forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
  KeyPair 'Staking (EraCrypto era)
kpStaking <- forall s c (m :: * -> *) (r :: KeyRole).
(HasCallStack, HasKeyPairs s c, MonadState s m) =>
KeyHash r c -> m (KeyPair r c)
lookupKeyPair forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
  let mbyPlutusScript :: Maybe (PlutusScript era)
mbyPlutusScript = forall era.
AlonzoEraImp era =>
ScriptHash (EraCrypto era) -> Maybe (PlutusScript era)
impLookupPlutusScriptMaybe ScriptHash (EraCrypto era)
sh
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut (forall c.
Crypto c =>
(KeyPair 'Payment c, KeyPair 'Staking c) -> Addr c
mkAddr (KeyPair 'Payment (EraCrypto era)
kpPayment, KeyPair 'Staking (EraCrypto era)
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 (EraCrypto era))
setupRefTx :: forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ImpTestM era (TxId (EraCrypto era))
setupRefTx = do
  let shSpending :: ScriptHash (EraCrypto era)
shSpending = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
  TxOut era
refTxOut <- forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash (EraCrypto era)
shSpending
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era. EraTx era => Tx era -> TxId (EraCrypto era)
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 (EraCrypto era) -> TxOut era
scriptLockedTxOut ScriptHash (EraCrypto era)
shSpending
          , forall era.
AlonzoEraTxOut era =>
ScriptHash (EraCrypto era) -> TxOut era
scriptLockedTxOut ScriptHash (EraCrypto era)
shSpending
          ]

testPlutusV1V2Failure ::
  forall era a.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
  , HasCallStack
  ) =>
  ScriptHash (EraCrypto era) ->
  a ->
  Lens' (TxBody era) a ->
  ContextError era ->
  ImpTestM era ()
testPlutusV1V2Failure :: forall era a.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
 HasCallStack) =>
ScriptHash (EraCrypto era)
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure ScriptHash (EraCrypto era)
sh a
badField Lens' (TxBody era) a
lenz ContextError era
errorField = do
  TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash (EraCrypto era) -> ImpTestM era (TxIn (EraCrypto era))
produceScript @era ScriptHash (EraCrypto era)
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 (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Set a
Set.singleton TxIn (EraCrypto era)
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 (EraCrypto era) ->
  NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)) ->
  ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels :: forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> CostModels
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose era)
enactCostModels StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
prevGovId CostModels
cms Credential 'DRepRole (EraCrypto era)
dRep NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
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 (EraCrypto era)
govId <- forall era.
ConwayEraImp era =>
StrictMaybe (GovActionId (EraCrypto era))
-> PParamsUpdate era -> ImpTestM era (GovActionId (EraCrypto era))
submitParameterChange (forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
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 (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
dRep) GovActionId (EraCrypto era)
govId
  forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' GovActionId (EraCrypto era)
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 (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
govId

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