Merge pull request #5176 from rrruko/rrruko/add-query-drep-delegation-state

add `queryDRepDelegationState` state query

Author: lehins

libs/cardano-ledger-api/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.12.0.0
 
+* Add `queryDRepDelegations` state query
 * Remove `filterStakePoolDelegsAndRewards` as unnecessary. Use `queryStakePoolDelegsAndRewards` instead
 * Expose `binaryUpgradeTx`, `binaryUpgradeTxBody`, `binaryUpgradeTxWits`, `binaryUpgradeTxAuxData`, `upgradeTx`, `upgradeTxBody`, `upgradeTxWits`, `upgradeTxAuxData`
 * Add `EraApi` class

libs/cardano-ledger-api/src/Cardano/Ledger/Api/State/Query.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -19,6 +20,9 @@ module Cardano.Ledger.Api.State.Query (
   -- * @GetDRepState@
   queryDRepState,
 
+  -- * @GetDRepDelegations@
+  queryDRepDelegations,
+
   -- * @GetDRepStakeDistr@
   queryDRepStakeDistr,
 
@@ -96,7 +100,8 @@ import Cardano.Ledger.Conway.Governance (
 import Cardano.Ledger.Conway.Rules (updateDormantDRepExpiry)
 import Cardano.Ledger.Conway.State
 import Cardano.Ledger.Core
-import Cardano.Ledger.Credential (Credential)
+import Cardano.Ledger.Credential (Credential (..))
+import Cardano.Ledger.DRep (credToDRep, dRepToCred)
 import Cardano.Ledger.Shelley.LedgerState
 import Control.Monad (guard)
 import Data.Foldable (foldMap')
@@ -156,6 +161,45 @@ queryDRepState nes creds
     vState = nes ^. nesEsL . esLStateL . lsCertStateL . certVStateL
     updateDormantDRepExpiry' = updateDormantDRepExpiry (nes ^. nesELL)
 
+-- | Query the delegators delegated to each DRep, including
+-- @AlwaysAbstain@ and @NoConfidence@.
+queryDRepDelegations ::
+  forall era.
+  ConwayEraCertState era =>
+  NewEpochState era ->
+  -- | Specify a set of DReps whose state should be returned. When this set is
+  -- empty, states for all of the DReps will be returned.
+  Set DRep ->
+  Map DRep (Set (Credential 'Staking))
+queryDRepDelegations nes dreps =
+  case getDRepCreds dreps of
+    Just creds ->
+      Map.map drepDelegs $
+        Map.mapKeys credToDRep ((vState ^. vsDRepsL) `Map.restrictKeys` creds)
+    Nothing ->
+      -- Whenever predefined `AlwaysAbstain` or `AlwaysNoConfidence` are
+      -- requested we are forced to iterate over all accounts and find those
+      -- delegations.
+      Map.foldlWithKey'
+        ( \m cred cas ->
+            case cas ^. dRepDelegationAccountStateL of
+              Just drep
+                | Set.null dreps || drep `Set.member` dreps ->
+                    Map.insertWith (<>) drep (Set.singleton cred) m
+              _ ->
+                m
+        )
+        Map.empty
+        (dState ^. accountsL . accountsMapL)
+  where
+    dState = nes ^. nesEsL . esLStateL . lsCertStateL . certDStateL
+    vState = nes ^. nesEsL . esLStateL . lsCertStateL . certVStateL
+    -- Find all credentials for requested DReps, but only when we don't care
+    -- about predefined DReps
+    getDRepCreds ds = do
+      guard $ not $ Set.null ds
+      Set.fromList <$> traverse dRepToCred (Set.elems ds)
+
 -- | Query DRep stake distribution. Note that this can be an expensive query because there
 -- is a chance that current distribution has not been fully computed yet.
 queryDRepStakeDistr ::

libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs

@@ -14,6 +14,7 @@ import Cardano.Ledger.Api.State.Query (
   MemberStatus (..),
   NextEpochChange (..),
   queryCommitteeMembersState,
+  queryDRepDelegations,
   queryDRepState,
  )
 import Cardano.Ledger.BaseTypes
@@ -198,6 +199,39 @@ spec = do
         expectQueryResult (Set.singleton c1) mempty mempty $
           [(c1, CommitteeMemberState (MemberAuthorized hk1) Active (Just c1Expiry) NoChangeExpected)]
 
+  it "queryDRepDelegationState" $ do
+    (credDrep, delegator, _) <- setupSingleDRep 1_000_000
+
+    kh <- freshKeyHash
+    let cred = KeyHashObj kh
+    _ <- registerStakeCredential cred
+    _ <- delegateToDRep cred (Coin 2_000_000) DRepAlwaysAbstain
+
+    kh2 <- freshKeyHash
+    let cred2 = KeyHashObj kh2
+    _ <- registerStakeCredential cred2
+    _ <- delegateToDRep cred2 (Coin 3_000_000) DRepAlwaysNoConfidence
+
+    let realDRepCred = DRepCredential credDrep
+
+    nes <- getsNES id
+    let abstainDelegations =
+          Map.singleton DRepAlwaysAbstain (Set.fromList [cred])
+        noConfidenceDelegations =
+          Map.singleton DRepAlwaysNoConfidence (Set.fromList [cred2])
+        realDRepDelegations = Map.singleton realDRepCred (Set.fromList [delegator])
+        expectedAllDelegations =
+          realDRepDelegations
+            <> abstainDelegations
+            <> noConfidenceDelegations
+    queryDRepDelegations nes mempty `shouldBe` expectedAllDelegations
+    queryDRepDelegations nes (Set.singleton DRepAlwaysAbstain)
+      `shouldBe` abstainDelegations
+    queryDRepDelegations nes (Set.singleton DRepAlwaysNoConfidence)
+      `shouldBe` noConfidenceDelegations
+    queryDRepDelegations nes (Set.singleton realDRepCred)
+      `shouldBe` realDRepDelegations
+
   it "Committee queries" $ whenPostBootstrap $ do
     (drep, _, _) <- setupSingleDRep 1_000_000
     (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.18.0.0
 
+* Export `credToDRep` and `dRepToCred`
 * Deprecate `PoolParams` in favor of `StakePoolState`. #5196
   * Move the `PoolParams` module to `Cardano.Ledger.State.StakePool` and export from there.
   * Add the `StakePoolState` data type to the new module.

libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs

@@ -11,6 +11,8 @@
 module Cardano.Ledger.DRep (
   DRep (DRepCredential, DRepKeyHash, DRepScriptHash, DRepAlwaysAbstain, DRepAlwaysNoConfidence),
   DRepState (..),
+  credToDRep,
+  dRepToCred,
   drepExpiryL,
   drepAnchorL,
   drepDepositL,