Skip to content

Commit 6538fac

Browse files
intricateintricate
committed
Add GetFilteredDelegationsAndRewardAccounts ledger query
1 parent 7700288 commit 6538fac

File tree

2 files changed

+92
-41
lines changed
  • ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley
  • ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger

2 files changed

+92
-41
lines changed

‎ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -123,6 +123,9 @@ instance Eq (Some (Query Block)) where
123123
Some (GetCBOR query) == Some (GetCBOR query') =
124124
Some query == Some query'
125125
Some (GetCBOR _) == _ = False
126+
Some (GetFilteredDelegationsAndRewardAccounts creds) == Some (GetFilteredDelegationsAndRewardAccounts creds') =
127+
creds == creds'
128+
Some (GetFilteredDelegationsAndRewardAccounts _) == _ = False
126129

127130
deriving instance Show (Some (Query Block))
128131

@@ -190,6 +193,7 @@ instance Arbitrary (Some (Query Block)) where
190193
, pure $ Some GetStakeDistribution
191194
, pure $ Some GetCurrentLedgerState
192195
, (\(Some q) -> Some (GetCBOR q)) <$> arbitrary
196+
, Some . GetFilteredDelegationsAndRewardAccounts <$> arbitrary
193197
]
194198

195199
instance Arbitrary SomeResult where
@@ -204,6 +208,7 @@ instance Arbitrary SomeResult where
204208
, (\(SomeResult q r) ->
205209
SomeResult (GetCBOR q) (mkSerialised (encodeShelleyResult q) r)) <$>
206210
arbitrary
211+
, SomeResult <$> (GetFilteredDelegationsAndRewardAccounts <$> arbitrary) <*> arbitrary
207212
]
208213

209214
instance Arbitrary (NonMyopicMemberRewards TPraosMockCrypto) where
@@ -266,6 +271,9 @@ instance Arbitrary Natural where
266271
Generators for cardano-ledger-specs
267272
-------------------------------------------------------------------------------}
268273

274+
instance Crypto c => Arbitrary (SL.StakeCreds c) where
275+
arbitrary = SL.StakeCreds <$> arbitrary
276+
269277
instance Arbitrary SL.Nonce where
270278
arbitrary = oneof
271279
[ return SL.NeutralNonce

‎ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

Lines changed: 84 additions & 41 deletions
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,9 @@ import Control.Monad.Except
5151
import Data.Functor.Identity
5252
import Data.Kind (Type)
5353
import Data.Map.Strict (Map)
54+
import qualified Data.Map.Strict as Map
5455
import Data.Set (Set)
56+
import qualified Data.Set as Set
5557
import Data.Type.Equality ((:~:) (Refl), apply)
5658
import GHC.Generics (Generic)
5759

@@ -289,6 +291,8 @@ newtype NonMyopicMemberRewards c = NonMyopicMemberRewards {
289291
deriving stock (Show)
290292
deriving newtype (Eq)
291293

294+
type Delegations c = Map (SL.Credential 'SL.Staking c) (SL.KeyHash 'SL.StakePool c)
295+
292296
instance Crypto c => Serialise (NonMyopicMemberRewards c) where
293297
encode = toCBOR . unNonMyopicMemberRewards
294298
decode = NonMyopicMemberRewards <$> fromCBOR
@@ -336,6 +340,10 @@ instance TPraosCrypto c => QueryLedger (ShelleyBlock c) where
336340
:: Query (ShelleyBlock c) result
337341
-> Query (ShelleyBlock c) (Serialised result)
338342

343+
GetFilteredDelegationsAndRewardAccounts
344+
:: Set (SL.Credential 'SL.Staking c)
345+
-> Query (ShelleyBlock c) (Delegations c, SL.RewardAccounts c)
346+
339347

340348
answerQuery cfg query st = case query of
341349
GetLedgerTip -> ledgerTip st
@@ -350,6 +358,11 @@ instance TPraosCrypto c => QueryLedger (ShelleyBlock c) where
350358
GetCurrentLedgerState -> getCurrentLedgerState $ shelleyState st
351359
GetCBOR query' -> mkSerialised (encodeShelleyResult query') $
352360
answerQuery cfg query' st
361+
GetFilteredDelegationsAndRewardAccounts creds ->
362+
getFilteredDelegationsAndRewardAccounts
363+
(shelleyLedgerGlobals cfg)
364+
(shelleyState st)
365+
creds
353366
where
354367
globals = shelleyLedgerGlobals cfg
355368

@@ -399,21 +412,30 @@ instance TPraosCrypto c => QueryLedger (ShelleyBlock c) where
399412
= apply Refl <$> eqQuery q q'
400413
eqQuery (GetCBOR _) _
401414
= Nothing
415+
eqQuery (GetFilteredDelegationsAndRewardAccounts creds)
416+
(GetFilteredDelegationsAndRewardAccounts creds')
417+
| creds == creds'
418+
= Just Refl
419+
| otherwise
420+
= Nothing
421+
eqQuery (GetFilteredDelegationsAndRewardAccounts _) _
422+
= Nothing
402423

403424
deriving instance Eq (Query (ShelleyBlock c) result)
404425
deriving instance Show (Query (ShelleyBlock c) result)
405426

406427
instance Crypto c => ShowQuery (Query (ShelleyBlock c)) where
407-
showResult GetLedgerTip = show
408-
showResult GetEpochNo = show
409-
showResult (GetNonMyopicMemberRewards {}) = show
410-
showResult GetCurrentPParams = show
411-
showResult GetProposedPParamsUpdates = show
412-
showResult GetStakeDistribution = show
413-
showResult (GetFilteredUTxO {}) = show
414-
showResult GetUTxO = show
415-
showResult GetCurrentLedgerState = show
416-
showResult (GetCBOR {}) = show
428+
showResult GetLedgerTip = show
429+
showResult GetEpochNo = show
430+
showResult (GetNonMyopicMemberRewards {}) = show
431+
showResult GetCurrentPParams = show
432+
showResult GetProposedPParamsUpdates = show
433+
showResult GetStakeDistribution = show
434+
showResult (GetFilteredUTxO {}) = show
435+
showResult GetUTxO = show
436+
showResult GetCurrentLedgerState = show
437+
showResult (GetCBOR {}) = show
438+
showResult (GetFilteredDelegationsAndRewardAccounts {}) = show
417439

418440
{-------------------------------------------------------------------------------
419441
ValidateEnvelope
@@ -454,6 +476,22 @@ getCurrentLedgerState =
454476
nukeUtxOSet :: SL.UTxOState c -> SL.UTxOState c
455477
nukeUtxOSet us = us { SL._utxo = SL.UTxO mempty }
456478

479+
getDState :: SL.ShelleyState c -> SL.DState c
480+
getDState = SL._dstate . SL._delegationState . SL.esLState . SL.nesEs
481+
482+
getFilteredDelegationsAndRewardAccounts :: SL.Globals
483+
-> SL.ShelleyState c
484+
-> Set (SL.Credential 'SL.Staking c)
485+
-> (Delegations c, SL.RewardAccounts c)
486+
getFilteredDelegationsAndRewardAccounts globals ss creds =
487+
(filteredDelegations, filteredRwdAcnts)
488+
where
489+
network = SL.networkId globals
490+
rwdAcnts = Set.map (SL.RewardAcnt network) creds
491+
dstate = getDState ss
492+
filteredDelegations = Map.restrictKeys (SL._delegations dstate) creds
493+
filteredRwdAcnts = Map.restrictKeys (SL._rewards dstate) rwdAcnts
494+
457495
{-------------------------------------------------------------------------------
458496
Serialisation
459497
-------------------------------------------------------------------------------}
@@ -525,53 +563,58 @@ encodeShelleyQuery query = case query of
525563
CBOR.encodeListLen 1 <> CBOR.encodeWord8 8
526564
GetCBOR query' ->
527565
CBOR.encodeListLen 2 <> CBOR.encodeWord8 9 <> encodeShelleyQuery query'
566+
GetFilteredDelegationsAndRewardAccounts creds ->
567+
CBOR.encodeListLen 2 <> CBOR.encodeWord8 10 <> toCBOR creds
528568

529569
decodeShelleyQuery :: Crypto c => Decoder s (Some (Query (ShelleyBlock c)))
530570
decodeShelleyQuery = do
531571
len <- CBOR.decodeListLen
532572
tag <- CBOR.decodeWord8
533573
case (len, tag) of
534-
(1, 0) -> return $ Some GetLedgerTip
535-
(1, 1) -> return $ Some GetEpochNo
536-
(2, 2) -> Some . GetNonMyopicMemberRewards <$> fromCBOR
537-
(1, 3) -> return $ Some GetCurrentPParams
538-
(1, 4) -> return $ Some GetProposedPParamsUpdates
539-
(1, 5) -> return $ Some GetStakeDistribution
540-
(2, 6) -> Some . GetFilteredUTxO <$> fromCBOR
541-
(1, 7) -> return $ Some GetUTxO
542-
(1, 8) -> return $ Some GetCurrentLedgerState
543-
(2, 9) -> (\(Some q) -> Some (GetCBOR q)) <$> decodeShelleyQuery
544-
_ -> fail $
574+
(1, 0) -> return $ Some GetLedgerTip
575+
(1, 1) -> return $ Some GetEpochNo
576+
(2, 2) -> Some . GetNonMyopicMemberRewards <$> fromCBOR
577+
(1, 3) -> return $ Some GetCurrentPParams
578+
(1, 4) -> return $ Some GetProposedPParamsUpdates
579+
(1, 5) -> return $ Some GetStakeDistribution
580+
(2, 6) -> Some . GetFilteredUTxO <$> fromCBOR
581+
(1, 7) -> return $ Some GetUTxO
582+
(1, 8) -> return $ Some GetCurrentLedgerState
583+
(2, 9) -> (\(Some q) -> Some (GetCBOR q)) <$> decodeShelleyQuery
584+
(2, 10) -> Some . GetFilteredDelegationsAndRewardAccounts <$> fromCBOR
585+
_ -> fail $
545586
"decodeShelleyQuery: invalid (len, tag): (" <>
546587
show len <> ", " <> show tag <> ")"
547588

548589
encodeShelleyResult
549590
:: Crypto c
550591
=> Query (ShelleyBlock c) result -> result -> Encoding
551592
encodeShelleyResult query = case query of
552-
GetLedgerTip -> encodePoint encode
553-
GetEpochNo -> encode
554-
GetNonMyopicMemberRewards {} -> encode
555-
GetCurrentPParams -> toCBOR
556-
GetProposedPParamsUpdates -> toCBOR
557-
GetStakeDistribution -> toCBOR
558-
GetFilteredUTxO {} -> toCBOR
559-
GetUTxO -> toCBOR
560-
GetCurrentLedgerState -> toCBOR
561-
GetCBOR {} -> encode
593+
GetLedgerTip -> encodePoint encode
594+
GetEpochNo -> encode
595+
GetNonMyopicMemberRewards {} -> encode
596+
GetCurrentPParams -> toCBOR
597+
GetProposedPParamsUpdates -> toCBOR
598+
GetStakeDistribution -> toCBOR
599+
GetFilteredUTxO {} -> toCBOR
600+
GetUTxO -> toCBOR
601+
GetCurrentLedgerState -> toCBOR
602+
GetCBOR {} -> encode
603+
GetFilteredDelegationsAndRewardAccounts {} -> toCBOR
562604

563605
decodeShelleyResult
564606
:: Crypto c
565607
=> Query (ShelleyBlock c) result
566608
-> forall s. Decoder s result
567609
decodeShelleyResult query = case query of
568-
GetLedgerTip -> decodePoint decode
569-
GetEpochNo -> decode
570-
GetNonMyopicMemberRewards {} -> decode
571-
GetCurrentPParams -> fromCBOR
572-
GetProposedPParamsUpdates -> fromCBOR
573-
GetStakeDistribution -> fromCBOR
574-
GetFilteredUTxO {} -> fromCBOR
575-
GetUTxO -> fromCBOR
576-
GetCurrentLedgerState -> fromCBOR
577-
GetCBOR {} -> decode
610+
GetLedgerTip -> decodePoint decode
611+
GetEpochNo -> decode
612+
GetNonMyopicMemberRewards {} -> decode
613+
GetCurrentPParams -> fromCBOR
614+
GetProposedPParamsUpdates -> fromCBOR
615+
GetStakeDistribution -> fromCBOR
616+
GetFilteredUTxO {} -> fromCBOR
617+
GetUTxO -> fromCBOR
618+
GetCurrentLedgerState -> fromCBOR
619+
GetCBOR {} -> decode
620+
GetFilteredDelegationsAndRewardAccounts {} -> fromCBOR

0 commit comments

Comments
 (0)