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

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

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.Rules (
  ConwayLedgerPredFailure (..),
  ConwayUtxoPredFailure (BadInputsUTxO),
  maxRefScriptSizePerTx,
 )
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), ApplyTxError (..), applyTx, mkMempoolEnv)
import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
import Cardano.Ledger.Shelley.LedgerState
import Control.Monad.Reader (asks)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.Exts (fromList)
import Lens.Micro ((&), (.~), (<>~), (^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysSucceedsNoDatum,
  purposeIsWellformedNoDatum,
 )

spec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
  , InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era
  , ApplyTx era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era,
 InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era,
 ApplyTx era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TxRefScriptsSizeTooBig" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- we use here the largest script we currently have as many times as necessary to
    -- trigger the predicate failure
    Just PlutusScript era
plutusScript <- Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (Maybe (PlutusScript era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PlutusScript era)
 -> ImpM (LedgerSpec era) (Maybe (PlutusScript era)))
-> Maybe (PlutusScript era)
-> ImpM (LedgerSpec era) (Maybe (PlutusScript era))
forall a b. (a -> b) -> a -> b
$ forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript @era (Plutus 'PlutusV3 -> Maybe (PlutusScript era))
-> Plutus 'PlutusV3 -> Maybe (PlutusScript era)
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage 'PlutusV3
SPlutusV3
    let script :: Script era
        script :: Script era
script = PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
plutusScript
        size :: Int
size = AlonzoScript era -> Int
forall t. SafeToHash t => t -> Int
originalBytesSize Script era
AlonzoScript era
script
        n :: Int
n = Int
maxRefScriptSizePerTx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    [TxIn]
txIns <- Int -> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Script era -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era TxIn
produceRefScript Script era
script)
    let tx :: Tx era
        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. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL ((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
.~ [TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
txIns)
    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
      [ ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
          Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure era
forall era. Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure era
ConwayTxRefScriptsSizeTooBig (Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure era)
-> Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure era
forall a b. (a -> b) -> a -> b
$
            Mismatch
              { mismatchSupplied :: Int
mismatchSupplied = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n
              , mismatchExpected :: Int
mismatchExpected = Int
maxRefScriptSizePerTx
              }
      ]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from delegated and non-delegated staking key" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
    KeyHash 'Staking
kh <- ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- Credential 'Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    Credential 'Staking -> ImpM (LedgerSpec era) ()
forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    let tx :: Tx era
tx = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$ TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, Coin
reward)]

    ProtVer
pv <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    if ProtVer -> Bool
HF.bootstrapPhase ProtVer
pv
      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
          [ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era
forall era.
NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [Item (NonEmpty (KeyHash 'Staking))
KeyHash 'Staking
kh]]
    KeyPair 'Payment
_ <- Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) DRep
DRepAlwaysAbstain
    Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
            ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
              [(RewardAccount
ra, if ProtVer -> Bool
HF.bootstrapPhase ProtVer
pv then Coin
forall a. Monoid a => a
mempty else Coin
reward)]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from a key delegated to an unregistered DRep" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
    KeyHash 'Staking
kh <- ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- Credential 'Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    Credential 'Staking -> ImpM (LedgerSpec era) ()
forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (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

    KeyPair 'Payment
_ <- Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    Credential 'DRepRole -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era ()
unRegisterDRep Credential 'DRepRole
drep
    Credential 'DRepRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era ()
expectDRepNotRegistered Credential 'DRepRole
drep
    let tx :: Tx era
tx =
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
            TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
              TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
                ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
                  [(RewardAccount
ra, Coin
reward)]
    ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap (Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
forall a. Monoid a => a
mempty)) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
      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 [ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era
forall era.
NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [Item (NonEmpty (KeyHash 'Staking))
KeyHash 'Staking
kh]]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw and unregister staking credential in the same transaction" (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
refund <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM 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
    KeyHash 'Staking
kh <- ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- Credential 'Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    Positive Integer
newDeposit <- ImpM (LedgerSpec era) (Positive Integer)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
newDeposit

    Credential 'Staking -> ImpM (LedgerSpec era) ()
forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (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

    KeyPair 'Payment
_ <- Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    let tx :: Tx era
tx =
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
            TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
              TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> TxBody era -> Identity (TxBody era))
-> StrictSeq (TxCert era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Credential 'Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
cred Coin
refund]
              TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& ((Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, Coin
reward)])
    Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from a key delegated to an expired DRep" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
4
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppDRepActivityL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
1
    KeyHash 'Staking
kh <- ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- Credential 'Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    Credential 'Staking -> ImpM (LedgerSpec era) ()
forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (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

    -- expire the drep before delegation
    StrictMaybe GovActionId -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing ImpTestM era (GovAction era)
-> (GovAction era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec 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
>>= GovAction era -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_
    Natural -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
4
    Credential 'DRepRole -> ImpTestM era Bool
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era Bool
isDRepExpired Credential 'DRepRole
drep ImpTestM era Bool -> Bool -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Bool
True

    KeyPair 'Payment
_ <- Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
            ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
              [(RewardAccount
ra, Coin
reward)]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from a key delegated to a DRep that expired after delegation" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
4
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppDRepActivityL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
1
    KeyHash 'Staking
kh <- ImpM (LedgerSpec era) (KeyHash 'Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = KeyHash 'Staking -> Credential 'Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- Credential 'Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    Credential 'Staking -> ImpM (LedgerSpec era) ()
forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (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

    KeyPair 'Payment
_ <- Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    -- expire the drep after delegation
    StrictMaybe GovActionId -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing ImpTestM era (GovAction era)
-> (GovAction era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec 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
>>= GovAction era -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_

    Natural -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
4
    Credential 'DRepRole -> ImpTestM era Bool
forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era Bool
isDRepExpired Credential 'DRepRole
drep ImpTestM era Bool -> Bool -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Bool
True

    Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
          TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
            ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
              [(RewardAccount
ra, Coin
reward)]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from delegated and non-delegated staking script" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
    let scriptHash :: ScriptHash
scriptHash = Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ScriptHash) -> Plutus 'PlutusV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3
    let cred :: Credential kr
cred = ScriptHash -> Credential kr
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash
    RewardAccount
ra <- Credential 'Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
forall {kr :: KeyRole}. Credential kr
cred
    Credential 'Staking -> ImpM (LedgerSpec era) ()
forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
forall {kr :: KeyRole}. Credential kr
cred
    Coin
reward <- Credential 'Staking -> ImpTestM era Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
forall {kr :: KeyRole}. Credential kr
cred

    Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, Coin
reward)]

    KeyPair 'Payment
_ <- Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
forall {kr :: KeyRole}. Credential kr
cred (Integer -> Coin
Coin Integer
1_000_000) DRep
DRepAlwaysAbstain
    Tx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ (Tx era -> ImpM (LedgerSpec era) ())
-> Tx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
      TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
        TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Withdrawals -> Identity Withdrawals)
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL ((Withdrawals -> Identity Withdrawals)
 -> TxBody era -> Identity (TxBody era))
-> Withdrawals -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, Coin
forall a. Monoid a => a
mempty)]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Mempool" (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
      submitFailingMempoolTx :: String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) (Tx era)
submitFailingMempoolTx String
cause Tx era
tx NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures = do
        Globals
globals <- Getting Globals (ImpTestState era) Globals
-> ImpM (LedgerSpec era) Globals
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Globals (ImpTestState era) Globals
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL
        NewEpochState era
nes <- Getting (NewEpochState era) (ImpTestState era) (NewEpochState era)
-> ImpM (LedgerSpec era) (NewEpochState era)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (NewEpochState era) (ImpTestState era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(NewEpochState era -> f (NewEpochState era))
-> ImpTestState era -> f (ImpTestState era)
impNESL
        SlotNo
slotNo <- Getting SlotNo (ImpTestState era) SlotNo
-> ImpM (LedgerSpec era) SlotNo
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting SlotNo (ImpTestState era) SlotNo
forall era r. Getting r (ImpTestState era) SlotNo
impLastTickG
        let
          mempoolEnv :: LedgerEnv era
mempoolEnv = NewEpochState era -> SlotNo -> LedgerEnv era
forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv NewEpochState era
nes SlotNo
slotNo
          ls :: LedgerState era
ls = NewEpochState era
nes NewEpochState era
-> Getting (LedgerState era) (NewEpochState era) (LedgerState era)
-> LedgerState era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (LedgerState era) (EpochState era))
-> NewEpochState era -> Const (LedgerState era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (LedgerState era) (EpochState era))
 -> NewEpochState era
 -> Const (LedgerState era) (NewEpochState era))
-> ((LedgerState era -> Const (LedgerState era) (LedgerState era))
    -> EpochState era -> Const (LedgerState era) (EpochState era))
-> Getting (LedgerState era) (NewEpochState era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const (LedgerState era) (LedgerState era))
-> EpochState era -> Const (LedgerState era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL
        Tx era
txFixed <- (Tx era
tx Tx era
-> (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era)
forall a b. a -> (a -> b) -> b
&) ((Tx era -> ImpM (LedgerSpec era) (Tx era))
 -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ImpTestEnv era -> Tx era -> ImpM (LedgerSpec era) (Tx era))
-> ImpM (LedgerSpec era) (Tx era -> ImpM (LedgerSpec era) (Tx era))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ImpTestEnv era -> Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup
        Tx era -> ImpM (LedgerSpec era) ()
forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
txFixed
        case Globals
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> Either (ApplyTxError era) (LedgerState era, Validated (Tx era))
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
applyTx Globals
globals LedgerEnv era
mempoolEnv LedgerState era
ls Tx era
txFixed of
          Left ApplyTxError era
err -> do
            ApplyTxError era
err ApplyTxError era -> ApplyTxError era -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError @era NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures
          Right (LedgerState era, Validated (Tx era))
_ ->
            String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"Expected failure due to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cause String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx era -> String
forall a. Show a => a -> String
show Tx era
txFixed
        Tx era -> ImpM (LedgerSpec era) (Tx era)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
txFixed
      submitFailingMempoolTx_ :: String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
submitFailingMempoolTx_ String
c Tx era
t = ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpM (LedgerSpec era) (Tx era) -> ImpM (LedgerSpec era) ())
-> (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
    -> ImpM (LedgerSpec era) (Tx era))
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) (Tx era)
submitFailingMempoolTx String
c Tx era
t

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Duplicate transactions" (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
        newInput :: ImpM (LedgerSpec era) TxIn
newInput = do
          Addr
addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
          Coin
amount <- Integer -> Coin
Coin (Integer -> Coin)
-> ImpM (LedgerSpec era) Integer -> ImpTestM era Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
2_000_000, Integer
8_000_000)
          Addr -> Coin -> ImpM (LedgerSpec era) TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr Coin
amount

      [TxIn]
inputsCommon <- Int -> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
5 ImpM (LedgerSpec era) TxIn
newInput
      [TxIn]
inputs1 <- Int -> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 ImpM (LedgerSpec era) TxIn
newInput
      [TxIn]
inputs2 <- Int -> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 ImpM (LedgerSpec era) TxIn
newInput

      Tx era
txFinal <-
        Tx era -> ImpM (LedgerSpec era) (Tx era)
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx (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 -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
            TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Item (Set TxIn)] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList ([TxIn]
inputsCommon [TxIn] -> [TxIn] -> [TxIn]
forall a. Semigroup a => a -> a -> a
<> [TxIn]
inputs1)

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Identical transaction" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
submitFailingMempoolTx_ String
"duplicate transaction" Tx era
txFinal (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
 -> ImpM (LedgerSpec era) ())
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
            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)))
-> (Text -> PredicateFailure (EraRule "LEDGER" era))
-> Text
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayLedgerPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era
 -> PredicateFailure (EraRule "LEDGER" era))
-> (Text -> ConwayLedgerPredFailure era)
-> Text
-> PredicateFailure (EraRule "LEDGER" era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ConwayLedgerPredFailure era
forall era. Text -> ConwayLedgerPredFailure era
ConwayMempoolFailure (Text -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> Text -> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
              Text
"All inputs are spent. Transaction has probably already been included"

      String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Overlapping transaction" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
        let txOverlap :: Tx era
txOverlap = TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$ TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody era -> Identity (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody era -> Identity (TxBody era))
-> Set TxIn -> TxBody era -> TxBody era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ [Item (Set TxIn)] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList ([TxIn]
inputsCommon [TxIn] -> [TxIn] -> [TxIn]
forall a. Semigroup a => a -> a -> a
<> [TxIn]
inputs2)
        String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
submitFailingMempoolTx_
          String
"overlapping transaction"
          Tx era
txOverlap
          [ConwayUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayUtxoPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayUtxoPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Set TxIn -> ConwayUtxoPredFailure era
forall era. Set TxIn -> ConwayUtxoPredFailure era
BadInputsUTxO (Set TxIn -> ConwayUtxoPredFailure era)
-> Set TxIn -> ConwayUtxoPredFailure era
forall a b. (a -> b) -> a -> b
$ [Item (Set TxIn)] -> Set TxIn
forall l. IsList l => [Item l] -> l
fromList [Item (Set TxIn)]
[TxIn]
inputsCommon]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Unelected Committee voting" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
      NonEmpty (Credential 'HotCommitteeRole)
_ <- ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      Credential 'ColdCommitteeRole
ccCold <- KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash 'ColdCommitteeRole -> Credential 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential 'ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash 'ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      EpochNo
curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      let action :: GovAction era
action =
            StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
              StrictMaybe (GovPurposeId 'CommitteePurpose era)
forall a. StrictMaybe a
SNothing
              Set (Credential 'ColdCommitteeRole)
forall a. Monoid a => a
mempty
              (Credential 'ColdCommitteeRole
-> EpochNo -> Map (Credential 'ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential 'ColdCommitteeRole
ccCold (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
7)))
              (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
      ProposalProcedure era
proposal <- GovAction era -> ImpTestM era (ProposalProcedure era)
forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
action
      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
& (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)))
 -> TxBody era -> Identity (TxBody era))
-> OSet (ProposalProcedure era) -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OSet (ProposalProcedure era))
ProposalProcedure era
proposal])
      Credential 'HotCommitteeRole
ccHot <- Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
registerCommitteeHotKey Credential 'ColdCommitteeRole
ccCold
      GovActionId
govActionId <- do
        RewardAccount
rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
        [(RewardAccount, Coin)] -> ImpM (LedgerSpec era) GovActionId
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1)]

      let
        tx :: Tx era
tx =
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (TxBody era -> Tx era) -> TxBody era -> Tx era
forall a b. (a -> b) -> a -> b
$
            TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
              TxBody era -> (TxBody era -> TxBody era) -> TxBody era
forall a b. a -> (a -> b) -> b
& (VotingProcedures era -> Identity (VotingProcedures era))
-> TxBody era -> Identity (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
                ((VotingProcedures era -> Identity (VotingProcedures era))
 -> TxBody era -> Identity (TxBody era))
-> VotingProcedures era -> TxBody era -> TxBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                  ( 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
ccHot)
                      (GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
govActionId (Vote -> StrictMaybe Anchor -> VotingProcedure era
forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes StrictMaybe Anchor
forall a. StrictMaybe a
SNothing))
                  )

      Tx era
txFixed <-
        String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) (Tx era)
submitFailingMempoolTx String
"unallowed votes" Tx era
tx (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
 -> ImpM (LedgerSpec era) (Tx era))
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) (Tx era)
forall a b. (a -> b) -> a -> b
$
          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)))
-> (Text -> PredicateFailure (EraRule "LEDGER" era))
-> Text
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConwayLedgerPredFailure era
-> PredicateFailure (EraRule "LEDGER" era)
ConwayLedgerPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayLedgerPredFailure era
 -> PredicateFailure (EraRule "LEDGER" era))
-> (Text -> ConwayLedgerPredFailure era)
-> Text
-> PredicateFailure (EraRule "LEDGER" era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ConwayLedgerPredFailure era
forall era. Text -> ConwayLedgerPredFailure era
ConwayMempoolFailure (Text -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> Text -> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$
            Text
"Unelected committee members are not allowed to cast votes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ([Credential 'HotCommitteeRole] -> String
forall a. Show a => a -> String
show (forall (f :: * -> *) a. Applicative f => a -> f a
pure @[] Credential 'HotCommitteeRole
ccHot))

      -- The tx should pass all other rules
      ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup (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
txFixed