Update checks in DelegSpec to include delegs in StakePoolState

and add a test case for redelegating drep

Author: teodanciu

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs

@@ -184,7 +184,7 @@ spec = do
               .~ [DelegTxCert cred (DelegStake poolKh)]
         )
         [injectFailure $ DelegateeStakePoolNotRegisteredDELEG poolKh]
-      expectNotDelegatedToPool cred
+      expectNotDelegatedToAnyPool cred
 
   describe "Delegate vote" $ do
     it "Delegate vote of registered stake credentials to registered drep" $ do
@@ -203,7 +203,7 @@ spec = do
             .~ [DelegTxCert cred (DelegVote (DRepCredential drepCred))]
 
       expectDelegatedVote cred (DRepCredential drepCred)
-      expectNotDelegatedToPool cred
+      expectNotDelegatedToAnyPool cred
       whenBootstrap $ do
         impAnn "Ensure DRep delegation is populated after bootstrap" $ do
           -- Clear out delegation, in order to check its repopulation from accounts.
@@ -223,6 +223,25 @@ spec = do
           getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai)
           expectDelegatedVote cred (DRepCredential drepCred)
 
+    it "Redelegate vote to the same DRep" $ do
+      expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . 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)
+
     it "Delegate vote of registered stake credentials to unregistered drep" $ do
       RewardAccount _ cred <- registerRewardAccount
       drepCred <- KeyHashObj <$> freshKeyHash
@@ -284,7 +303,13 @@ spec = do
       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 (expectNotDelegatedVote cred) (expectDelegatedVote cred (DRepCredential drepCred2))
+        ifBootstrap
+          ( do
+              -- we cannot `expectNotDelegatedVote` because the the delegation is still in the DRepState of the other pool
+              accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
+              expectNothingExpr (lookupDRepDelegation cred accounts)
+          )
+          (expectDelegatedVote cred (DRepCredential drepCred2))
 
     it "Delegate vote and unregister stake credentials" $ do
       expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
@@ -300,6 +325,8 @@ spec = do
             .~ [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
     disableInConformanceIt "Delegate vote and unregister after hardfork" $ do
@@ -412,9 +439,9 @@ spec = do
 
       -- when pool is re-registered after its expiration, all delegations are cleared
       passNEpochs $ fromIntegral poolLifetime
-      expectNotDelegatedToPool cred
+      expectNotDelegatedToAnyPool cred
       registerPoolWithRewardAccount poolKh rewardAccount
-      expectNotDelegatedToPool cred
+      expectNotDelegatedToAnyPool cred
       -- the vote delegation is kept
       expectDelegatedVote cred (DRepCredential drepCred)
 
@@ -502,6 +529,7 @@ spec = do
           & bodyTxL . certsTxBodyL
             .~ [DelegTxCert cred (DelegStake poolKh')]
       expectDelegatedToPool cred poolKh'
+      expectNotDelegatedToPool cred poolKh
       expectDelegatedVote cred (DRepCredential drepCred)
   where
     expectDelegatedVote :: HasCallStack => Credential 'Staking -> DRep -> ImpTestM era ()
@@ -527,8 +555,12 @@ spec = do
     expectNotDelegatedVote :: Credential 'Staking -> ImpTestM era ()
     expectNotDelegatedVote cred = do
       accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
-      impAnn (show cred <> " expected to not have their vote delegated") $
+      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) (Map.elems dreps))
 
 conwayEraSpecificSpec :: SpecWith (ImpInit (LedgerSpec ConwayEra))
 conwayEraSpecificSpec = do

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/DelegSpec.hs

@@ -54,7 +54,7 @@ shelleyEraSpecificSpec = do
           & bodyTxL . certsTxBodyL .~ [delegStakeTxCert cred poolKh]
       )
       [injectFailure $ DelegateeNotRegisteredDELEG poolKh]
-    expectNotDelegatedToPool cred
+    expectNotDelegatedToAnyPool cred
 
   it "Deregistering returns the deposit" $ do
     let keyDeposit = Coin 2
@@ -228,6 +228,7 @@ spec = do
               else StakeKeyNotRegisteredDELEG cred
         ]
       expectStakeCredNotRegistered cred
+      expectNotDelegatedToAnyPool cred
 
     it "Delegate already delegated credentials" $ do
       cred <- KeyHashObj <$> freshKeyHash
@@ -251,6 +252,7 @@ spec = do
           & bodyTxL . certsTxBodyL
             .~ [delegStakeTxCert cred poolKh1]
       expectDelegatedToPool cred poolKh1
+      expectNotDelegatedToPool cred poolKh
 
       poolKh2 <- freshKeyHash
       registerPool poolKh2
@@ -265,6 +267,8 @@ spec = do
                ]
 
       expectDelegatedToPool cred poolKh3
+      expectNotDelegatedToPool cred poolKh2
+      expectNotDelegatedToPool cred poolKh
 
     it "Delegate and unregister" $ do
       cred <- KeyHashObj <$> freshKeyHash
@@ -277,3 +281,4 @@ spec = do
           & bodyTxL . certsTxBodyL
             .~ [regTxCert, delegStakeTxCert cred poolKh, unRegTxCert]
       expectStakeCredNotRegistered cred
+      expectNotDelegatedToAnyPool cred

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs

@@ -71,6 +71,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
   delegateStake,
   registerRewardAccount,
   registerStakeCredential,
+  expectNotDelegatedToAnyPool,
   expectNotDelegatedToPool,
   expectStakeCredRegistered,
   expectStakeCredNotRegistered,
@@ -1637,20 +1638,51 @@ expectDelegatedToPool ::
   KeyHash 'StakePool ->
   ImpTestM era ()
 expectDelegatedToPool cred poolKh = do
-  accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
+  certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
+  let accounts = certState ^. certDStateL . accountsL
+  let pools = certState ^. certPStateL . psStakePoolsL
   impAnn (show cred <> " expected to have delegated to " <> show poolKh) $ do
     accountState <- expectJust $ lookupAccountState cred accounts
     accountState ^. stakePoolDelegationAccountStateL `shouldBe` Just poolKh
+    case Map.lookup poolKh pools of
+      Nothing ->
+        assertFailure $
+          "Expected stake pool state for: " <> show poolKh
+      Just poolState ->
+        assertBool
+          ("Expected pool delegations to contain the stake credential: " <> show cred)
+          (cred `Set.member` (poolState ^. spsDelegsL))
+
+expectNotDelegatedToAnyPool ::
+  (HasCallStack, ShelleyEraImp era) =>
+  Credential 'Staking ->
+  ImpTestM era ()
+expectNotDelegatedToAnyPool cred = do
+  certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
+  let accounts = certState ^. certDStateL . accountsL
+  let pools = certState ^. certPStateL . psStakePoolsL
+  impAnn (show cred <> " expected to not have delegated to a stake pool") $ do
+    forM_ (lookupAccountState cred accounts) $ \accountState ->
+      expectNothingExpr (accountState ^. stakePoolDelegationAccountStateL)
+    assertBool
+      ("Expected no stake pool state delegation to contain the stake credential: " <> show cred)
+      (all (Set.notMember cred . spsDelegs) (Map.elems pools))
 
 expectNotDelegatedToPool ::
   (HasCallStack, ShelleyEraImp era) =>
   Credential 'Staking ->
+  KeyHash 'StakePool ->
   ImpTestM era ()
-expectNotDelegatedToPool cred = do
-  accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
+expectNotDelegatedToPool cred pool = do
+  certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
+  let accounts = certState ^. certDStateL . accountsL
+  let pools = certState ^. certPStateL . psStakePoolsL
   impAnn (show cred <> " expected to not have delegated to a stake pool") $ do
-    accountState <- expectJust $ lookupAccountState cred accounts
-    expectNothingExpr (accountState ^. stakePoolDelegationAccountStateL)
+    forM_ (lookupAccountState cred accounts) $ \accountState ->
+      accountState ^. stakePoolDelegationAccountStateL `shouldNotBe` Just pool
+    assertBool
+      ("Expected stake pool state delegation to not contain the stake credential: " <> show cred)
+      (maybe True (Set.notMember cred . spsDelegs) (Map.lookup pool pools))
 
 registerRewardAccount ::
   forall era.