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

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.Rules (
  ConwayLedgerEvent (..),
  ConwayLedgerPredFailure (..),
  ConwayMempoolEvent (..),
  maxRefScriptSizePerTx,
 )
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
import Cardano.Ledger.SafeHash (originalBytesSize)
import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), mkMempoolEnv)
import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (ShelleyLedgersEnv (..), ShelleyLedgersEvent (..))
import Control.State.Transition.Extended
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysFailsWithDatum,
  alwaysSucceedsNoDatum,
 )

spec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
  , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era
  , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
  , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
  , Signal (EraRule "LEDGERS" era) ~ Seq.Seq (Tx era)
  , Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era
  , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era
  , STS (EraRule "LEDGERS" era)
  , ApplyTx era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era,
 Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era,
 BaseM (EraRule "LEDGERS" era) ~ ShelleyBase,
 Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era,
 Signal (EraRule "LEDGERS" era) ~ Seq (Tx era),
 Event (EraRule "LEDGERS" era) ~ ShelleyLedgersEvent era,
 Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era,
 STS (EraRule "LEDGERS" era), ApplyTx era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TxRefScriptsSizeTooBig" 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 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript @era forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysFailsWithDatum SLanguage 'PlutusV3
SPlutusV3
    let script :: Script era
        script :: Script era
script = forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
plutusScript
        size :: Int
size = forall t. SafeToHash t => t -> Int
originalBytesSize Script era
script
        n :: Int
n = Int
maxRefScriptSizePerTx forall a. Integral a => a -> a -> a
`div` Int
size forall a. Num a => a -> a -> a
+ Int
1
    [TxIn (EraCrypto era)]
txIns <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era (TxIn (EraCrypto era))
produceRefScript Script era
script)
    let tx :: Tx era
        tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [TxIn (EraCrypto era)]
txIns)
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx era
tx
      [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
          forall era. Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure era
ConwayTxRefScriptsSizeTooBig forall a b. (a -> b) -> a -> b
$
            Mismatch
              { mismatchSupplied :: Int
mismatchSupplied = Int
size forall a. Num a => a -> a -> a
* Int
n
              , mismatchExpected :: Int
mismatchExpected = Int
maxRefScriptSizePerTx
              }
      ]

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

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

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

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

    (Credential 'DRepRole (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000

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

    forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'DRepRole (EraCrypto era) -> ImpTestM era ()
unRegisterDRep Credential 'DRepRole (EraCrypto era)
drep
    forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era) -> ImpTestM era ()
expectDRepNotRegistered Credential 'DRepRole (EraCrypto era)
drep
    let tx :: Tx era
tx =
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
            forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (Withdrawals (EraCrypto era))
withdrawalsTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall c. Map (RewardAccount c) Coin -> Withdrawals c
Withdrawals
                  [(RewardAccount (EraCrypto era)
ra, Coin
reward)]
    forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall era.
HasCallStack =>
Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward Credential 'Staking (EraCrypto era)
cred forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` forall a. Monoid a => a
mempty)) forall a b. (a -> b) -> a -> b
$ do
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
NonEmpty (KeyHash 'Staking (EraCrypto era))
-> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [KeyHash 'Staking (EraCrypto era)
kh]]

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

    forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era) -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking (EraCrypto era)
cred
    Coin
reward <- forall era.
HasCallStack =>
Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward Credential 'Staking (EraCrypto era)
cred

    (Credential 'DRepRole (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000

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

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

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

    (Credential 'DRepRole (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000

    -- expire the drep before delegation
    forall era.
ConwayEraImp era =>
StrictMaybe (GovActionId (EraCrypto era))
-> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_
    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
4
    forall era.
HasCallStack =>
Credential 'DRepRole (EraCrypto era) -> ImpTestM era Bool
isDRepExpired Credential 'DRepRole (EraCrypto era)
drep forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Bool
True

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

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

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

    (Credential 'DRepRole (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000

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

    -- expire the drep after delegation
    forall era.
ConwayEraImp era =>
StrictMaybe (GovActionId (EraCrypto era))
-> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_

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

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

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

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

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

  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Mempool events" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"No Mempool events should be emitted via LEDGERS rules " forall a b. (a -> b) -> a -> b
$ do
      NewEpochState era
nes <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL
      SlotNo
slotNo <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. SimpleGetter (ImpTestState era) SlotNo
impLastTickG
      let ls :: LedgerState era
ls = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL
          pp :: PParams era
pp = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
          account :: AccountState
account = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) AccountState
esAccountStateL
          epochNo :: EpochNo
epochNo = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) EpochNo
nesELL
      Tx era
tx <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      Right (LedgerState era
_, [ShelleyLedgersEvent era]
evs) <-
        forall (rule :: Symbol) era.
(STS (EraRule rule era), BaseM (EraRule rule era) ~ ShelleyBase) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM
     era
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (State (EraRule rule era), [Event (EraRule rule era)]))
tryRunImpRule @"LEDGERS"
          (forall era.
SlotNo
-> EpochNo -> PParams era -> AccountState -> ShelleyLedgersEnv era
LedgersEnv SlotNo
slotNo EpochNo
epochNo PParams era
pp AccountState
account)
          LedgerState era
ls
          (forall a. a -> Seq a
Seq.singleton Tx era
tx)
      let mempoolEvents :: [ConwayLedgerEvent era]
mempoolEvents = [Event (EraRule "LEDGER" era)
ev | LedgerEvent ev :: Event (EraRule "LEDGER" era)
ev@(MempoolEvent (ConwayMempoolEvent Text
_)) <- [ShelleyLedgersEvent era]
evs]
      [ConwayLedgerEvent era]
mempoolEvents forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` []

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Mempool events should be emitted via `applyTx` with `mkMempoolEnv`" forall a b. (a -> b) -> a -> b
$ do
      Globals
globals <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
      SlotNo
slotNo <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. SimpleGetter (ImpTestState era) SlotNo
impLastTickG
      NewEpochState era
nes <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL
      let ls :: LedgerState era
ls = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL

      let mempoolEnv :: MempoolEnv era
mempoolEnv = forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv NewEpochState era
nes SlotNo
slotNo
      Tx era
tx <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Tx era -> ImpTestM era (Tx era)
fixupTx forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
      let stsOpts :: ApplySTSOpts 'EventPolicyReturn
stsOpts =
            ApplySTSOpts
              { asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
AssertionsAll
              , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll
              , asoEvents :: SingEP 'EventPolicyReturn
asoEvents = SingEP 'EventPolicyReturn
EPReturn
              }
      case forall era (ep :: EventPolicy) (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m,
 EventReturnTypeRep ep) =>
ApplySTSOpts ep
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (EventReturnType
        ep (EraRule "LEDGER" era) (MempoolState era, Validated (Tx era)))
applyTxOpts ApplySTSOpts 'EventPolicyReturn
stsOpts Globals
globals MempoolEnv era
mempoolEnv LedgerState era
ls Tx era
tx of
        Left ApplyTxError era
e ->
          forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Unexpected failure while applyingTx: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Tx era
tx forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ApplyTxError era
e
        Right ((LedgerState era, Validated (Tx era))
_, [ConwayLedgerEvent era]
evs) ->
          forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConwayLedgerEvent era
ev | ev :: ConwayLedgerEvent era
ev@(MempoolEvent (ConwayMempoolEvent Text
_)) <- [ConwayLedgerEvent era]
evs] forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Int
1