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

module Test.Cardano.Ledger.Conway.Imp.DelegSpec (
  spec,
) where

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), StrictMaybe (..), addEpochInterval)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.Rules (ConwayDelegPredFailure (..))
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus (
  SLanguage (..),
  hashPlutusScript,
 )
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.UMap as UMap
import Cardano.Ledger.Val (Val (..))
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((%~), (&), (.~))
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (evenRedeemerNoDatum)

spec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayDelegPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Register stake credential" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"With correct deposit or without any deposit" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh -> do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
RegTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh)]
        forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectRegistered (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh -> do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
expectedDeposit]
        forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectRegistered (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh)

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Twice the same certificate in the same transaction" forall a b. (a -> b) -> a -> b
$ do
      -- This is expected behavior because `certsTxBodyL` removes duplicates
      Coin
expectedDeposit <- 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
      forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh -> do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
expectedDeposit
                 , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
expectedDeposit
                 ]
        forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectRegistered (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh)

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"When already already registered" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
      let sh :: ScriptHash (EraCrypto era)
sh = forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage 'PlutusV3
SPlutusV3)
      let tx :: Tx era
tx =
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
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
RegDepositTxCert (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
sh) Coin
expectedDeposit]
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx

      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.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyRegisteredDELEG (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
sh)
        ]
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectRegistered (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj ScriptHash (EraCrypto era)
sh)

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"With incorrect deposit" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Positive Integer
n <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      let wrongDeposit :: Coin
wrongDeposit = Coin
expectedDeposit forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
n

      forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh -> do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          ( forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (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
RegDepositTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
wrongDeposit]
          )
          [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Coin
wrongDeposit]
        forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotRegistered (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh)

  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Unregister stake credentials" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"When registered" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
      let sh :: Credential kr (EraCrypto era)
sh = forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
ScriptHashObj forall a b. (a -> b) -> a -> b
$ forall c (l :: Language).
(Crypto c, PlutusLanguage l) =>
Plutus l -> ScriptHash c
hashPlutusScript (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage 'PlutusV3
SPlutusV3)
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert forall {kr :: KeyRole}. Credential kr (EraCrypto era)
sh Coin
expectedDeposit]

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
UnRegDepositTxCert forall {kr :: KeyRole}. Credential kr (EraCrypto era)
sh Coin
expectedDeposit]
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotRegistered forall {kr :: KeyRole}. Credential kr (EraCrypto era)
sh

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"When not registered" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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
      forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh ->
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          ( forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (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 (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
expectedDeposit]
          )
          [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh)
          ]

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"With incorrect deposit" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit]

      Positive Integer
n <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      let wrongDeposit :: Coin
wrongDeposit = Coin
expectedDeposit forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
n

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        ( forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (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
wrongDeposit]
        )
        [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Coin
wrongDeposit]

      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectRegistered Credential 'Staking (EraCrypto era)
cred

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"With non-zero reward balance" 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
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit]

      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
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        ( forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (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
expectedDeposit]
        )
        [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Coin -> ConwayDelegPredFailure era
StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
reward]
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectRegistered Credential 'Staking (EraCrypto era)
cred

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Register and unregister in the same transaction" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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
      forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh -> do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
expectedDeposit
                 , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
UnRegDepositTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
expectedDeposit
                 ]
        forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotRegistered (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh)

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"deregistering returns the deposit" forall a b. (a -> b) -> a -> b
$ do
      let
        keyDeposit :: Coin
keyDeposit = Integer -> Coin
Coin Integer
2
        -- This is paid out as the reward
        govActionDeposit :: Coin
govActionDeposit = Integer -> Coin
Coin Integer
3
      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. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
keyDeposit
          forall a b. a -> (a -> b) -> b
& forall era. ConwayEraPParams era => Lens' (PParams era) Coin
ppGovActionDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
govActionDeposit
      Credential 'Staking (EraCrypto era)
stakeCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      RewardAccount (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
registerStakeCredential Credential 'Staking (EraCrypto era)
stakeCred
      Credential 'Staking (EraCrypto era)
otherStakeCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      RewardAccount (EraCrypto era)
otherRewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking (EraCrypto era)
-> ImpTestM era (RewardAccount (EraCrypto era))
registerStakeCredential Credential 'Staking (EraCrypto era)
otherStakeCred
      KeyHash 'StakePool (EraCrypto era)
khStakePool <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
khStakePool
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 a. [a] -> StrictSeq a
SSeq.fromList
              [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
stakeCred (forall c. KeyHash 'StakePool c -> DRep c -> Delegatee c
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
khStakePool forall c. DRep c
DRepAlwaysAbstain)
              , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
otherStakeCred (forall c. KeyHash 'StakePool c -> DRep c -> Delegatee c
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
khStakePool forall c. DRep c
DRepAlwaysAbstain)
              ]
      forall era. RewardAccount (EraCrypto era) -> ImpTestM era ()
expectRegisteredRewardAddress RewardAccount (EraCrypto era)
rewardAccount
      forall era. RewardAccount (EraCrypto era) -> ImpTestM era ()
expectRegisteredRewardAddress RewardAccount (EraCrypto era)
otherRewardAccount
      forall era.
ConwayEraImp era =>
Credential 'Staking (EraCrypto era) -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking (EraCrypto era)
otherStakeCred
      forall era.
HasCallStack =>
Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward Credential 'Staking (EraCrypto era)
otherStakeCred forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
govActionDeposit
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 a. [a] -> StrictSeq a
SSeq.fromList
              [forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era) -> TxCert era
UnRegTxCert Credential 'Staking (EraCrypto era)
stakeCred]
          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
              ( forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                  [ (RewardAccount (EraCrypto era)
rewardAccount, Integer -> Coin
Coin Integer
0)
                  , (RewardAccount (EraCrypto era)
otherRewardAccount, Coin
govActionDeposit)
                  ]
              )
      forall era.
HasCallStack =>
Credential 'Staking (EraCrypto era) -> ImpTestM era Coin
lookupReward Credential 'Staking (EraCrypto era)
otherStakeCred forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Integer -> Coin
Coin Integer
0
      forall era. RewardAccount (EraCrypto era) -> ImpTestM era ()
expectNotRegisteredRewardAddress RewardAccount (EraCrypto era)
rewardAccount

  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Delegate stake" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate registered stake credentials to registered pool" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit]

      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)]

      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Register and delegate in the same transaction" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit
               , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)
               ]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

      forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh -> do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh) Coin
expectedDeposit]
        forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) KeyHash 'StakePool (EraCrypto era)
poolKh

      forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash 'Staking (EraCrypto era)
kh -> do
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) Coin
expectedDeposit
                 , forall era.
ShelleyEraTxCert era =>
StakeCredential (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> TxCert era
DelegStakeTxCert (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) KeyHash 'StakePool (EraCrypto era)
poolKh -- using the pattern from Shelley
                 ]
        forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh) KeyHash 'StakePool (EraCrypto era)
poolKh

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate unregistered stake credentials" forall a b. (a -> b) -> a -> b
$ do
      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        ( forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)]
        )
        [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking (EraCrypto era)
cred]

      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate to unregistered pool" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit]

      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        ( forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)]
        )
        [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
KeyHash 'StakePool (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeStakePoolNotRegisteredDELEG KeyHash 'StakePool (EraCrypto era)
poolKh]

      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate already delegated credentials" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit
               , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)
               ]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

      KeyHash 'StakePool (EraCrypto era)
poolKh1 <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh1
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh1)]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh1

      KeyHash 'StakePool (EraCrypto era)
poolKh2 <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh2
      KeyHash 'StakePool (EraCrypto era)
poolKh3 <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh3

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh2)
               , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh3)
               ]

      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh3

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate and unregister" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit
               , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)
               , forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit
               ]
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotRegistered Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred

  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Delegate vote" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate vote of registered stake credentials to registered drep" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
RegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit]

      (Credential 'DRepRole (EraCrypto era)
drepCred, 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
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred))]

      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred
      forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenBootstrap forall a b. (a -> b) -> a -> b
$ do
        forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Ensure DRep delegation is populated after bootstrap" forall a b. (a -> b) -> a -> b
$ do
          -- Clear out delegation, in order to check its repopulation from UMap.
          let deleteDelegation :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
deleteDelegation =
                forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall c. Lens' (DRepState c) (Set (Credential 'Staking c))
drepDelegsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.delete Credential 'Staking (EraCrypto era)
cred) Credential 'DRepRole (EraCrypto era)
drepCred
          --  Drep delegation for both version 9 and 10 are populating both umap and
          --  `drepDelegs`, so manually modifying the umap in the state is the only way to
          --  test the correct repopulation of `drepDelegs`
          forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES 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.
Lens'
  (EpochState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
epochStateRegDrepL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
deleteDelegation
          NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
hotCreds <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
          (KeyHash 'StakePool (EraCrypto era)
spo, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
3_000_000_000
          ProtVer
protVer <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
          GovActionId (EraCrypto era)
gai <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation forall a. StrictMaybe a
SNothing (ProtVer -> ProtVer
majorFollow ProtVer
protVer)
          forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
hotCreds GovActionId (EraCrypto era)
gai
          forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spo) GovActionId (EraCrypto era)
gai
          forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
          forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose era))
getLastEnactedHardForkInitiation forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
gai)
          forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate vote of registered stake credentials to unregistered drep" forall a b. (a -> b) -> a -> b
$ do
      RewardAccount Network
_ Credential 'Staking (EraCrypto era)
cred <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount
      Credential 'DRepRole (EraCrypto era)
drepCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      let tx :: Tx era
tx =
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
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)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred))]
          inBootstrap :: ImpM (LedgerSpec era) ()
inBootstrap = do
            forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)
            forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Ensure delegation is cleaned up on the transition out of bootstrap" forall a b. (a -> b) -> a -> b
$ do
              NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
hotCreds <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
              (KeyHash 'StakePool (EraCrypto era)
spo, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
3_000_000_000
              ProtVer
protVer <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
              GovActionId (EraCrypto era)
gai <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation forall a. StrictMaybe a
SNothing (ProtVer -> ProtVer
majorFollow ProtVer
protVer)
              forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
hotCreds GovActionId (EraCrypto era)
gai
              forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spo) GovActionId (EraCrypto era)
gai
              forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
              forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose era))
getLastEnactedHardForkInitiation forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
gai)
              forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred

          outOfBootstrap :: ImpM (LedgerSpec era) ()
outOfBootstrap = 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.
Credential 'DRepRole (EraCrypto era) -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG Credential 'DRepRole (EraCrypto era)
drepCred]
            forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred
      forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap ImpM (LedgerSpec era) ()
inBootstrap ImpM (LedgerSpec era) ()
outOfBootstrap

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate vote of unregistered stake credentials" forall a b. (a -> b) -> a -> b
$ do
      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      Credential 'DRepRole (EraCrypto era)
drepCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
        ( forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
              forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred))]
        )
        [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
Credential 'Staking (EraCrypto era) -> ConwayDelegPredFailure era
StakeKeyNotRegisteredDELEG Credential 'Staking (EraCrypto era)
cred]

      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Redelegate vote" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      Credential 'DRepRole (EraCrypto era)
drepCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)) Coin
expectedDeposit]
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

      Credential 'DRepRole (EraCrypto era)
drepCred2 <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred2))]

      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred2)

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate vote and unregister stake credentials" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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
      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      Credential 'DRepRole (EraCrypto era)
drepCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. DRep c -> Delegatee c
DelegVote (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)) Coin
expectedDeposit]
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit]
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotRegistered Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred

  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Delegate both stake and vote" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate and unregister credentials" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh
      Credential 'DRepRole (EraCrypto era)
drepCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert
                  Credential 'Staking (EraCrypto era)
cred
                  (forall c. KeyHash 'StakePool c -> DRep c -> Delegatee c
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
poolKh (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred))
                  Coin
expectedDeposit
               ]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era) -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking (EraCrypto era)
cred Coin
expectedDeposit]
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotRegistered Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate to DRep and SPO and change delegation to a different SPO" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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

      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh
      Credential 'DRepRole (EraCrypto era)
drepCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert
                  Credential 'Staking (EraCrypto era)
cred
                  (forall c. KeyHash 'StakePool c -> DRep c -> Delegatee c
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
poolKh (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred))
                  Coin
expectedDeposit
               ]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

      KeyHash 'StakePool (EraCrypto era)
poolKh' <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh'
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert Credential 'Staking (EraCrypto era)
cred (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh')]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh'
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate, retire and re-register pool" forall a b. (a -> b) -> a -> b
$ do
      Coin
expectedDeposit <- 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
      Credential 'Staking (EraCrypto era)
cred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      RewardAccount (EraCrypto era)
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era) -> ImpTestM era ()
registerPool KeyHash 'StakePool (EraCrypto era)
poolKh
      Credential 'DRepRole (EraCrypto era)
drepCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash 'DRepRole (EraCrypto era))
registerDRep

      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> Coin -> TxCert era
RegDepositDelegTxCert
                  Credential 'Staking (EraCrypto era)
cred
                  (forall c. KeyHash 'StakePool c -> DRep c -> Delegatee c
DelegStakeVote KeyHash 'StakePool (EraCrypto era)
poolKh (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred))
                  Coin
expectedDeposit
               ]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

      let poolLifetime :: Word32
poolLifetime = Word32
2
      let poolExpiry :: ImpM (LedgerSpec era) EpochNo
poolExpiry = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \EpochNo
n -> EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
n forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
poolLifetime

      ImpM (LedgerSpec era) EpochNo
poolExpiry forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EpochNo
pe ->
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolKh EpochNo
pe]

      -- when pool is re-registered after its expiration, all delegations are cleared
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
poolLifetime
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era) -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool (EraCrypto era)
poolKh RewardAccount (EraCrypto era)
rewardAccount
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred
      -- the vote delegation is kept
      forall {era}.
EraGov era =>
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

      -- re-delegate
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ forall era.
ConwayEraTxCert era =>
StakeCredential (EraCrypto era)
-> Delegatee (EraCrypto era) -> TxCert era
DelegTxCert
                  Credential 'Staking (EraCrypto era)
cred
                  (forall c. KeyHash 'StakePool c -> Delegatee c
DelegStake KeyHash 'StakePool (EraCrypto era)
poolKh)
               ]
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

      -- when pool is re-registered before its expiration, delegations are kept
      ImpM (LedgerSpec era) EpochNo
poolExpiry forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EpochNo
pe ->
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolKh EpochNo
pe]
      -- re-register the pool before the expiration time
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
poolLifetime forall a. Num a => a -> a -> a
- Natural
1
      forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era) -> ImpTestM era ()
registerPoolWithRewardAccount KeyHash 'StakePool (EraCrypto era)
poolKh RewardAccount (EraCrypto era)
rewardAccount
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

      -- when pool is retired and re-registered in the same transaction, delegations are kept
      PoolParams (EraCrypto era)
pps <- forall era.
ShelleyEraImp era =>
KeyHash 'StakePool (EraCrypto era)
-> RewardAccount (EraCrypto era)
-> ImpTestM era (PoolParams (EraCrypto era))
poolParams KeyHash 'StakePool (EraCrypto era)
poolKh RewardAccount (EraCrypto era)
rewardAccount
      ImpM (LedgerSpec era) EpochNo
poolExpiry forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \EpochNo
pe ->
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
            forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolKh EpochNo
pe, forall era.
EraTxCert era =>
PoolParams (EraCrypto era) -> TxCert era
RegPoolTxCert PoolParams (EraCrypto era)
pps]

      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
poolLifetime
      forall {era}.
Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
  where
    expectRegistered :: Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectRegistered Credential 'Staking (EraCrypto era)
cred = do
      UMap (EraCrypto era)
umap <- 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. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
      Coin
expectedDeposit <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL

      let umapDeposit :: Maybe Coin
umapDeposit = RDPair -> Coin
rdDepositCoin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k c v. k -> UView c k v -> Maybe v
UMap.lookup Credential 'Staking (EraCrypto era)
cred (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
umap)
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn
        (forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
cred forall a. Semigroup a => a -> a -> a
<> String
" expected to be in UMap RewDep with the correct deposit")
        forall a b. (a -> b) -> a -> b
$ Maybe Coin
umapDeposit forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just Coin
expectedDeposit

    expectNotRegistered :: Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotRegistered Credential 'Staking (EraCrypto era)
cred = do
      UMap (EraCrypto era)
umap <- 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. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
cred forall a. Semigroup a => a -> a -> a
<> String
" expected to not be in UMap RewDep") forall a b. (a -> b) -> a -> b
$
        forall k c v. k -> UView c k v -> Bool
UMap.notMember Credential 'Staking (EraCrypto era)
cred (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
RewDepUView UMap (EraCrypto era)
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
True

    expectDelegatedToPool :: Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh = do
      UMap (EraCrypto era)
umap <- 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. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
cred forall a. Semigroup a => a -> a -> a
<> String
" expected to have stake delegated to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show KeyHash 'StakePool (EraCrypto era)
poolKh) forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking (EraCrypto era)
cred (forall c.
UMap c -> Map (Credential 'Staking c) (KeyHash 'StakePool c)
sPoolMap UMap (EraCrypto era)
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just KeyHash 'StakePool (EraCrypto era)
poolKh

    expectNotDelegatedToPool :: Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred = do
      UMap (EraCrypto era)
umap <- 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. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
cred forall a. Semigroup a => a -> a -> a
<> String
" expected to not have delegated stake") forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'Staking (EraCrypto era)
cred (forall c.
UMap c -> Map (Credential 'Staking c) (KeyHash 'StakePool c)
sPoolMap UMap (EraCrypto era)
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
True

    expectDelegatedVote :: Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred DRep (EraCrypto era)
drep = do
      UMap (EraCrypto era)
umap <- 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. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
      Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps <- 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.
Lens'
  (EpochState era)
  (Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
epochStateRegDrepL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
cred forall a. Semigroup a => a -> a -> a
<> String
" expected to have their vote delegated to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show DRep (EraCrypto era)
drep) forall a b. (a -> b) -> a -> b
$ do
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking (EraCrypto era)
cred (forall c. UMap c -> Map (Credential 'Staking c) (DRep c)
dRepMap UMap (EraCrypto era)
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just DRep (EraCrypto era)
drep
        case DRep (EraCrypto era)
drep of
          DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred ->
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
drepCred Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
dreps of
              Maybe (DRepState (EraCrypto era))
Nothing ->
                forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure String
"Expected DRep to be registered"
              Just DRepState (EraCrypto era)
drepState ->
                forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> Bool -> m ()
assertBool
                  String
"Expected DRep delegations to contain the stake credential"
                  (Credential 'Staking (EraCrypto era)
cred forall a. Ord a => a -> Set a -> Bool
`Set.member` forall c. DRepState c -> Set (Credential 'Staking c)
drepDelegs DRepState (EraCrypto era)
drepState)
          DRep (EraCrypto era)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    expectNotDelegatedVote :: Credential 'Staking (EraCrypto era) -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred = do
      UMap (EraCrypto era)
umap <- 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. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (CertState era)
lsCertStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) (UMap (EraCrypto era))
dsUnifiedL
      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn (forall a. Show a => a -> String
show Credential 'Staking (EraCrypto era)
cred forall a. Semigroup a => a -> a -> a
<> String
" expected to not have their vote delegated") forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Bool
Map.notMember Credential 'Staking (EraCrypto era)
cred (forall c. UMap c -> Map (Credential 'Staking c) (DRep c)
dRepMap UMap (EraCrypto era)
umap) forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Bool
True