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

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

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (Coin))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Genesis
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Shelley.State (ShelleyEraAccounts)
import Cardano.Ledger.Shelley.Transition (shelleyRegisterInitialAccounts)
import Cardano.Ledger.State (accountsL, accountsMapL, stakePoolDelegationAccountStateL)
import qualified Data.ListMap as LM
import qualified Data.Map.Strict as Map
import Lens.Micro
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.Arbitrary ()
import Test.Cardano.Ledger.Shelley.ImpTest

shelleyEraSpecificSpec ::
  ( ShelleyEraImp era
  , ShelleyEraAccounts era
  , InjectRuleFailure "LEDGER" ShelleyDelegsPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
shelleyEraSpecificSpec :: forall era.
(ShelleyEraImp era, ShelleyEraAccounts era,
 InjectRuleFailure "LEDGER" ShelleyDelegsPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
shelleyEraSpecificSpec = do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Twice the same certificate in the same transaction" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM (LedgerSpec era) (KeyHash Staking)
-> (KeyHash Staking -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash Staking
kh -> do
      regTxCert <- Credential Staking -> ImpM (LedgerSpec era) (TxCert era)
forall era.
ShelleyEraImp era =>
Credential Staking -> ImpTestM era (TxCert era)
genRegTxCert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)
      submitFailingTx
        ( mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ [regTxCert, regTxCert]
        )
        [injectFailure $ StakeKeyAlreadyRegisteredDELEG (KeyHashObj kh)]
      expectStakeCredNotRegistered (KeyHashObj kh)

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate to unregistered pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    regTxCert <- genRegTxCert cred
    submitTx_ $
      mkBasicTx mkBasicTxBody
        & bodyTxL . certsTxBodyL .~ [regTxCert]

    poolKh <- freshKeyHash
    submitFailingTx
      ( mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [delegStakeTxCert cred poolKh]
      )
      [injectFailure $ DelegateeNotRegisteredDELEG poolKh]
    expectNotDelegatedToAnyPool cred

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Deregistering returns the deposit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    let keyDeposit :: Coin
keyDeposit = Integer -> Coin
Coin Integer
2
    -- This is paid out as the reward
    let poolDeposit :: Coin
poolDeposit = Integer -> Coin
Coin Integer
3
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
keyDeposit
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
poolDeposit
    stakeCred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    rewardAccount <- getRewardAccountFor stakeCred
    otherStakeCred <- KeyHashObj <$> freshKeyHash
    otherRewardAccount <- getRewardAccountFor otherStakeCred
    khStakePool <- freshKeyHash
    registerPool khStakePool
    stakeCredRegTxCert <- genRegTxCert stakeCred
    otherStakeCredRegTxCert <- genRegTxCert otherStakeCred
    submitTx_ . mkBasicTx $
      mkBasicTxBody
        & certsTxBodyL
          .~ [ stakeCredRegTxCert
             , delegStakeTxCert stakeCred khStakePool
             , otherStakeCredRegTxCert
             , delegStakeTxCert otherStakeCred khStakePool
             ]
    expectRegisteredRewardAddress rewardAccount
    expectRegisteredRewardAddress otherRewardAccount
    registerAndRetirePoolToMakeReward otherStakeCred

    getBalance otherStakeCred `shouldReturn` poolDeposit
    unRegTxCert <- genUnRegTxCert stakeCred

    submitTx_ . mkBasicTx $
      mkBasicTxBody
        & certsTxBodyL .~ [unRegTxCert]
        & withdrawalsTxBodyL
          .~ Withdrawals
            ( Map.fromList
                [ (rewardAccount, Coin 0)
                , (otherRewardAccount, poolDeposit)
                ]
            )
    getBalance otherStakeCred `shouldReturn` Coin 0
    expectNotRegisteredRewardAddress rewardAccount

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Transition creates the delegations correctly" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    pool1 <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM (LedgerSpec era) (KeyHash StakePool)
-> (KeyHash StakePool -> ImpM (LedgerSpec era) (KeyHash StakePool))
-> ImpM (LedgerSpec era) (KeyHash StakePool)
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash StakePool
kh -> KeyHash StakePool
kh KeyHash StakePool
-> ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) (KeyHash StakePool)
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ KeyHash StakePool -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> ImpTestM era ()
registerPool KeyHash StakePool
kh
    pool2 <- freshKeyHash >>= \KeyHash StakePool
kh -> KeyHash StakePool
kh KeyHash StakePool
-> ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) (KeyHash StakePool)
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ KeyHash StakePool -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> ImpTestM era ()
registerPool KeyHash StakePool
kh
    pool3 <- freshKeyHash >>= \KeyHash StakePool
kh -> KeyHash StakePool
kh KeyHash StakePool
-> ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) (KeyHash StakePool)
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ KeyHash StakePool -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> ImpTestM era ()
registerPool KeyHash StakePool
kh
    poolParams <- freshKeyHash >>= \KeyHash StakePool
kh -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount ImpTestM era RewardAccount
-> (RewardAccount -> ImpM (LedgerSpec era) StakePoolParams)
-> ImpM (LedgerSpec era) StakePoolParams
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyHash StakePool
-> RewardAccount -> ImpM (LedgerSpec era) StakePoolParams
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> RewardAccount -> ImpTestM era StakePoolParams
freshPoolParams KeyHash StakePool
kh
    deleg1 <- freshKeyHash >>= \KeyHash Staking
kh -> KeyHash Staking
kh KeyHash Staking
-> ImpTestM era RewardAccount
-> ImpM (LedgerSpec era) (KeyHash Staking)
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Credential Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era RewardAccount
registerStakeCredential (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)
    deleg2 <- freshKeyHash >>= \KeyHash Staking
kh -> KeyHash Staking
kh KeyHash Staking
-> ImpTestM era RewardAccount
-> ImpM (LedgerSpec era) (KeyHash Staking)
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Credential Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era RewardAccount
registerStakeCredential (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)
    deleg3 <- freshKeyHash >>= \KeyHash Staking
kh -> KeyHash Staking
kh KeyHash Staking
-> ImpTestM era RewardAccount
-> ImpM (LedgerSpec era) (KeyHash Staking)
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Credential Staking -> ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era RewardAccount
registerStakeCredential (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)
    nes <- getsNES id
    let sgs =
          ShelleyGenesisStaking
            { sgsPools :: ListMap (KeyHash StakePool) StakePoolParams
sgsPools = [(KeyHash StakePool, StakePoolParams)]
-> ListMap (KeyHash StakePool) StakePoolParams
forall k v. [(k, v)] -> ListMap k v
LM.ListMap [(KeyHash StakePool
pool1, StakePoolParams
poolParams), (KeyHash StakePool
pool2, StakePoolParams
poolParams), (KeyHash StakePool
pool3, StakePoolParams
poolParams)]
            , sgsStake :: ListMap (KeyHash Staking) (KeyHash StakePool)
sgsStake = [(KeyHash Staking, KeyHash StakePool)]
-> ListMap (KeyHash Staking) (KeyHash StakePool)
forall k v. [(k, v)] -> ListMap k v
LM.ListMap [(KeyHash Staking
deleg1, KeyHash StakePool
pool1), (KeyHash Staking
deleg2, KeyHash StakePool
pool1), (KeyHash Staking
deleg3, KeyHash StakePool
pool2)]
            }
    let updatedNES = ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
forall era.
(HasCallStack, ShelleyEraAccounts era, EraCertState era,
 EraGov era) =>
ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
shelleyRegisterInitialAccounts ShelleyGenesisStaking
sgs NewEpochState era
nes
    delegateStake (KeyHashObj deleg1) pool1
    delegateStake (KeyHashObj deleg2) pool1
    delegateStake (KeyHashObj deleg3) pool2
    getPoolsState <$> (getsNES id) `shouldReturn` getPoolsState updatedNES
    getDelegs deleg1 updatedNES `shouldReturn` Just pool1
    getDelegs deleg2 updatedNES `shouldReturn` Just pool1
    getDelegs deleg3 updatedNES `shouldReturn` Just pool2
  where
    getDelegs :: KeyHash Staking
-> NewEpochState era -> f (Maybe (KeyHash StakePool))
getDelegs KeyHash Staking
kh NewEpochState era
nes = do
      let accounts :: Map (Credential Staking) (AccountState era)
accounts = NewEpochState era
nes NewEpochState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (NewEpochState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (EpochState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (EpochState era))
-> NewEpochState era
-> Const
     (Map (Credential Staking) (AccountState era)) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era
  -> Const
       (Map (Credential Staking) (AccountState era)) (EpochState era))
 -> NewEpochState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (NewEpochState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> EpochState era
    -> Const
         (Map (Credential Staking) (AccountState era)) (EpochState era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (NewEpochState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (LedgerState era))
-> EpochState era
-> Const
     (Map (Credential Staking) (AccountState era)) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era
  -> Const
       (Map (Credential Staking) (AccountState era)) (LedgerState era))
 -> EpochState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (EpochState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> LedgerState era
    -> Const
         (Map (Credential Staking) (AccountState era)) (LedgerState era))
-> (Map (Credential Staking) (AccountState era)
    -> Const
         (Map (Credential Staking) (AccountState era))
         (Map (Credential Staking) (AccountState era)))
-> EpochState era
-> Const
     (Map (Credential Staking) (AccountState era)) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (CertState era))
-> LedgerState era
-> Const
     (Map (Credential Staking) (AccountState era)) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era
  -> Const
       (Map (Credential Staking) (AccountState era)) (CertState era))
 -> LedgerState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (LedgerState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> CertState era
    -> Const
         (Map (Credential Staking) (AccountState era)) (CertState era))
-> (Map (Credential Staking) (AccountState era)
    -> Const
         (Map (Credential Staking) (AccountState era))
         (Map (Credential Staking) (AccountState era)))
-> LedgerState era
-> Const
     (Map (Credential Staking) (AccountState era)) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> CertState era
-> Const
     (Map (Credential Staking) (AccountState era)) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era
  -> Const
       (Map (Credential Staking) (AccountState era)) (DState era))
 -> CertState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (CertState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> DState era
    -> Const
         (Map (Credential Staking) (AccountState era)) (DState era))
-> (Map (Credential Staking) (AccountState era)
    -> Const
         (Map (Credential Staking) (AccountState era))
         (Map (Credential Staking) (AccountState era)))
-> CertState era
-> Const
     (Map (Credential Staking) (AccountState era)) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era
 -> Const
      (Map (Credential Staking) (AccountState era)) (Accounts era))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const
       (Map (Credential Staking) (AccountState era)) (Accounts era))
 -> DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Const
         (Map (Credential Staking) (AccountState era))
         (Map (Credential Staking) (AccountState era)))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
      Maybe (KeyHash StakePool) -> f (Maybe (KeyHash StakePool))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (KeyHash StakePool) -> f (Maybe (KeyHash StakePool)))
-> Maybe (KeyHash StakePool) -> f (Maybe (KeyHash StakePool))
forall a b. (a -> b) -> a -> b
$ Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Maybe (AccountState era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh) Map (Credential Staking) (AccountState era)
accounts Maybe (AccountState era)
-> (AccountState era -> Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL)
    getPoolsState :: NewEpochState era -> Map (KeyHash StakePool) StakePoolState
getPoolsState NewEpochState era
nes = NewEpochState era
nes NewEpochState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> NewEpochState era
-> Const
     (Map (KeyHash StakePool) StakePoolState) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
 -> NewEpochState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (NewEpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era
  -> Const
       (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
 -> EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era
    -> Const
         (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
 -> LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> CertState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL

spec ::
  ShelleyEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
ShelleyEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Register stake credential" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"With correct deposit or without any deposit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      -- NOTE: This will always generate certs with deposits post-Conway
      regTxCert <- genRegTxCert cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [regTxCert]
      expectStakeCredRegistered cred

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"When already already registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Staking)
-> ImpM (LedgerSpec era) ScriptHash
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf [])
      regTxCert <- genRegTxCert cred
      let tx =
            TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL
                ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictSeq (TxCert era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (StrictSeq (TxCert era))
TxCert era
regTxCert]
      submitTx_ tx
      submitFailingTx
        tx
        [ injectFailure $ StakeKeyAlreadyRegisteredDELEG cred
        ]
      expectStakeCredRegistered cred

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Unregister stake credentials" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"When registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Staking)
-> ImpM (LedgerSpec era) ScriptHash
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NativeScript era -> ImpM (LedgerSpec era) ScriptHash
forall era.
EraScript era =>
NativeScript era -> ImpTestM era ScriptHash
impAddNativeScript (StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf [])
      regTxCert <- genRegTxCert cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [regTxCert]
      expectStakeCredRegistered cred

      unRegTxCert <- genUnRegTxCert cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [unRegTxCert]
      expectStakeCredNotRegistered cred

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"When not registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM (LedgerSpec era) (KeyHash Staking)
-> (KeyHash Staking -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash Staking
kh -> do
        unRegTxCert <- Credential Staking -> ImpM (LedgerSpec era) (TxCert era)
forall era.
ShelleyEraImp era =>
Credential Staking -> ImpTestM era (TxCert era)
genUnRegTxCert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)
        submitFailingTx
          ( mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ [unRegTxCert]
          )
          [injectFailure $ StakeKeyNotRegisteredDELEG (KeyHashObj kh)]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"With non-zero reward balance" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      regTxCert <- genRegTxCert cred

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [regTxCert]

      registerAndRetirePoolToMakeReward cred

      balance <- getBalance cred
      unRegTxCert <- genUnRegTxCert cred
      submitFailingTx
        ( mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL .~ [unRegTxCert]
        )
        [injectFailure $ StakeKeyNonZeroAccountBalanceDELEG balance]
      expectStakeCredRegistered cred

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Register and unregister in the same transaction" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM (LedgerSpec era) (KeyHash Staking)
-> (KeyHash Staking -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \KeyHash Staking
kh -> do
        regTxCert <- Credential Staking -> ImpM (LedgerSpec era) (TxCert era)
forall era.
ShelleyEraImp era =>
Credential Staking -> ImpTestM era (TxCert era)
genRegTxCert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)
        unRegTxCert <- genUnRegTxCert (KeyHashObj kh)
        submitTx_ $
          mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL .~ [regTxCert, unRegTxCert]
        expectStakeCredNotRegistered (KeyHashObj kh)

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Delegate stake" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate registered stake credentials to registered pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      regTxCert <- genRegTxCert cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [regTxCert]

      poolKh <- freshKeyHash
      registerPool poolKh

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [delegStakeTxCert cred poolKh]
      expectDelegatedToPool cred poolKh

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Register and delegate in the same transaction" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      poolKh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      registerPool poolKh
      cred <- KeyHashObj <$> freshKeyHash
      regTxCert <- genRegTxCert cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [regTxCert, delegStakeTxCert cred poolKh]
      expectDelegatedToPool cred poolKh

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate unregistered stake credentials" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      poolKh <- freshKeyHash
      registerPool poolKh
      pv <- getProtVer
      submitFailingTx
        ( mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ [delegStakeTxCert cred poolKh]
        )
        [ injectFailure $
            if pvMajor pv < natVersion @9
              then StakeDelegationImpossibleDELEG cred
              else StakeKeyNotRegisteredDELEG cred
        ]
      expectStakeCredNotRegistered cred
      expectNotDelegatedToAnyPool cred

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate already delegated credentials" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      poolKh <- freshKeyHash
      registerPool poolKh
      regTxCert <- genRegTxCert cred
      let delegTxCert = Credential Staking -> KeyHash StakePool -> TxCert era
forall era.
ShelleyEraImp era =>
Credential Staking -> KeyHash StakePool -> TxCert era
delegStakeTxCert Credential Staking
cred KeyHash StakePool
poolKh
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [regTxCert, delegTxCert]
      expectDelegatedToPool cred poolKh
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [delegTxCert]
      expectDelegatedToPool cred poolKh

      poolKh1 <- freshKeyHash
      registerPool poolKh1
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [delegStakeTxCert cred poolKh1]
      expectDelegatedToPool cred poolKh1
      expectNotDelegatedToPool cred poolKh

      poolKh2 <- freshKeyHash
      registerPool poolKh2
      poolKh3 <- freshKeyHash
      registerPool poolKh3

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [ delegStakeTxCert cred poolKh2
               , delegStakeTxCert cred poolKh3
               ]

      expectDelegatedToPool cred poolKh3
      expectNotDelegatedToPool cred poolKh2
      expectNotDelegatedToPool cred poolKh

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate and unregister" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      poolKh <- freshKeyHash
      registerPool poolKh
      regTxCert <- genRegTxCert cred
      unRegTxCert <- genUnRegTxCert cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [regTxCert, delegStakeTxCert cred poolKh, unRegTxCert]
      expectStakeCredNotRegistered cred
      expectNotDelegatedToAnyPool cred