{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Cardano.Ledger.Conway.Imp.UtxosSpec (spec) where
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Allegra.Scripts (
pattern RequireTimeStart,
)
import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..))
import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..), AlonzoUtxowPredFailure (..))
import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..))
import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Conway.TxInfo
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial)
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import qualified Data.OSet.Strict as OSet
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import qualified PlutusLedgerApi.V1 as P1
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.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
SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
govPolicySpec
SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
costModelsSpec
SpecWith (ImpInit (LedgerSpec era))
forall era.
(Inject (BabbageContextError era) (ContextError era),
InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
ConwayEraImp era,
Inject (ConwayContextError era) (ContextError era)) =>
SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec
SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
Inject (ConwayContextError era) (ContextError era)) =>
SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Spending script without a Datum" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
[Language]
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Item [Language]
Language
forall a. Bounded a => a
minBound .. forall era. AlonzoEraScript era => Language
eraMaxLanguage @era] :: [Language]) ((Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era)))
-> (Language -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \Language
lang -> do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (Language -> String
forall a. Show a => a -> String
show Language
lang) (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
let scriptHash :: ScriptHash
scriptHash = Language
-> (forall (l :: Language).
PlutusLanguage l =>
SLanguage l -> ScriptHash)
-> ScriptHash
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang (Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus l -> ScriptHash)
-> (SLanguage l -> Plutus l) -> SLanguage l -> ScriptHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum)
addr :: Addr
addr = Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
Testnet (ScriptHash -> PaymentCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash) StakeReference
StakeRefNull
Coin
amount <- (Coin, Coin) -> ImpM (LedgerSpec era) Coin
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
10_000_000, Integer -> Coin
Coin Integer
100_000_000)
TxIn
txIn <- Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr Coin
amount
let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn])
if Language
lang Language -> Language -> Bool
forall a. Ord a => a -> a -> Bool
>= Language
PlutusV3
then Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
else
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
tx
[ AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set TxIn -> AlonzoUtxowPredFailure era
forall era. Set TxIn -> AlonzoUtxowPredFailure era
UnspendableUTxONoDatumHash [Item (Set TxIn)
TxIn
txIn]
]
datumAndReferenceInputsSpec ::
forall era.
( Inject (BabbageContextError era) (ContextError era)
, InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
, ConwayEraImp era
, Inject (ConwayContextError era) (ContextError era)
) =>
SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec :: forall era.
(Inject (BabbageContextError era) (ContextError era),
InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
ConwayEraImp era,
Inject (ConwayContextError era) (ContextError era)) =>
SpecWith (ImpInit (LedgerSpec era))
datumAndReferenceInputsSpec = do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"can use reference scripts" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
TxId
producingTx <- SLanguage 'PlutusV1 -> ImpTestM era TxId
forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage 'PlutusV1
SPlutusV1
Tx era
referringTx <-
String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Transaction that refers to the script" (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1)
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
(Tx era
referringTx Tx era
-> Getting
(Map ScriptHash (Script era))
(Tx era)
(Map ScriptHash (Script era))
-> Map ScriptHash (Script era)
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Tx era -> Const (Map ScriptHash (Script era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Tx era -> Const (Map ScriptHash (Script era)) (Tx era))
-> ((Map ScriptHash (Script era)
-> Const
(Map ScriptHash (Script era)) (Map ScriptHash (Script era)))
-> TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Getting
(Map ScriptHash (Script era))
(Tx era)
(Map ScriptHash (Script era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
-> Const
(Map ScriptHash (Script era)) (Map ScriptHash (Script era)))
-> TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL) Map ScriptHash (Script era)
-> Map ScriptHash (Script era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Map ScriptHash (Script era)
forall a. Monoid a => a
mempty
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"can use regular inputs for reference" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
TxId
producingTx <- SLanguage 'PlutusV1 -> ImpTestM era TxId
forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage 'PlutusV1
SPlutusV1
Tx era
referringTx <-
String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Consuming transaction" (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList
[ HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0
, HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
]
(Tx era
referringTx Tx era
-> Getting
(Map ScriptHash (Script era))
(Tx era)
(Map ScriptHash (Script era))
-> Map ScriptHash (Script era)
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Tx era -> Const (Map ScriptHash (Script era)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Tx era -> Const (Map ScriptHash (Script era)) (Tx era))
-> ((Map ScriptHash (Script era)
-> Const
(Map ScriptHash (Script era)) (Map ScriptHash (Script era)))
-> TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era))
-> Getting
(Map ScriptHash (Script era))
(Tx era)
(Map ScriptHash (Script era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Script era)
-> Const
(Map ScriptHash (Script era)) (Map ScriptHash (Script era)))
-> TxWits era -> Const (Map ScriptHash (Script era)) (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL) Map ScriptHash (Script era)
-> Map ScriptHash (Script era) -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Map ScriptHash (Script era)
forall a. Monoid a => a
mempty
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails with same txIn in regular inputs and reference inputs (PlutusV1)" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
TxId
producingTx <- SLanguage 'PlutusV1 -> ImpTestM era TxId
forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage 'PlutusV1
SPlutusV1
let
consumingTx :: Tx era
consumingTx =
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList
[ HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0
, HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
]
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
let badTxIns :: NonEmpty TxIn
badTxIns = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0 TxIn -> [TxIn] -> NonEmpty TxIn
forall a. a -> [a] -> NonEmpty a
:| []
forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtMost @10 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
consumingTx
(PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (BabbageUtxoPredFailure era
-> PredicateFailure (EraRule "LEDGER" era))
-> BabbageUtxoPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BabbageUtxoPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
BabbageUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (BabbageUtxoPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> BabbageUtxoPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ NonEmpty TxIn -> BabbageUtxoPredFailure era
forall era. NonEmpty TxIn -> BabbageUtxoPredFailure era
BabbageNonDisjointRefInputs NonEmpty TxIn
badTxIns)
forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
consumingTx
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails when using inline datums for PlutusV1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
let shSpending :: ScriptHash
shSpending = Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
TxOut era
refTxOut <- ScriptHash -> ImpM (LedgerSpec era) (TxOut era)
forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
let producingTx :: Tx era
producingTx =
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList
[ Item [TxOut era]
TxOut era
refTxOut
, ScriptHash -> TxOut era
forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Data era) -> Identity (StrictMaybe (Data era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Data era))
Lens' (TxOut era) (StrictMaybe (Data era))
dataTxOutL ((StrictMaybe (Data era) -> Identity (StrictMaybe (Data era)))
-> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Data era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Data era -> StrictMaybe (Data era)
forall a. a -> StrictMaybe a
SJust (Data -> Data era
forall era. Era era => Data -> Data era
Data Data
spendDatum)
]
Tx era -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
producingTx
TxId
producingTxId <- Tx era -> TxId
forall era. EraTx era => Tx era -> TxId
txIdTx (Tx era -> TxId)
-> ImpM (LedgerSpec era) (Tx era) -> ImpTestM era TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Producing transaction" Tx era
producingTx
let
lockedTxIn :: TxIn
lockedTxIn = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTxId Integer
1
consumingTx :: Tx era
consumingTx =
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
lockedTxIn
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTxId Integer
0)
String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Consuming transaction" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
consumingTx
( PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
[CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors
[ContextError era -> Item [CollectError era]
ContextError era -> CollectError era
forall era. ContextError era -> CollectError era
BadTranslation (ContextError era -> Item [CollectError era])
-> (TxOutSource -> ContextError era)
-> TxOutSource
-> Item [CollectError era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BabbageContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (BabbageContextError era -> ContextError era)
-> (TxOutSource -> BabbageContextError era)
-> TxOutSource
-> ContextError era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. TxOutSource -> BabbageContextError era
InlineDatumsNotSupported @era (TxOutSource -> Item [CollectError era])
-> TxOutSource -> Item [CollectError era]
forall a b. (a -> b) -> a -> b
$ TxIn -> TxOutSource
TxOutFromInput TxIn
lockedTxIn]
)
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails with same txIn in regular inputs and reference inputs (PlutusV3)" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
TxId
producingTx <- SLanguage 'PlutusV3 -> ImpTestM era TxId
forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage 'PlutusV3
SPlutusV3
let
consumingTx :: Tx era
consumingTx =
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx @era TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList
[ HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0
, HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
]
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
let badTxIns :: NonEmpty TxIn
badTxIns = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0 TxIn -> [TxIn] -> NonEmpty TxIn
forall a. a -> [a] -> NonEmpty a
:| []
forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtMost @10 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx @era
Tx era
consumingTx
(PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (BabbageUtxoPredFailure era
-> PredicateFailure (EraRule "LEDGER" era))
-> BabbageUtxoPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BabbageUtxoPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
BabbageUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (BabbageUtxoPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> BabbageUtxoPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ NonEmpty TxIn -> BabbageUtxoPredFailure era
forall era. NonEmpty TxIn -> BabbageUtxoPredFailure era
BabbageNonDisjointRefInputs NonEmpty TxIn
badTxIns)
forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtLeast @11 (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx @era
Tx era
consumingTx
[ AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
[CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [ContextError era -> Item [CollectError era]
ContextError era -> CollectError era
forall era. ContextError era -> CollectError era
BadTranslation (ContextError era -> Item [CollectError era])
-> (ConwayContextError era -> ContextError era)
-> ConwayContextError era
-> Item [CollectError era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (ConwayContextError era -> Item [CollectError era])
-> ConwayContextError era -> Item [CollectError era]
forall a b. (a -> b) -> a -> b
$ forall era. NonEmpty TxIn -> ConwayContextError era
ReferenceInputsNotDisjointFromInputs @era NonEmpty TxIn
badTxIns]
]
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails when using inline datums for PlutusV1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
let shSpending :: ScriptHash
shSpending = Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1
TxOut era
refTxOut <- ScriptHash -> ImpM (LedgerSpec era) (TxOut era)
forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
TxId
producingTx <-
(Tx era -> TxId)
-> ImpM (LedgerSpec era) (Tx era) -> ImpTestM era TxId
forall a b.
(a -> b) -> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx era -> TxId
forall era. EraTx era => Tx era -> TxId
txIdTx (ImpM (LedgerSpec era) (Tx era) -> ImpTestM era TxId)
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpTestM era TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Producing transaction" (Tx era -> ImpTestM era TxId) -> Tx era -> ImpTestM era TxId
forall a b. (a -> b) -> a -> b
$
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList
[ Item [TxOut era]
TxOut era
refTxOut
, ScriptHash -> TxOut era
forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Data era) -> Identity (StrictMaybe (Data era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Data era))
Lens' (TxOut era) (StrictMaybe (Data era))
dataTxOutL ((StrictMaybe (Data era) -> Identity (StrictMaybe (Data era)))
-> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Data era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Data era -> StrictMaybe (Data era)
forall a. a -> StrictMaybe a
SJust (Data -> Data era
forall era. Era era => Data -> Data era
Data Data
spendDatum)
]
let
lockedTxIn :: TxIn
lockedTxIn = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
1
consumingTx :: Tx era
consumingTx =
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
lockedTxIn
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
producingTx Integer
0)
String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Consuming transaction" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
Tx era
consumingTx
( PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
[CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors
[ContextError era -> Item [CollectError era]
ContextError era -> CollectError era
forall era. ContextError era -> CollectError era
BadTranslation (ContextError era -> Item [CollectError era])
-> (TxOutSource -> ContextError era)
-> TxOutSource
-> Item [CollectError era]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BabbageContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (BabbageContextError era -> ContextError era)
-> (TxOutSource -> BabbageContextError era)
-> TxOutSource
-> ContextError era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. TxOutSource -> BabbageContextError era
InlineDatumsNotSupported @era (TxOutSource -> Item [CollectError era])
-> TxOutSource -> Item [CollectError era]
forall a b. (a -> b) -> a -> b
$ TxIn -> TxOutSource
TxOutFromInput TxIn
lockedTxIn]
)
conwayFeaturesPlutusV1V2FailureSpec ::
forall era.
( ConwayEraImp era
, InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
, Inject (ConwayContextError era) (ContextError era)
) =>
SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec :: forall era.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
Inject (ConwayContextError era) (ContextError era)) =>
SpecWith (ImpInit (LedgerSpec era))
conwayFeaturesPlutusV1V2FailureSpec = do
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Conway features fail in Plutusdescribe v1 and v2" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Unsupported Fields" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CurrentTreasuryValue" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Coin
donation <- ImpM (LedgerSpec era) Coin
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> Coin -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
donation)
ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
ScriptHash
-> StrictMaybe Coin
-> Lens' (TxBody era) (StrictMaybe Coin)
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
(Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
donation)
(StrictMaybe Coin -> f (StrictMaybe Coin))
-> TxBody era -> f (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (StrictMaybe Coin)
Lens' (TxBody era) (StrictMaybe Coin)
currentTreasuryValueTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (forall era. Coin -> ConwayContextError era
CurrentTreasuryFieldNotSupported @era Coin
donation)
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Coin
donation <- ImpM (LedgerSpec era) Coin
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era)
forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin) -> TxBody era -> Identity (TxBody era))
-> Coin -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
donation)
ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
ScriptHash
-> StrictMaybe Coin
-> Lens' (TxBody era) (StrictMaybe Coin)
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
(Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
donation)
(StrictMaybe Coin -> f (StrictMaybe Coin))
-> TxBody era -> f (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (StrictMaybe Coin)
Lens' (TxBody era) (StrictMaybe Coin)
currentTreasuryValueTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (forall era. Coin -> ConwayContextError era
CurrentTreasuryFieldNotSupported @era Coin
donation)
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"VotingProcedures" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
GovAction era
action <- StrictMaybe GovActionId -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing
(Credential 'HotCommitteeRole
ccCred :| [Credential 'HotCommitteeRole]
_) <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
GovActionId
proposal <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
action
let badField :: VotingProcedures era
badField =
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
(Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era)
-> Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall a b. (a -> b) -> a -> b
$ Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton
(Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
ccCred)
(Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era)))
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall a b. (a -> b) -> a -> b
$ GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
proposal
(VotingProcedure era -> Map GovActionId (VotingProcedure era))
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall a b. (a -> b) -> a -> b
$ Vote -> StrictMaybe Anchor -> VotingProcedure era
forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
ScriptHash
-> VotingProcedures era
-> Lens' (TxBody era) (VotingProcedures era)
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
VotingProcedures era
badField
(VotingProcedures era -> f (VotingProcedures era))
-> TxBody era -> f (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject
(ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ VotingProcedures era -> ConwayContextError era
forall era. VotingProcedures era -> ConwayContextError era
VotingProceduresFieldNotSupported VotingProcedures era
badField
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
GovAction era
action <- StrictMaybe GovActionId -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing
(Credential 'HotCommitteeRole
ccCred :| [Credential 'HotCommitteeRole]
_) <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
GovActionId
proposal <- GovAction era -> ImpTestM era GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction GovAction era
action
let badField :: VotingProcedures era
badField =
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
(Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era)
-> Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall a b. (a -> b) -> a -> b
$ Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton
(Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
ccCred)
(Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era)))
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall a b. (a -> b) -> a -> b
$ GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
proposal
(VotingProcedure era -> Map GovActionId (VotingProcedure era))
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall a b. (a -> b) -> a -> b
$ Vote -> StrictMaybe Anchor -> VotingProcedure era
forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
ScriptHash
-> VotingProcedures era
-> Lens' (TxBody era) (VotingProcedures era)
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
VotingProcedures era
badField
(VotingProcedures era -> f (VotingProcedures era))
-> TxBody era -> f (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject
(ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ VotingProcedures era -> ConwayContextError era
forall era. VotingProcedures era -> ConwayContextError era
VotingProceduresFieldNotSupported VotingProcedures era
badField
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ProposalProcedures" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Coin
deposit <- SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
-> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL
RewardAccount
rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
let badField :: OSet (ProposalProcedure era)
badField = ProposalProcedure era -> OSet (ProposalProcedure era)
forall a. a -> OSet a
OSet.singleton (ProposalProcedure era -> OSet (ProposalProcedure era))
-> ProposalProcedure era -> OSet (ProposalProcedure era)
forall a b. (a -> b) -> a -> b
$ Coin
-> RewardAccount
-> GovAction era
-> Anchor
-> ProposalProcedure era
forall era.
Coin
-> RewardAccount
-> GovAction era
-> Anchor
-> ProposalProcedure era
ProposalProcedure Coin
deposit RewardAccount
rewardAccount GovAction era
forall era. GovAction era
InfoAction Anchor
forall a. Default a => a
def
ScriptHash
-> OSet (ProposalProcedure era)
-> Lens' (TxBody era) (OSet (ProposalProcedure era))
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
OSet (ProposalProcedure era)
badField
(OSet (ProposalProcedure era) -> f (OSet (ProposalProcedure era)))
-> TxBody era -> f (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject
(ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ OSet (ProposalProcedure era) -> ConwayContextError era
forall era. OSet (ProposalProcedure era) -> ConwayContextError era
ProposalProceduresFieldNotSupported OSet (ProposalProcedure era)
badField
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Coin
deposit <- SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
-> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL
RewardAccount
rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
let badField :: OSet (ProposalProcedure era)
badField = ProposalProcedure era -> OSet (ProposalProcedure era)
forall a. a -> OSet a
OSet.singleton (ProposalProcedure era -> OSet (ProposalProcedure era))
-> ProposalProcedure era -> OSet (ProposalProcedure era)
forall a b. (a -> b) -> a -> b
$ Coin
-> RewardAccount
-> GovAction era
-> Anchor
-> ProposalProcedure era
forall era.
Coin
-> RewardAccount
-> GovAction era
-> Anchor
-> ProposalProcedure era
ProposalProcedure Coin
deposit RewardAccount
rewardAccount GovAction era
forall era. GovAction era
InfoAction Anchor
forall a. Default a => a
def
ScriptHash
-> OSet (ProposalProcedure era)
-> Lens' (TxBody era) (OSet (ProposalProcedure era))
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
OSet (ProposalProcedure era)
badField
(OSet (ProposalProcedure era) -> f (OSet (ProposalProcedure era)))
-> TxBody era -> f (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject
(ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ OSet (ProposalProcedure era) -> ConwayContextError era
forall era. OSet (ProposalProcedure era) -> ConwayContextError era
ProposalProceduresFieldNotSupported OSet (ProposalProcedure era)
badField
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"TreasuryDonation" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1"
(ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ ScriptHash
-> Coin
-> Lens' (TxBody era) Coin
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
(Integer -> Coin
Coin Integer
10_000)
(Coin -> f Coin) -> TxBody era -> f (TxBody era)
forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
treasuryDonationTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject
(ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayContextError era
TreasuryDonationFieldNotSupported @era
(Coin -> ConwayContextError era) -> Coin -> ConwayContextError era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2"
(ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ ScriptHash
-> Coin
-> Lens' (TxBody era) Coin
-> ContextError era
-> ImpM (LedgerSpec era) ()
forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure
(Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
(Integer -> Coin
Coin Integer
10_000)
(Coin -> f Coin) -> TxBody era -> f (TxBody era)
forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
Lens' (TxBody era) Coin
treasuryDonationTxBodyL
(ContextError era -> ImpM (LedgerSpec era) ())
-> ContextError era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject
(ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayContextError era
TreasuryDonationFieldNotSupported @era
(Coin -> ConwayContextError era) -> Coin -> ConwayContextError era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
10_000
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Certificates" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Translated" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
let testCertificateTranslated :: TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
okCert TxIn
txIn = do
Tx era -> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_
( TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxCert era -> StrictSeq (TxCert era)
forall a. a -> StrictSeq a
SSeq.singleton TxCert era
okCert
)
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RegDepositTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Credential 'Staking
stakingC <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
Coin
deposit <- SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
-> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
let regDepositTxCert :: TxCert era
regDepositTxCert = Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking
stakingC Coin
deposit
TxCert era -> TxIn -> ImpM (LedgerSpec era) ()
forall {era}.
(Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
Eq (Event (EraRule "LEDGER" era)),
NFData (Event (EraRule "TICK" era)),
NFData (Event (EraRule "LEDGER" era)),
Typeable (Event (EraRule "TICK" era)),
Typeable (Event (EraRule "LEDGER" era)),
ToExpr (Event (EraRule "TICK" era)),
ToExpr (Event (EraRule "LEDGER" era))) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
regDepositTxCert
(TxIn -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Credential 'Staking
stakingC <- KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'Staking -> Credential 'Staking)
-> ImpM (LedgerSpec era) (KeyHash 'Staking)
-> ImpM (LedgerSpec era) (Credential 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
Coin
deposit <- SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
-> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
let regDepositTxCert :: TxCert era
regDepositTxCert = Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking
stakingC Coin
deposit
TxCert era -> TxIn -> ImpM (LedgerSpec era) ()
forall {era}.
(Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
Eq (Event (EraRule "LEDGER" era)),
NFData (Event (EraRule "TICK" era)),
NFData (Event (EraRule "LEDGER" era)),
Typeable (Event (EraRule "TICK" era)),
Typeable (Event (EraRule "LEDGER" era)),
ToExpr (Event (EraRule "TICK" era)),
ToExpr (Event (EraRule "LEDGER" era))) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
regDepositTxCert
(TxIn -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UnRegDepositTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(KeyHash 'StakePool
_poolKH, PaymentCredential
_spendingC, Credential 'Staking
stakingC) <- Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
setupPoolWithStake (Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking))
-> Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
Coin
deposit <- SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
-> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
let unRegDepositTxCert :: TxCert era
unRegDepositTxCert = Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
stakingC Coin
deposit
TxCert era -> TxIn -> ImpM (LedgerSpec era) ()
forall {era}.
(Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
Eq (Event (EraRule "LEDGER" era)),
NFData (Event (EraRule "TICK" era)),
NFData (Event (EraRule "LEDGER" era)),
Typeable (Event (EraRule "TICK" era)),
Typeable (Event (EraRule "LEDGER" era)),
ToExpr (Event (EraRule "TICK" era)),
ToExpr (Event (EraRule "LEDGER" era))) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
unRegDepositTxCert
(TxIn -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(KeyHash 'StakePool
_poolKH, PaymentCredential
_spendingC, Credential 'Staking
stakingC) <- Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
setupPoolWithStake (Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking))
-> Coin
-> ImpTestM
era (KeyHash 'StakePool, PaymentCredential, Credential 'Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
Coin
deposit <- SimpleGetter (NewEpochState era) Coin -> ImpM (LedgerSpec era) Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin)
-> SimpleGetter (NewEpochState era) Coin
-> ImpM (LedgerSpec era) Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
-> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
let unRegDepositTxCert :: TxCert era
unRegDepositTxCert = Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
stakingC Coin
deposit
TxCert era -> TxIn -> ImpM (LedgerSpec era) ()
forall {era}.
(Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
ShelleyEraImp era, Eq (Event (EraRule "TICK" era)),
Eq (Event (EraRule "LEDGER" era)),
NFData (Event (EraRule "TICK" era)),
NFData (Event (EraRule "LEDGER" era)),
Typeable (Event (EraRule "TICK" era)),
Typeable (Event (EraRule "LEDGER" era)),
ToExpr (Event (EraRule "TICK" era)),
ToExpr (Event (EraRule "LEDGER" era))) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateTranslated TxCert era
unRegDepositTxCert
(TxIn -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptHash -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript (Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Unsupported" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
let testCertificateNotSupportedV1 :: TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
badCert =
TxCert era -> TxIn -> ImpM (LedgerSpec era) ()
forall {rule :: Symbol} {era} {era}.
(PredicateFailure (EraRule "LEDGER" era)
~ PredicateFailure (EraRule rule era),
Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
ShelleyEraImp era,
InjectRuleFailure rule AlonzoUtxosPredFailure era,
Inject (ConwayContextError era) (ContextError era),
EncCBOR (PredicateFailure (EraRule rule era)),
DecCBOR (PredicateFailure (EraRule rule era)),
Show (PredicateFailure (EraRule rule era)),
Eq (PredicateFailure (EraRule rule era)),
Eq (Event (EraRule "TICK" era)), Eq (Event (EraRule "LEDGER" era)),
NFData (PredicateFailure (EraRule rule era)),
NFData (Event (EraRule "TICK" era)),
NFData (Event (EraRule "LEDGER" era)),
Typeable (Event (EraRule "TICK" era)),
Typeable (Event (EraRule "LEDGER" era)),
ToExpr (Event (EraRule "TICK" era)),
ToExpr (Event (EraRule "LEDGER" era)),
ToExpr (PredicateFailure (EraRule rule era))) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateNotSupported TxCert era
badCert
(TxIn -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era (Plutus 'PlutusV1 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV1 -> ScriptHash) -> Plutus 'PlutusV1 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV1 -> Plutus 'PlutusV1
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1)
testCertificateNotSupportedV2 :: TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
badCert =
TxCert era -> TxIn -> ImpM (LedgerSpec era) ()
forall {rule :: Symbol} {era} {era}.
(PredicateFailure (EraRule "LEDGER" era)
~ PredicateFailure (EraRule rule era),
Assert
(OrdCond
(CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
(TypeError ...),
Assert
(OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
(TypeError ...),
ShelleyEraImp era,
InjectRuleFailure rule AlonzoUtxosPredFailure era,
Inject (ConwayContextError era) (ContextError era),
EncCBOR (PredicateFailure (EraRule rule era)),
DecCBOR (PredicateFailure (EraRule rule era)),
Show (PredicateFailure (EraRule rule era)),
Eq (PredicateFailure (EraRule rule era)),
Eq (Event (EraRule "TICK" era)), Eq (Event (EraRule "LEDGER" era)),
NFData (PredicateFailure (EraRule rule era)),
NFData (Event (EraRule "TICK" era)),
NFData (Event (EraRule "LEDGER" era)),
Typeable (Event (EraRule "TICK" era)),
Typeable (Event (EraRule "LEDGER" era)),
ToExpr (Event (EraRule "TICK" era)),
ToExpr (Event (EraRule "LEDGER" era)),
ToExpr (PredicateFailure (EraRule rule era))) =>
TxCert era -> TxIn -> ImpTestM era ()
testCertificateNotSupported TxCert era
badCert
(TxIn -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era (Plutus 'PlutusV2 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV2 -> ScriptHash) -> Plutus 'PlutusV2 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV2 -> Plutus 'PlutusV2
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV2
SPlutusV2)
testCertificateNotSupported :: TxCert era -> TxIn -> ImpTestM era ()
testCertificateNotSupported TxCert era
badCert TxIn
txIn = do
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
( TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx era -> Identity (Tx era))
-> StrictSeq (TxCert era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxCert era -> StrictSeq (TxCert era)
forall a. a -> StrictSeq a
SSeq.singleton TxCert era
badCert
)
( PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
AlonzoUtxosPredFailure era -> EraRuleFailure rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
[CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors
[ ContextError era -> CollectError era
forall era. ContextError era -> CollectError era
BadTranslation (ContextError era -> CollectError era)
-> ContextError era -> CollectError era
forall a b. (a -> b) -> a -> b
$
ConwayContextError era -> ContextError era
forall t s. Inject t s => t -> s
inject (ConwayContextError era -> ContextError era)
-> ConwayContextError era -> ContextError era
forall a b. (a -> b) -> a -> b
$
TxCert era -> ConwayContextError era
forall era. TxCert era -> ConwayContextError era
CertificateNotSupported TxCert era
badCert
]
)
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DelegTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drep, Credential 'Staking
delegator, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
let delegTxCert :: TxCert era
delegTxCert =
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> TxCert era
DelegTxCert @era
Credential 'Staking
delegator
(DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
delegTxCert
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drep, Credential 'Staking
delegator, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
let delegTxCert :: TxCert era
delegTxCert =
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> TxCert era
DelegTxCert @era
Credential 'Staking
delegator
(DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
delegTxCert
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RegDepositDelegTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
KeyHash 'Staking
unregisteredDelegatorKH <- ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
let regDepositDelegTxCert :: TxCert era
regDepositDelegTxCert =
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert @era
(KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
unregisteredDelegatorKH)
(DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
(PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL)
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
regDepositDelegTxCert
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
KeyHash 'Staking
unregisteredDelegatorKH <- ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
let regDepositDelegTxCert :: TxCert era
regDepositDelegTxCert =
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Delegatee -> Coin -> TxCert era
RegDepositDelegTxCert @era
(KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
unregisteredDelegatorKH)
(DRep -> Delegatee
DelegVote (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep))
(PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL)
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
regDepositDelegTxCert
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AuthCommitteeHotKeyTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Credential 'ColdCommitteeRole
coldKey <- [Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> (Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole])
-> Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
Credential 'HotCommitteeRole
hotKey <- KeyHash 'HotCommitteeRole -> Credential 'HotCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'HotCommitteeRole -> Credential 'HotCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash 'HotCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'HotCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'HotCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
let authCommitteeHotKeyTxCert :: TxCert era
authCommitteeHotKeyTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole
-> Credential 'HotCommitteeRole -> TxCert era
AuthCommitteeHotKeyTxCert @era Credential 'ColdCommitteeRole
coldKey Credential 'HotCommitteeRole
hotKey
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
authCommitteeHotKeyTxCert
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Credential 'ColdCommitteeRole
coldKey <- [Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> (Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole])
-> Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
Credential 'HotCommitteeRole
hotKey <- KeyHash 'HotCommitteeRole -> Credential 'HotCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'HotCommitteeRole -> Credential 'HotCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash 'HotCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'HotCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'HotCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
let authCommitteeHotKeyTxCert :: TxCert era
authCommitteeHotKeyTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole
-> Credential 'HotCommitteeRole -> TxCert era
AuthCommitteeHotKeyTxCert @era Credential 'ColdCommitteeRole
coldKey Credential 'HotCommitteeRole
hotKey
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
authCommitteeHotKeyTxCert
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ResignCommitteeColdTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Credential 'ColdCommitteeRole
coldKey <- [Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> (Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole])
-> Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
let resignCommitteeColdTxCert :: TxCert era
resignCommitteeColdTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole -> StrictMaybe Anchor -> TxCert era
ResignCommitteeColdTxCert @era Credential 'ColdCommitteeRole
coldKey StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
resignCommitteeColdTxCert
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
Credential 'ColdCommitteeRole
coldKey <- [Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a. MonadGen m => [a] -> m a
elements ([Credential 'ColdCommitteeRole]
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> (Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole])
-> Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential 'ColdCommitteeRole)
-> [Credential 'ColdCommitteeRole]
forall a. Set a -> [a]
Set.toList (Set (Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (Set (Credential 'ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole))
getCommitteeMembers
let resignCommitteeColdTxCert :: TxCert era
resignCommitteeColdTxCert = forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole -> StrictMaybe Anchor -> TxCert era
ResignCommitteeColdTxCert @era Credential 'ColdCommitteeRole
coldKey StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
resignCommitteeColdTxCert
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RegDRepTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
KeyHash 'DRepRole
unregisteredDRepKH <- ImpM (LedgerSpec era) (KeyHash 'DRepRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 (TxCert era -> ImpM (LedgerSpec era) ())
-> TxCert era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
RegDRepTxCert @era (KeyHash 'DRepRole -> Credential 'DRepRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
unregisteredDRepKH) (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL) StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
KeyHash 'DRepRole
unregisteredDRepKH <- ImpM (LedgerSpec era) (KeyHash 'DRepRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 (TxCert era -> ImpM (LedgerSpec era) ())
-> TxCert era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> StrictMaybe Anchor -> TxCert era
RegDRepTxCert @era (KeyHash 'DRepRole -> Credential 'DRepRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'DRepRole
unregisteredDRepKH) (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL) StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UnRegDRepTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
let unRegDRepTxCert :: TxCert era
unRegDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> TxCert era
UnRegDRepTxCert @era Credential 'DRepRole
drepKH (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL)
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
unRegDRepTxCert
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
PParams era
pp <- SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era))
-> SimpleGetter (NewEpochState era) (PParams era)
-> ImpTestM era (PParams era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> (PParams era -> Const r (PParams era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
let unRegDRepTxCert :: TxCert era
unRegDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> Coin -> TxCert era
UnRegDRepTxCert @era Credential 'DRepRole
drepKH (PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppDRepDepositL)
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV2 TxCert era
unRegDRepTxCert
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UpdateDRepTxCert" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V1" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
let updateDRepTxCert :: TxCert era
updateDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> StrictMaybe Anchor -> TxCert era
UpdateDRepTxCert @era Credential 'DRepRole
drepKH StrictMaybe Anchor
forall a. StrictMaybe a
SNothing
TxCert era -> ImpM (LedgerSpec era) ()
testCertificateNotSupportedV1 TxCert era
updateDRepTxCert
String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"V2" (ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
(Credential 'DRepRole
drepKH, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
let updateDRepTxCert :: TxCert era
updateDRepTxCert = forall era.
ConwayEraTxCert era =>
Credential 'DRepRole -> StrictMaybe Anchor -> TxCert era
UpdateDRepTxCert @era Credential 'DRepRole
drepKH StrictMaybe Anchor
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
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Gov policy scripts" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"failing native script govPolicy" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
(Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
ScriptHash
scriptHash <- NativeScript era -> ImpTestM era ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (NativeScript era -> ImpTestM era ScriptHash)
-> NativeScript era -> ImpTestM era ScriptHash
forall a b. (a -> b) -> a -> b
$ SlotNo -> NativeScript era
forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (Word64 -> SlotNo
SlotNo Word64
1)
Anchor
anchor <- ImpM (LedgerSpec era) Anchor
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
ImpM (LedgerSpec era) GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) GovActionId -> ImpTestM era ())
-> ImpM (LedgerSpec era) GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpM (LedgerSpec era) GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. StrictMaybe a
SNothing (Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"ParameterChange" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Natural -> Identity (StrictMaybe Natural))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCommitteeMinSizeL ((StrictMaybe Natural -> Identity (StrictMaybe Natural))
-> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Natural -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> StrictMaybe Natural
forall a. a -> StrictMaybe a
SJust Natural
1
let govAction :: GovAction era
govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)
ProposalProcedure era
proposal <- GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
let tx :: Tx era
tx =
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era))
-> (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era -> Identity (Tx era))
-> OSet (ProposalProcedure era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((ValidityInterval -> Identity ValidityInterval)
-> TxBody era -> Identity (TxBody era))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody era -> Identity (TxBody era)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
-> Tx era -> Identity (Tx era))
-> ValidityInterval -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]]
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"TreasuryWithdrawals" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
RewardAccount
rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
let withdrawals :: Map RewardAccount Coin
withdrawals = [(RewardAccount, Coin)] -> Map RewardAccount Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1000)]
let govAction :: GovAction era
govAction = Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map RewardAccount Coin
withdrawals (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
scriptHash)
ProposalProcedure era
proposal <- GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
let tx :: Tx era
tx =
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era))
-> (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era -> Identity (Tx era))
-> OSet (ProposalProcedure era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((ValidityInterval -> Identity ValidityInterval)
-> TxBody era -> Identity (TxBody era))
-> (ValidityInterval -> Identity ValidityInterval)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Identity ValidityInterval)
-> TxBody era -> Identity (TxBody era)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody era) ValidityInterval
vldtTxBodyL ((ValidityInterval -> Identity ValidityInterval)
-> Tx era -> Identity (Tx era))
-> ValidityInterval -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing StrictMaybe SlotNo
forall a. StrictMaybe a
SNothing
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set ScriptHash -> ShelleyUtxowPredFailure era
forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW [Item (Set ScriptHash)
ScriptHash
scriptHash]]
String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"alwaysSucceeds Plutus govPolicy validates" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
let alwaysSucceedsSh :: ScriptHash
alwaysSucceedsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
(Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
Anchor
anchor <- ImpM (LedgerSpec era) Anchor
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
ImpM (LedgerSpec era) GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) GovActionId -> ImpTestM era ())
-> ImpM (LedgerSpec era) GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpM (LedgerSpec era) GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. StrictMaybe a
SNothing
(Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh))
Credential 'DRepRole
dRep
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
RewardAccount
rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"ParameterChange" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Natural -> Identity (StrictMaybe Natural))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCommitteeMinSizeL ((StrictMaybe Natural -> Identity (StrictMaybe Natural))
-> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Natural -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> StrictMaybe Natural
forall a. a -> StrictMaybe a
SJust Natural
1
let govAction :: GovAction era
govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)
GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction ImpTestM era (ProposalProcedure era)
-> (ProposalProcedure era -> ImpTestM era ()) -> ImpTestM era ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProposalProcedure era -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era ()
submitProposal_
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"TreasuryWithdrawals" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
let withdrawals :: Map RewardAccount Coin
withdrawals = [(RewardAccount, Coin)] -> Map RewardAccount Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1000)]
let govAction :: GovAction era
govAction = Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map RewardAccount Coin
withdrawals (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)
GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction ImpTestM era (ProposalProcedure era)
-> (ProposalProcedure era -> ImpTestM era ()) -> ImpTestM era ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProposalProcedure era -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era ()
submitProposal_
String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"alwaysFails Plutus govPolicy does not validate" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
let alwaysFailsSh :: ScriptHash
alwaysFailsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3)
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
(Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
Anchor
anchor <- ImpM (LedgerSpec era) Anchor
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
ImpM (LedgerSpec era) GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) GovActionId -> ImpTestM era ())
-> ImpM (LedgerSpec era) GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpM (LedgerSpec era) GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. StrictMaybe a
SNothing (Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"ParameterChange" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Natural -> Identity (StrictMaybe Natural))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Natural)
Lens' (PParamsUpdate era) (StrictMaybe Natural)
ppuCommitteeMinSizeL ((StrictMaybe Natural -> Identity (StrictMaybe Natural))
-> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Natural -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> StrictMaybe Natural
forall a. a -> StrictMaybe a
SJust Natural
1
let govAction :: GovAction era
govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
ProposalProcedure era
proposal <- GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era))
-> (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era -> Identity (Tx era))
-> OSet (ProposalProcedure era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
Tx era -> ImpTestM era ()
forall era.
(HasCallStack, AlonzoEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ Tx era
tx
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"TreasuryWithdrawals" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
RewardAccount
rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
let withdrawals :: Map RewardAccount Coin
withdrawals = [(RewardAccount, Coin)] -> Map RewardAccount Coin
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1000)]
let govAction :: GovAction era
govAction = Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
forall era.
Map RewardAccount Coin -> StrictMaybe ScriptHash -> GovAction era
TreasuryWithdrawals Map RewardAccount Coin
withdrawals (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
ProposalProcedure era
proposal <- GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era))
-> (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era -> Identity (Tx era))
-> OSet (ProposalProcedure era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
Tx era -> ImpTestM era ()
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 =
String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"PlutusV3 Initialization" (SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels with alwaysFails govPolicy does not validate" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
(PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV1 .. Item [Language]
Language
PlutusV2]
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
(Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
Anchor
anchor <- ImpM (LedgerSpec era) Anchor
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
GovActionId
govIdConstitution1 <-
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. StrictMaybe a
SNothing (Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor StrictMaybe ScriptHash
forall a. StrictMaybe a
SNothing) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
GovPurposeId 'PParamUpdatePurpose
govIdPPUpdate1 <-
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
enactCostModels StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing (HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV3]) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
let alwaysFailsSh :: ScriptHash
alwaysFailsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsNoDatum SLanguage 'PlutusV3
SPlutusV3)
ImpTestM era GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era GovActionId -> ImpTestM era ())
-> ImpTestM era GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
(GovPurposeId 'ConstitutionPurpose
-> StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'ConstitutionPurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govIdConstitution1))
(Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh))
Credential 'DRepRole
dRep
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Fail to update V3 Costmodels" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL ((StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe CostModels -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels -> StrictMaybe CostModels
forall a. a -> StrictMaybe a
SJust (HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV3])
let govAction :: GovAction era
govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange (GovPurposeId 'PParamUpdatePurpose
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. a -> StrictMaybe a
SJust GovPurposeId 'PParamUpdatePurpose
govIdPPUpdate1) PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysFailsSh)
ProposalProcedure era
proposal <- GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
govAction
let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era))
-> (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> TxBody era -> Identity (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL ((OSet (ProposalProcedure era)
-> Identity (OSet (ProposalProcedure era)))
-> Tx era -> Identity (Tx era))
-> OSet (ProposalProcedure era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal]
Tx era -> ImpTestM era ()
forall era.
(HasCallStack, AlonzoEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era) =>
Tx era -> ImpTestM era ()
submitPhase2Invalid_ Tx era
tx
String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels with alwaysSucceeds govPolicy but no PlutusV3 CostModels fails" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$
ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
(PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV1 .. Item [Language]
Language
PlutusV2]
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
(Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000
Anchor
anchor <- ImpM (LedgerSpec era) Anchor
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
let alwaysSucceedsSh :: ScriptHash
alwaysSucceedsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
ImpTestM era GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era GovActionId -> ImpTestM era ())
-> ImpTestM era GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. StrictMaybe a
SNothing
(Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh))
Credential 'DRepRole
dRep
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL ((StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe CostModels -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels -> StrictMaybe CostModels
forall a. a -> StrictMaybe a
SJust (HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV3])
let govAction :: GovAction era
govAction = StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> PParamsUpdate era -> StrictMaybe ScriptHash -> GovAction era
ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing PParamsUpdate era
pparamsUpdate (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh)
GovAction era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingGovAction GovAction era
govAction [AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ [CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [Language -> CollectError era
forall era. Language -> CollectError era
NoCostModel Language
PlutusV3]]
String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Updating CostModels and setting the govPolicy afterwards succeeds" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
(PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
-> PParams era -> Identity (PParams era))
-> CostModels -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV1 .. Item [Language]
Language
PlutusV2]
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
(Credential 'DRepRole
dRep, Credential 'Staking
_, KeyPair 'Payment
_) <- Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000_000
Anchor
anchor <- ImpM (LedgerSpec era) Anchor
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
GovActionId
govIdConstitution1 <-
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. StrictMaybe a
SNothing (Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor StrictMaybe ScriptHash
forall a. StrictMaybe a
SNothing) Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
Tx era
mintingTokenTx <- ScriptHash -> ImpM (LedgerSpec era) (Tx era)
forall era. MaryEraImp era => ScriptHash -> ImpTestM era (Tx era)
mkTokenMintingTx (ScriptHash -> ImpM (LedgerSpec era) (Tx era))
-> ScriptHash -> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$ Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage 'PlutusV3
SPlutusV3)
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Minting token fails" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
mintingTokenTx [AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ [CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [Language -> CollectError era
forall era. Language -> CollectError era
NoCostModel Language
PlutusV3]]
GovPurposeId 'PParamUpdatePurpose
govIdPPUpdate1 <-
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
enactCostModels
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. StrictMaybe a
SNothing
(HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV3])
Credential 'DRepRole
dRep
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
let alwaysSucceedsSh :: ScriptHash
alwaysSucceedsSh = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3)
ImpTestM era GovActionId -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era GovActionId -> ImpTestM era ())
-> ImpTestM era GovActionId -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> Constitution era
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era GovActionId
enactConstitution
(GovPurposeId 'ConstitutionPurpose
-> StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'ConstitutionPurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govIdConstitution1))
(Anchor -> StrictMaybe ScriptHash -> Constitution era
forall era. Anchor -> StrictMaybe ScriptHash -> Constitution era
Constitution Anchor
anchor (ScriptHash -> StrictMaybe ScriptHash
forall a. a -> StrictMaybe a
SJust ScriptHash
alwaysSucceedsSh))
Credential 'DRepRole
dRep
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Minting token succeeds" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
Tx era -> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
mintingTokenTx
String -> ImpTestM era () -> ImpTestM era ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Updating CostModels succeeds" (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
ImpTestM era (GovPurposeId 'PParamUpdatePurpose) -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
-> ImpTestM era ())
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
-> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
enactCostModels
(GovPurposeId 'PParamUpdatePurpose
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. a -> StrictMaybe a
SJust GovPurposeId 'PParamUpdatePurpose
govIdPPUpdate1)
(HasCallStack => [Language] -> CostModels
[Language] -> CostModels
testingCostModels [Item [Language]
Language
PlutusV3])
Credential 'DRepRole
dRep
NonEmpty (Credential 'HotCommitteeRole)
committeeMembers'
scriptLockedTxOut ::
forall era.
AlonzoEraTxOut era =>
ScriptHash ->
TxOut era
scriptLockedTxOut :: forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending =
Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut
(ScriptHash -> StakeReference -> Addr
forall p s.
(MakeCredential p 'Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr ScriptHash
shSpending StakeReference
StakeRefNull)
Value era
forall a. Monoid a => a
mempty
TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era)
forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL ((StrictMaybe DataHash -> Identity (StrictMaybe DataHash))
-> TxOut era -> Identity (TxOut era))
-> StrictMaybe DataHash -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (forall era. Data era -> DataHash
hashData @era (Data era -> DataHash) -> Data era -> DataHash
forall a b. (a -> b) -> a -> b
$ Data -> Data era
forall era. Era era => Data -> Data era
Data Data
spendDatum)
mkRefTxOut ::
( BabbageEraTxOut era
, AlonzoEraImp era
) =>
ScriptHash ->
ImpTestM era (TxOut era)
mkRefTxOut :: forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
sh = do
Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
let mbyPlutusScript :: Maybe (PlutusScript era)
mbyPlutusScript = ScriptHash -> Maybe (PlutusScript era)
forall era.
AlonzoEraImp era =>
ScriptHash -> Maybe (PlutusScript era)
impLookupPlutusScript ScriptHash
sh
TxOut era -> ImpTestM era (TxOut era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut era -> ImpTestM era (TxOut era))
-> TxOut era -> ImpTestM era (TxOut era)
forall a b. (a -> b) -> a -> b
$
Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
forall a. Monoid a => a
mempty
TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era)
forall era.
BabbageEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (Script era))
Lens' (TxOut era) (StrictMaybe (Script era))
referenceScriptTxOutL ((StrictMaybe (Script era) -> Identity (StrictMaybe (Script era)))
-> TxOut era -> Identity (TxOut era))
-> StrictMaybe (Script era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Script era) -> StrictMaybe (Script era)
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript (PlutusScript era -> Script era)
-> Maybe (PlutusScript era) -> Maybe (Script era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PlutusScript era)
mbyPlutusScript)
setupRefTx ::
forall era l.
( BabbageEraTxOut era
, AlonzoEraImp era
, PlutusLanguage l
) =>
SLanguage l ->
ImpTestM era TxId
setupRefTx :: forall era (l :: Language).
(BabbageEraTxOut era, AlonzoEraImp era, PlutusLanguage l) =>
SLanguage l -> ImpTestM era TxId
setupRefTx SLanguage l
lang = do
let shSpending :: ScriptHash
shSpending = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l
forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage l
lang)
TxOut era
refTxOut <- ScriptHash -> ImpM (LedgerSpec era) (TxOut era)
forall era.
(BabbageEraTxOut era, AlonzoEraImp era) =>
ScriptHash -> ImpTestM era (TxOut era)
mkRefTxOut ScriptHash
shSpending
(Tx era -> TxId)
-> ImpM (LedgerSpec era) (Tx era) -> ImpTestM era TxId
forall a b.
(a -> b) -> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tx era -> TxId
forall era. EraTx era => Tx era -> TxId
txIdTx (ImpM (LedgerSpec era) (Tx era) -> ImpTestM era TxId)
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> Tx era
-> ImpTestM era TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx era -> ImpTestM era (Tx era)
submitTxAnn String
"Producing transaction" (Tx era -> ImpTestM era TxId) -> Tx era -> ImpTestM era TxId
forall a b. (a -> b) -> a -> b
$
TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era))
-> (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL
((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> Tx era -> Identity (Tx era))
-> StrictSeq (TxOut era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxOut era] -> StrictSeq (TxOut era)
forall a. [a] -> StrictSeq a
SSeq.fromList
[ Item [TxOut era]
TxOut era
refTxOut
, ScriptHash -> TxOut era
forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending
, ScriptHash -> TxOut era
forall era. AlonzoEraTxOut era => ScriptHash -> TxOut era
scriptLockedTxOut ScriptHash
shSpending
]
testPlutusV1V2Failure ::
forall era a.
( ConwayEraImp era
, InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
, HasCallStack
) =>
ScriptHash ->
a ->
Lens' (TxBody era) a ->
ContextError era ->
ImpTestM era ()
testPlutusV1V2Failure :: forall era a.
(ConwayEraImp era,
InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era,
HasCallStack) =>
ScriptHash
-> a -> Lens' (TxBody era) a -> ContextError era -> ImpTestM era ()
testPlutusV1V2Failure ScriptHash
sh a
badField Lens' (TxBody era) a
lenz ContextError era
errorField = do
TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
ScriptHash -> ImpTestM era TxIn
produceScript @era ScriptHash
sh
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
( TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn)) -> Tx era -> Identity (Tx era))
-> Set TxIn -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn
Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era))
-> ((a -> Identity a) -> TxBody era -> Identity (TxBody era))
-> (a -> Identity a)
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> TxBody era -> Identity (TxBody era)
Lens' (TxBody era) a
lenz ((a -> Identity a) -> Tx era -> Identity (Tx era))
-> a -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ a
badField
)
( PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PredicateFailure (EraRule "LEDGER" era)
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoUtxosPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
AlonzoUtxosPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> AlonzoUtxosPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
[CollectError era] -> AlonzoUtxosPredFailure era
forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [ContextError era -> CollectError era
forall era. ContextError era -> CollectError era
BadTranslation ContextError era
errorField]
)
enactCostModels ::
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose) ->
CostModels ->
Credential 'DRepRole ->
NonEmpty (Credential 'HotCommitteeRole) ->
ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
enactCostModels :: forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> CostModels
-> Credential 'DRepRole
-> NonEmpty (Credential 'HotCommitteeRole)
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
enactCostModels StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
prevGovId CostModels
cms Credential 'DRepRole
dRep NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' = do
CostModels
initialCms <- SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels)
-> SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((CostModels -> Const r CostModels)
-> EpochState era -> Const r (EpochState era))
-> (CostModels -> Const r CostModels)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((CostModels -> Const r CostModels)
-> PParams era -> Const r (PParams era))
-> (CostModels -> Const r CostModels)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CostModels -> Const r CostModels)
-> PParams era -> Const r (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL
let pparamsUpdate :: PParamsUpdate era
pparamsUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
AlonzoEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
Lens' (PParamsUpdate era) (StrictMaybe CostModels)
ppuCostModelsL ((StrictMaybe CostModels -> Identity (StrictMaybe CostModels))
-> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe CostModels -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CostModels -> StrictMaybe CostModels
forall a. a -> StrictMaybe a
SJust CostModels
cms
GovActionId
govId <- StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era GovActionId
submitParameterChange (GovPurposeId 'PParamUpdatePurpose -> GovActionId
forall (p :: GovActionPurpose). GovPurposeId p -> GovActionId
unGovPurposeId (GovPurposeId 'PParamUpdatePurpose -> GovActionId)
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> StrictMaybe GovActionId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
prevGovId) PParamsUpdate era
pparamsUpdate
Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential 'DRepRole -> Voter
DRepVoter Credential 'DRepRole
dRep) GovActionId
govId
NonEmpty (Credential 'HotCommitteeRole)
-> GovActionId -> ImpTestM era ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole)
committeeMembers' GovActionId
govId
Natural -> ImpTestM era ()
forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
CostModels
enactedCms <- SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels)
-> SimpleGetter (NewEpochState era) CostModels
-> ImpTestM era CostModels
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era))
-> ((CostModels -> Const r CostModels)
-> EpochState era -> Const r (EpochState era))
-> (CostModels -> Const r CostModels)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era))
-> ((CostModels -> Const r CostModels)
-> PParams era -> Const r (PParams era))
-> (CostModels -> Const r CostModels)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CostModels -> Const r CostModels)
-> PParams era -> Const r (PParams era)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams era) CostModels
ppCostModelsL
CostModels
enactedCms CostModels -> CostModels -> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` (CostModels
initialCms CostModels -> CostModels -> CostModels
forall a. Semigroup a => a -> a -> a
<> CostModels
cms)
GovPurposeId 'PParamUpdatePurpose
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GovPurposeId 'PParamUpdatePurpose
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose))
-> GovPurposeId 'PParamUpdatePurpose
-> ImpTestM era (GovPurposeId 'PParamUpdatePurpose)
forall a b. (a -> b) -> a -> b
$ GovActionId -> GovPurposeId 'PParamUpdatePurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govId
spendDatum :: P1.Data
spendDatum :: Data
spendDatum = Integer -> Data
P1.I Integer
3