{-# 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 (..),
  Mismatch (..),
  ProtVer (..),
  StrictMaybe (..),
  addEpochInterval,
  natVersion,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.Rules (ConwayDelegPredFailure (..))
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Conway.Transition (conwayRegisterInitialAccounts)
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus (
  SLanguage (..),
  hashPlutusScript,
 )
import Cardano.Ledger.Shelley.Genesis (ShelleyGenesisStaking (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Val (Val (..))
import qualified Data.ListMap as LM
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Conway.Arbitrary ()
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (evenRedeemerNoDatum)

spec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp 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" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      freshKeyHash >>= \KeyHash Staking
kh -> do
        Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          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
.~ [Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh) Coin
expectedDeposit]
        Credential Staking -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era ()
expectStakeCredRegistered (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)

    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
      -- This is expected behavior because `certsTxBodyL` removes duplicates
      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)
        submitTx_ $
          mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ [regTxCert, regTxCert]
        expectStakeCredRegistered (KeyHashObj kh)
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"With incorrect 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
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      pv <- getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL

      Positive n <- arbitrary
      let wrongDeposit = Coin
expectedDeposit Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
n

      freshKeyHash >>= \KeyHash Staking
kh -> do
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          ( 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
.~ [Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
RegDepositTxCert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh) Coin
wrongDeposit]
          )
          [ ConwayDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayDelegPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$
              if ProtVer -> Bool
hardforkConwayDELEGIncorrectDepositsAndRefunds ProtVer
pv
                then
                  Mismatch RelEQ Coin -> ConwayDelegPredFailure era
forall era. Mismatch RelEQ Coin -> ConwayDelegPredFailure era
DepositIncorrectDELEG
                    Mismatch
                      { mismatchSupplied :: Coin
mismatchSupplied = Coin
wrongDeposit
                      , mismatchExpected :: Coin
mismatchExpected = Coin
expectedDeposit
                      }
                else Coin -> ConwayDelegPredFailure era
forall era. Coin -> ConwayDelegPredFailure era
IncorrectDepositDELEG Coin
wrongDeposit
          ]
        Credential Staking -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential Staking -> ImpTestM era ()
expectStakeCredNotRegistered (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
kh)

  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
"With incorrect refund" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      pv <- getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL

      let cred = ScriptHash -> Credential kr
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential kr) -> ScriptHash -> Credential kr
forall a b. (a -> b) -> a -> b
$ Plutus 'PlutusV3 -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (Plutus 'PlutusV3 -> ScriptHash) -> Plutus 'PlutusV3 -> ScriptHash
forall a b. (a -> b) -> a -> b
$ SLanguage 'PlutusV3 -> Plutus 'PlutusV3
forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage 'PlutusV3
SPlutusV3

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [RegDepositTxCert cred expectedDeposit]

      Positive n <- arbitrary
      let wrongDeposit = Coin
expectedDeposit Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
n

      submitFailingTx
        ( mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ [UnRegDepositTxCert cred wrongDeposit]
        )
        [ injectFailure $
            if hardforkConwayDELEGIncorrectDepositsAndRefunds pv
              then
                RefundIncorrectDELEG
                  Mismatch
                    { mismatchSupplied = wrongDeposit
                    , mismatchExpected = expectedDeposit
                    }
              else IncorrectDepositDELEG wrongDeposit
        ]

      expectStakeCredRegistered 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
        govActionDeposit :: Coin
govActionDeposit = 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. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((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
govActionDeposit
      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
      submitTx_ . mkBasicTx $
        mkBasicTxBody
          & certsTxBodyL
            .~ SSeq.fromList
              [ RegDepositDelegTxCert stakeCred (DelegStakeVote khStakePool DRepAlwaysAbstain) keyDeposit
              , RegDepositDelegTxCert otherStakeCred (DelegStakeVote khStakePool DRepAlwaysAbstain) keyDeposit
              ]
      expectRegisteredRewardAddress rewardAccount
      expectRegisteredRewardAddress otherRewardAccount
      submitAndExpireProposalToMakeReward otherStakeCred
      getBalance otherStakeCred `shouldReturn` govActionDeposit
      unRegTxCert <- genUnRegTxCert stakeCred
      submitTx_ . mkBasicTx $
        mkBasicTxBody
          & certsTxBodyL .~ SSeq.fromList [unRegTxCert]
          & withdrawalsTxBodyL
            .~ Withdrawals
              ( Map.fromList
                  [ (rewardAccount, Coin 0)
                  , (otherRewardAccount, govActionDeposit)
                  ]
              )
      getBalance otherStakeCred `shouldReturn` Coin 0
      expectNotRegisteredRewardAddress rewardAccount

  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 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
              .~ [DelegTxCert cred (DelegStake poolKh)]
        )
        [injectFailure $ DelegateeStakePoolNotRegisteredDELEG poolKh]
      expectNotDelegatedToAnyPool cred

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Delegate vote" (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 vote of registered stake credentials to registered drep" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL

      cred <- KeyHashObj <$> freshKeyHash
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [RegDepositTxCert cred expectedDeposit]

      (drepCred, _, _) <- setupSingleDRep 1_000_000
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred))]

      expectDelegatedVote cred (DRepCredential drepCred)
      expectNotDelegatedToAnyPool cred
      whenBootstrap $ do
        impAnn "Ensure DRep delegation is populated after bootstrap" $ do
          -- Clear out delegation, in order to check its repopulation from accounts.
          let deleteDelegation =
                (DRepState -> DRepState)
-> Credential DRepRole
-> Map (Credential DRepRole) DRepState
-> Map (Credential DRepRole) DRepState
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
-> DRepState -> Identity DRepState
Lens' DRepState (Set (Credential Staking))
drepDelegsL ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
 -> DRepState -> Identity DRepState)
-> (Set (Credential Staking) -> Set (Credential Staking))
-> DRepState
-> DRepState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Credential Staking
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Ord a => a -> Set a -> Set a
Set.delete Credential Staking
cred) Credential DRepRole
drepCred
          --  Drep delegation for both version 9 and 10 are populating both umap and
          --  `drepDelegs`, so manually modifying the umap in the state is the only way to
          --  test the correct repopulation of `drepDelegs`
          modifyNES $ nesEsL . epochStateRegDrepL %~ deleteDelegation
          hotCreds <- registerInitialCommittee
          (spo, _, _) <- setupPoolWithStake $ Coin 3_000_000_000
          protVer <- getProtVer
          gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer)
          submitYesVoteCCs_ hotCreds gai
          submitYesVote_ (StakePoolVoter spo) gai
          passNEpochs 2
          getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai)
          expectDelegatedVote cred (DRepCredential drepCred)

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Redelegate vote to the same DRep" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL

      cred <- KeyHashObj <$> freshKeyHash
      drepCred <- KeyHashObj <$> registerDRep

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [RegDepositDelegTxCert cred (DelegVote (DRepCredential drepCred)) expectedDeposit]
      expectDelegatedVote cred (DRepCredential drepCred)

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred))]

      expectDelegatedVote cred (DRepCredential drepCred)

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate vote of registered stake credentials to unregistered drep" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      RewardAccount _ cred <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
      drepCred <- KeyHashObj <$> freshKeyHash
      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
.~ [Credential Staking -> Delegatee -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Delegatee -> TxCert era
DelegTxCert Credential Staking
cred (DRep -> Delegatee
DelegVote (Credential DRepRole -> DRep
DRepCredential Credential DRepRole
drepCred))]
          inBootstrap = do
            Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ Tx TopTx era
tx
            HasCallStack =>
Credential Staking -> DRep -> ImpM (LedgerSpec era) ()
Credential Staking -> DRep -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential Staking
cred (Credential DRepRole -> DRep
DRepCredential Credential DRepRole
drepCred)
            String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Ensure delegation is cleaned up on the transition out of bootstrap" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
              hotCreds <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
              (spo, _, _) <- setupPoolWithStake $ Coin 3_000_000_000
              protVer <- getProtVer
              gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer)
              submitYesVoteCCs_ hotCreds gai
              submitYesVote_ (StakePoolVoter spo) gai
              passNEpochs 2
              getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai)
              expectNotDelegatedVote cred

          outOfBootstrap = do
            Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx [ConwayDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ConwayDelegPredFailure era -> EraRuleFailure "LEDGER" era)
-> ConwayDelegPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ Credential DRepRole -> ConwayDelegPredFailure era
forall era. Credential DRepRole -> ConwayDelegPredFailure era
DelegateeDRepNotRegisteredDELEG Credential DRepRole
drepCred]
            Credential Staking -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential Staking
cred
      ifBootstrap inBootstrap outOfBootstrap

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate vote of 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
      drepCred <- KeyHashObj <$> registerDRep
      submitFailingTx
        ( mkBasicTx mkBasicTxBody
            & bodyTxL . certsTxBodyL
              .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred))]
        )
        [injectFailure $ StakeKeyNotRegisteredDELEG cred]

      expectStakeCredNotRegistered cred

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Redelegate vote" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL

      cred <- KeyHashObj <$> freshKeyHash
      drepCred <- KeyHashObj <$> registerDRep

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [RegDepositDelegTxCert cred (DelegVote (DRepCredential drepCred)) expectedDeposit]
      expectDelegatedVote cred (DRepCredential drepCred)

      drepCred2 <- KeyHashObj <$> registerDRep
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred2))]

      expectDelegatedVote cred (DRepCredential drepCred2)

      impAnn "Check that unregistration of previous delegation does not affect current delegation" $ do
        unRegisterDRep drepCred
        -- we need to preserve the buggy behavior until the boostrap phase is over.
        ifBootstrap
          ( do
              -- we cannot `expectNotDelegatedVote` because the delegation is still in the DRepState of the other pool
              accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
              expectNothingExpr (lookupDRepDelegation cred accounts)
              dReps <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL
              drepState2 <- expectJust $ Map.lookup drepCred2 dReps
              drepDelegs drepState2 `shouldSatisfy` Set.member cred
          )
          (expectDelegatedVote cred (DRepCredential drepCred2))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate vote and unregister 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
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      cred <- KeyHashObj <$> freshKeyHash
      drepCred <- KeyHashObj <$> registerDRep
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [RegDepositDelegTxCert cred (DelegVote (DRepCredential drepCred)) expectedDeposit]
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [UnRegDepositTxCert cred expectedDeposit]
      expectStakeCredNotRegistered cred
      expectNotDelegatedVote cred
      expectNotDelegatedToAnyPool cred

    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/917
    -- TODO: Re-enable after issue is resolved, by removing this override
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Delegate vote and unregister after hardfork" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      let
        bootstrapVer :: ProtVer
bootstrapVer = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, 0 <= v, v <= MaxVersion) =>
Version
natVersion @9) Natural
0
        setProtVer :: ProtVer -> ImpTestM era ()
setProtVer ProtVer
pv = (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES ((NewEpochState era -> NewEpochState era) -> ImpTestM era ())
-> (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((ProtVer -> Identity ProtVer)
    -> EpochState era -> Identity (EpochState era))
-> (ProtVer -> Identity ProtVer)
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Identity (PParams era))
-> EpochState era -> Identity (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Identity (PParams era))
 -> EpochState era -> Identity (EpochState era))
-> ((ProtVer -> Identity ProtVer)
    -> PParams era -> Identity (PParams era))
-> (ProtVer -> Identity ProtVer)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Identity ProtVer)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> NewEpochState era -> Identity (NewEpochState era))
-> ProtVer -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer
pv
      initialProtVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
      (_, ccCred, _) <- impAnn "Set up a committee" $ do
        -- Temporarily set protver to 10 to elect a committee
        setProtVer $ ProtVer (natVersion @10) 0
        res <- electBasicCommittee
        setProtVer initialProtVer
        pure res
      (khSPO, _, _) <- setupPoolWithStake $ Coin 10_000_000
      -- Using a lazy pattern match here to prevent evaluation of tuple
      -- unless we actually need a value from it
      ~(drepCred, _, _) <-
        if initialProtVer > bootstrapVer
          then setupSingleDRep 100_000_000
          else pure $ error "drepCred should not be accessed before protver 10"
      passNEpochs 3
      expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
      cred <- KeyHashObj <$> freshKeyHash
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [RegDepositDelegTxCert cred (DelegVote DRepAlwaysAbstain) expectedDeposit]
      registerAndRetirePoolToMakeReward cred
      expectStakeCredRegistered cred
      expectDelegatedVote cred DRepAlwaysAbstain
      impAnn "Version should be unchanged" $
        getProtVer `shouldReturn` initialProtVer
      let nextVer = ProtVer -> ProtVer
majorFollow ProtVer
initialProtVer
      hfGaid <- submitGovAction $ HardForkInitiation SNothing nextVer
      submitVote_ VoteYes (StakePoolVoter khSPO) hfGaid
      submitVote_ VoteYes (CommitteeVoter ccCred) hfGaid
      when (initialProtVer > bootstrapVer) $
        submitVote_ VoteYes (DRepVoter drepCred) hfGaid
      passNEpochs 3
      logRatificationChecks hfGaid
      impAnn "Version should be bumped" $
        getProtVer `shouldReturn` nextVer
      withdrawalAmount <- getsPParams ppPoolDepositL
      rewardAccount <- getRewardAccountFor cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [UnRegDepositTxCert cred expectedDeposit]
          & bodyTxL . withdrawalsTxBodyL
            .~ Withdrawals (Map.singleton rewardAccount withdrawalAmount)
      expectStakeCredNotRegistered cred
      expectNotDelegatedVote cred
    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/916
    -- TODO: Re-enable after issue is resolved, by removing this override
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Delegate vote and undelegate after delegating to some stake pools" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      (khSPO, _, _) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000
      expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
      cred <- KeyHashObj <$> freshKeyHash
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [RegDepositDelegTxCert cred (DelegVote DRepAlwaysAbstain) expectedDeposit]
      registerAndRetirePoolToMakeReward cred
      expectStakeCredRegistered cred
      expectDelegatedVote cred DRepAlwaysAbstain
      forM_ @[] [1 .. 3 :: Int] $ \Int
_ -> do
        Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          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
.~ [Credential Staking -> Delegatee -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Delegatee -> TxCert era
DelegTxCert Credential Staking
cred (KeyHash StakePool -> Delegatee
DelegStake KeyHash StakePool
khSPO)]
      passNEpochs 3
      withdrawalAmount <- getsPParams ppPoolDepositL
      rewardAccount <- getRewardAccountFor cred
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [UnRegDepositTxCert cred expectedDeposit]
          & bodyTxL . withdrawalsTxBodyL
            .~ Withdrawals (Map.singleton rewardAccount withdrawalAmount)
      expectStakeCredNotRegistered cred
      expectNotDelegatedVote cred

    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/640
    -- TODO: Re-enable after issue is resolved, by removing this override
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Delegate, retire and re-register pool" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL
      cred <- KeyHashObj <$> freshKeyHash
      poolKh <- freshKeyHash
      rewardAccount <- registerRewardAccount
      registerPool poolKh
      drepCred <- KeyHashObj <$> registerDRep

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [ RegDepositDelegTxCert
                   cred
                   (DelegStakeVote poolKh (DRepCredential drepCred))
                   expectedDeposit
               ]
      expectDelegatedToPool cred poolKh
      expectDelegatedVote cred (DRepCredential drepCred)

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

      poolExpiry >>= \EpochNo
pe ->
        Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          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
.~ [KeyHash StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash StakePool
poolKh EpochNo
pe]

      -- when pool is re-registered after its expiration, all delegations are cleared
      passNEpochs $ fromIntegral poolLifetime
      expectNotDelegatedToAnyPool cred
      registerPoolWithRewardAccount poolKh rewardAccount
      expectNotDelegatedToAnyPool cred
      -- the vote delegation is kept
      expectDelegatedVote cred (DRepCredential drepCred)

      -- re-delegate
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [ DelegTxCert
                   cred
                   (DelegStake poolKh)
               ]
      expectDelegatedToPool cred poolKh

      -- when pool is re-registered before its expiration, delegations are kept
      poolExpiry >>= \EpochNo
pe ->
        Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          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
.~ [KeyHash StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash StakePool
poolKh EpochNo
pe]
      -- re-register the pool before the expiration time
      passNEpochs $ fromIntegral poolLifetime - 1
      registerPoolWithRewardAccount poolKh rewardAccount
      expectDelegatedToPool cred poolKh
      passNEpochs 2
      expectDelegatedToPool cred poolKh

      -- when pool is retired and re-registered in the same transaction, delegations are kept
      pps <- freshPoolParams poolKh rewardAccount
      poolExpiry >>= \EpochNo
pe ->
        Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
          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
.~ [KeyHash StakePool -> EpochNo -> TxCert era
forall era.
EraTxCert era =>
KeyHash StakePool -> EpochNo -> TxCert era
RetirePoolTxCert KeyHash StakePool
poolKh EpochNo
pe, StakePoolParams -> TxCert era
forall era. EraTxCert era => StakePoolParams -> TxCert era
RegPoolTxCert StakePoolParams
pps]

      expectDelegatedToPool cred poolKh
      passNEpochs $ fromIntegral poolLifetime
      expectDelegatedToPool cred poolKh
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Delegate both stake and vote" (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 and unregister 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
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL

      cred <- KeyHashObj <$> freshKeyHash
      poolKh <- freshKeyHash
      registerPool poolKh
      drepCred <- KeyHashObj <$> registerDRep

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [ RegDepositDelegTxCert
                   cred
                   (DelegStakeVote poolKh (DRepCredential drepCred))
                   expectedDeposit
               ]
      expectDelegatedToPool cred poolKh
      expectDelegatedVote cred (DRepCredential drepCred)

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [UnRegDepositTxCert cred expectedDeposit]
      expectStakeCredNotRegistered cred

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Delegate to DRep and SPO and change delegation to a different SPO" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      expectedDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL

      cred <- KeyHashObj <$> freshKeyHash
      poolKh <- freshKeyHash
      registerPool poolKh
      drepCred <- KeyHashObj <$> registerDRep

      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [ RegDepositDelegTxCert
                   cred
                   (DelegStakeVote poolKh (DRepCredential drepCred))
                   expectedDeposit
               ]
      expectDelegatedToPool cred poolKh
      expectDelegatedVote cred (DRepCredential drepCred)

      poolKh' <- freshKeyHash
      registerPool poolKh'
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ [DelegTxCert cred (DelegStake poolKh')]
      expectDelegatedToPool cred poolKh'
      expectNotDelegatedToPool cred poolKh
      expectDelegatedVote cred (DRepCredential drepCred)

  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 -> ImpTestM era StakePoolParams)
-> ImpTestM 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 -> ImpTestM 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, EraTransition era, ConwayEraAccounts era) =>
ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
conwayRegisterInitialAccounts 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
    expectDelegatedVote :: HasCallStack => Credential Staking -> DRep -> ImpTestM era ()
    expectDelegatedVote :: HasCallStack =>
Credential Staking -> DRep -> ImpM (LedgerSpec era) ()
expectDelegatedVote Credential Staking
cred DRep
drep = do
      accounts <- SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Accounts era)
 -> ImpTestM era (Accounts era))
-> SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> EpochState era -> Const r (EpochState era))
-> (Accounts era -> Const r (Accounts era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Accounts era -> Const r (Accounts era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Accounts era -> Const r (Accounts era))
    -> CertState era -> Const r (CertState era))
-> (Accounts era -> Const r (Accounts era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Accounts era -> Const r (Accounts era))
    -> DState era -> Const r (DState era))
-> (Accounts era -> Const r (Accounts era))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
      dreps <- getsNES $ nesEsL . epochStateRegDrepL
      impAnn (show cred <> " expected to have delegated to " <> show drep) $ do
        accountState <- expectJust $ lookupAccountState cred accounts
        accountState ^. dRepDelegationAccountStateL `shouldBe` Just drep
        case drep of
          DRepCredential Credential DRepRole
drepCred ->
            case Credential DRepRole
-> Map (Credential DRepRole) DRepState -> Maybe DRepState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential DRepRole
drepCred Map (Credential DRepRole) DRepState
dreps of
              Maybe DRepState
Nothing ->
                ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                  String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
                    String
"Expected DRep: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Credential DRepRole -> String
forall a. Show a => a -> String
show Credential DRepRole
drepCred String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to be registered"
              Just DRepState
drepState ->
                String -> Bool -> ImpM (LedgerSpec era) ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> Bool -> m ()
assertBool
                  String
"Expected DRep delegations to contain the stake credential"
                  (Credential Staking
cred Credential Staking -> Set (Credential Staking) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` DRepState -> Set (Credential Staking)
drepDelegs DRepState
drepState)
          DRep
_ -> () -> ImpM (LedgerSpec era) ()
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    expectNotDelegatedVote :: Credential Staking -> ImpTestM era ()
    expectNotDelegatedVote :: Credential Staking -> ImpM (LedgerSpec era) ()
expectNotDelegatedVote Credential Staking
cred = do
      accounts <- SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Accounts era)
 -> ImpTestM era (Accounts era))
-> SimpleGetter (NewEpochState era) (Accounts era)
-> ImpTestM era (Accounts era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> EpochState era -> Const r (EpochState era))
-> (Accounts era -> Const r (Accounts era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Accounts era -> Const r (Accounts era))
    -> LedgerState era -> Const r (LedgerState era))
-> (Accounts era -> Const r (Accounts era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Accounts era -> Const r (Accounts era))
    -> CertState era -> Const r (CertState era))
-> (Accounts era -> Const r (Accounts era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const r (DState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const r (DState era))
 -> CertState era -> Const r (CertState era))
-> ((Accounts era -> Const r (Accounts era))
    -> DState era -> Const r (DState era))
-> (Accounts era -> Const r (Accounts era))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const r (Accounts era))
-> DState era -> Const r (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
      dreps <- getsNES $ nesEsL . epochStateRegDrepL
      impAnn (show cred <> " expected to not have their vote delegated") $ do
        expectNothingExpr (lookupDRepDelegation cred accounts)
        assertBool
          ("Expected no drep state delegation to contain the stake credential: " <> show cred)
          (all (Set.notMember cred . drepDelegs) dreps)
    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