Add a query for vote delegatees (#502)

For context, see [this issue on `cardano-cli`](IntersectMBO/cardano-cli#423): We want to have a query returns the vote delegatees, given staking credentials. This functionality is currently missing (here, and thus in the `cardano-api`, which I want to use in the CLI).
IntersectMBO · Nov 13, 2023 · 968cc64 · 968cc64
2 parents d490501 + ac8a4c0
commit 968cc64
Show file tree

Hide file tree

Showing 3 changed files with 58 additions and 3 deletions.
diff --git a/...sensus-cardano/changelog.d/20231110_165234_carl.hammann_vote_delegatee_query.md b/...sensus-cardano/changelog.d/20231110_165234_carl.hammann_vote_delegatee_query.md
@@ -0,0 +1,23 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Add a query for vote delegatees: GetFilteredVoteDelegatees
diff --git a/...onsensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs b/...onsensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/NetworkProtocolVersion.hs
@@ -35,7 +35,7 @@ data ShelleyNodeToClientVersion =
     -- | New queries introduced: GetStakeDelegDeposits
   | ShelleyNodeToClientVersion7
 
-    -- | New queries introduced: GetConstitutionHash
+    -- | New queries introduced: GetConstitutionHash, GetFilteredVoteDelegatees
   | ShelleyNodeToClientVersion8
   deriving (Show, Eq, Ord, Enum, Bounded)
 

diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs
@@ -49,8 +49,8 @@ import qualified Cardano.Ledger.Shelley.LedgerState as SL (RewardAccounts,
 import qualified Cardano.Ledger.Shelley.PParams as SL (emptyPPPUpdates)
 import qualified Cardano.Ledger.Shelley.RewardProvenance as SL
                      (RewardProvenance)
-import           Cardano.Ledger.UMap (UMap (..), rdReward, umElemRDPair,
-                     umElemSPool)
+import           Cardano.Ledger.UMap (UMap (..), rdReward, umElemDRep,
+                     umElemRDPair, umElemSPool)
 import           Codec.CBOR.Decoding (Decoder)
 import qualified Codec.CBOR.Decoding as CBOR
 import           Codec.CBOR.Encoding (Encoding)
@@ -102,6 +102,10 @@ type Delegations c =
   Map (SL.Credential 'SL.Staking c)
       (SL.KeyHash 'SL.StakePool c)
 
+type VoteDelegatees c =
+  Map (SL.Credential 'SL.Staking c)
+      (SL.DRep c)
+
 data instance BlockQuery (ShelleyBlock proto era) :: Type -> Type where
   GetLedgerTip :: BlockQuery (ShelleyBlock proto era) (Point (ShelleyBlock proto era))
   GetEpochNo :: BlockQuery (ShelleyBlock proto era) EpochNo
@@ -258,6 +262,10 @@ data instance BlockQuery (ShelleyBlock proto era) :: Type -> Type where
     -> Set SL.MemberStatus
     -> BlockQuery (ShelleyBlock proto era) (Maybe (SL.CommitteeMembersState (EraCrypto era)))
 
+  GetFilteredVoteDelegatees
+    :: Set (SL.Credential 'SL.Staking (EraCrypto era))
+    -> BlockQuery (ShelleyBlock proto era) (VoteDelegatees (EraCrypto era))
+
   -- WARNING: please add new queries to the end of the list and stick to this
   -- order in all other pattern matches on queries. This helps in particular
   -- with the en/decoders, as we want the CBOR tags to be ordered.
@@ -406,6 +414,8 @@ instance (ShelleyCompatible proto era, ProtoCrypto proto ~ crypto) => QueryLedge
           SL.queryDRepStakeDistr st dreps
         GetCommitteeMembersState coldCreds hotCreds statuses ->
           SL.queryCommitteeMembersState coldCreds hotCreds statuses st
+        GetFilteredVoteDelegatees stakeCreds ->
+          getFilteredVoteDelegatees st stakeCreds
     where
       lcfg    = configLedger $ getExtLedgerCfg cfg
       globals = shelleyLedgerGlobals lcfg
@@ -551,6 +561,12 @@ instance SameDepIndex (BlockQuery (ShelleyBlock proto era)) where
   sameDepIndex GetDRepStakeDistr{} _ = Nothing
   sameDepIndex GetCommitteeMembersState{} GetCommitteeMembersState{} = Just Refl
   sameDepIndex GetCommitteeMembersState{} _ = Nothing
+  sameDepIndex (GetFilteredVoteDelegatees stakeCreds) (GetFilteredVoteDelegatees stakeCreds')
+    | stakeCreds == stakeCreds'
+    = Just Refl
+    | otherwise
+    = Nothing
+  sameDepIndex GetFilteredVoteDelegatees {} _ = Nothing
 
 deriving instance Eq   (BlockQuery (ShelleyBlock proto era) result)
 deriving instance Show (BlockQuery (ShelleyBlock proto era) result)
@@ -585,6 +601,7 @@ instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock prot
       GetDRepState {}                            -> show
       GetDRepStakeDistr {}                       -> show
       GetCommitteeMembersState {}                -> show
+      GetFilteredVoteDelegatees {}               -> show
 
 -- | Is the given query supported by the given 'ShelleyNodeToClientVersion'?
 querySupportedVersion :: BlockQuery (ShelleyBlock proto era) result -> ShelleyNodeToClientVersion -> Bool
@@ -617,6 +634,7 @@ querySupportedVersion = \case
     GetDRepState {}                            -> (>= v8)
     GetDRepStakeDistr {}                       -> (>= v8)
     GetCommitteeMembersState {}                -> (>= v8)
+    GetFilteredVoteDelegatees {}               -> (>= v8)
     -- WARNING: when adding a new query, a new @ShelleyNodeToClientVersionX@
     -- must be added. See #2830 for a template on how to do this.
   where
@@ -663,6 +681,15 @@ getFilteredDelegationsAndRewardAccounts ss creds =
     filteredRwdAcnts =
       Map.mapMaybe (\e -> fromCompact . rdReward <$> umElemRDPair e) umElemsRestricted
 
+getFilteredVoteDelegatees ::
+     SL.NewEpochState era
+  -> Set (SL.Credential 'SL.Staking (EraCrypto era))
+  -> VoteDelegatees (EraCrypto era)
+getFilteredVoteDelegatees ss creds = Map.mapMaybe umElemDRep umElemsRestricted
+  where
+    UMap umElems _ = SL.dsUnified $ getDState ss
+    umElemsRestricted = Map.restrictKeys umElems creds
+
 {-------------------------------------------------------------------------------
   Serialisation
 -------------------------------------------------------------------------------}
@@ -727,6 +754,8 @@ encodeShelleyQuery query = case query of
       CBOR.encodeListLen 2 <> CBOR.encodeWord8 26 <> LC.toEraCBOR @era dreps
     GetCommitteeMembersState coldCreds hotCreds statuses ->
       CBOR.encodeListLen 4 <> CBOR.encodeWord8 27 <> toCBOR coldCreds <> toCBOR hotCreds <> LC.toEraCBOR @era statuses
+    GetFilteredVoteDelegatees stakeCreds ->
+      CBOR.encodeListLen 2 <> CBOR.encodeWord8 28 <> LC.toEraCBOR @era stakeCreds
 
 decodeShelleyQuery ::
      forall era proto. ShelleyBasedEra era
@@ -767,6 +796,7 @@ decodeShelleyQuery = do
         hotCreds <- fromCBOR
         statuses <- LC.fromEraCBOR @era
         return $ SomeSecond $ GetCommitteeMembersState coldCreds hotCreds statuses
+      (2, 28) -> SomeSecond . GetFilteredVoteDelegatees <$> LC.fromEraCBOR @era
       _       -> fail $
         "decodeShelleyQuery: invalid (len, tag): (" <>
         show len <> ", " <> show tag <> ")"
@@ -804,6 +834,7 @@ encodeShelleyResult v query = case query of
     GetDRepState {}                            -> LC.toEraCBOR @era
     GetDRepStakeDistr {}                       -> LC.toEraCBOR @era
     GetCommitteeMembersState {}                -> LC.toEraCBOR @era
+    GetFilteredVoteDelegatees {}               -> LC.toEraCBOR @era
 
 decodeShelleyResult ::
      forall proto era result. ShelleyCompatible proto era
@@ -839,6 +870,7 @@ decodeShelleyResult v query = case query of
     GetDRepState {}                            -> LC.fromEraCBOR @era
     GetDRepStakeDistr {}                       -> LC.fromEraCBOR @era
     GetCommitteeMembersState {}                -> LC.fromEraCBOR @era
+    GetFilteredVoteDelegatees {}               -> LC.fromEraCBOR @era
 
 currentPParamsEnDecoding ::
      forall era s.