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

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

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
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 as Map
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 (ImpTestState era)
spec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayDelegPredFailure era) =>
SpecWith (ImpTestState 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM era ()
expectRegistered (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking (EraCrypto era)
kh)

      forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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
"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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM era ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

      forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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) -> ImpTestM era ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

      KeyHash 'StakePool (EraCrypto era)
poolKh1 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM era ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh1

      KeyHash 'StakePool (EraCrypto era)
poolKh2 <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM era ()
expectNotRegistered Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM 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) -> ImpTestM era ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred

    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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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 :: ImpTestM era ()
inBootstrap = do
            forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
            forall {era}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM era ()
expectDelegatedVote Credential 'Staking (EraCrypto era)
cred (forall c. Credential 'DRepRole c -> DRep c
DRepCredential Credential 'DRepRole (EraCrypto era)
drepCred)

          outOfBootstrap :: ImpTestM 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) -> ImpTestM era ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred
      forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap ImpTestM era ()
inBootstrap ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM 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}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM era ()
expectNotRegistered Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpTestM 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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM era ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall {era}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM 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) -> ImpTestM era ()
expectNotRegistered Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpTestM era ()
expectNotDelegatedVote Credential 'Staking (EraCrypto era)
cred
      forall {era}.
Credential 'Staking (EraCrypto era) -> ImpTestM era ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred

    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 :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
      KeyHash 'StakePool (EraCrypto era)
poolKh <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) 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) -> ImpTestM era ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
      forall {era}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM 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 :: ImpTestM 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

      ImpTestM 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) -> ImpTestM 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) -> ImpTestM era ()
expectNotDelegatedToPool Credential 'Staking (EraCrypto era)
cred
      -- the vote delegation is kept
      forall {era}.
Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM 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) -> ImpTestM era ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh

      -- when pool is re-registered before its expiration, delegations are kept
      ImpTestM 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) -> ImpTestM 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) -> ImpTestM 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
      ImpTestM 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) -> ImpTestM 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) -> ImpTestM era ()
expectDelegatedToPool Credential 'Staking (EraCrypto era)
cred KeyHash 'StakePool (EraCrypto era)
poolKh
  where
    expectRegistered :: Credential 'Staking (EraCrypto era) -> ImpTestM 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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era 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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just Coin
expectedDeposit

    expectNotRegistered :: Credential 'Staking (EraCrypto era) -> ImpTestM 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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era 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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Bool
True

    expectDelegatedToPool :: Credential 'Staking (EraCrypto era)
-> KeyHash 'StakePool (EraCrypto era) -> ImpTestM 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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era 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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just KeyHash 'StakePool (EraCrypto era)
poolKh

    expectNotDelegatedToPool :: Credential 'Staking (EraCrypto era) -> ImpTestM 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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era 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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Bool
True

    expectDelegatedVote :: Credential 'Staking (EraCrypto era)
-> DRep (EraCrypto era) -> ImpTestM 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
      forall a era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era 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
$
        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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` forall a. a -> Maybe a
Just DRep (EraCrypto era)
drep

    expectNotDelegatedVote :: Credential 'Staking (EraCrypto era) -> ImpTestM 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 era.
NFData a =>
String -> ImpTestM era a -> ImpTestM era 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 a (m :: * -> *).
(HasCallStack, Show a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBe` Bool
True