From aed7d47295b5453d5a0cc2d4ce6c3e5df137e4dd Mon Sep 17 00:00:00 2001 From: Kostas Dermentzis Date: Thu, 7 Apr 2022 23:32:46 +0300 Subject: [PATCH] Introduce RestrainedRewards event --- .../src/Cardano/Ledger/Shelley/LedgerState.hs | 25 +++++++++++++------ .../src/Cardano/Ledger/Shelley/Rewards.hs | 12 ++++++--- .../Cardano/Ledger/Shelley/Rules/NewEpoch.hs | 4 ++- .../Test/Cardano/Ledger/Shelley/Rewards.hs | 2 +- 4 files changed, 30 insertions(+), 13 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index f954cc508c6..228fa4d603b 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs @@ -1260,7 +1260,7 @@ applyRUpd :: EpochState era -> EpochState era applyRUpd ru es = - let (es', _) = applyRUpd' ru es + let (es', _, _, _) = applyRUpd' ru es in es' applyRUpd' :: @@ -1268,15 +1268,21 @@ applyRUpd' :: ) => RewardUpdate (Crypto era) -> EpochState era -> - (EpochState era, Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))) + ( EpochState era, + Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), + Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), + Set (Credential 'Staking (Crypto era)) + ) applyRUpd' ru - es@(EpochState as ss ls pr pp _nm) = (EpochState as' ss ls' pr pp nm', registered) + es@(EpochState as ss ls pr pp _nm) = + (EpochState as' ss ls' pr pp nm', registered, eraIgnored, unregistered) where utxoState_ = lsUTxOState ls delegState = lsDPState ls dState = dpsDState delegState - (registered, totalUnregistered) = filterAllRewards (rs ru) es + (registered, eraIgnored, unregistered, totalUnregistered) = + filterAllRewards (rs ru) es registeredAggregated = aggregateRewards pp registered as' = as @@ -1302,9 +1308,13 @@ filterAllRewards :: ) => Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))) -> EpochState era -> - (Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), Coin) + ( Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), + Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era))), + Set (Credential 'Staking (Crypto era)), + Coin + ) filterAllRewards rs' (EpochState _as _ss ls pr _pp _nm) = - (registered, totalUnregistered) + (registered, eraIgnored, unregistered, totalUnregistered) where delegState = lsDPState ls dState = dpsDState delegState @@ -1313,7 +1323,8 @@ filterAllRewards rs' (EpochState _as _ss ls pr _pp _nm) = (\k _ -> eval (k ∈ dom (rewards dState))) rs' totalUnregistered = fold $ aggregateRewards pr unregRU - registered = filterRewards pr regRU + unregistered = Map.keysSet unregRU + (registered, eraIgnored) = filterRewards pr regRU decayFactor :: Float decayFactor = 0.9 diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs index 38644d95d25..dc2919e9c7b 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rewards.hs @@ -187,11 +187,15 @@ filterRewards :: (HasField "_protocolVersion" pp ProtVer) => pp -> Map (Credential 'Staking crypto) (Set (Reward crypto)) -> - Map (Credential 'Staking crypto) (Set (Reward crypto)) + ( Map (Credential 'Staking crypto) (Set (Reward crypto)), + Map (Credential 'Staking crypto) (Set (Reward crypto)) + ) filterRewards pp rewards = if HardForks.aggregatedRewards pp - then rewards - else Map.map (Set.singleton . Set.findMin) rewards + then (rewards, Map.empty) + else + let mp = Map.map Set.deleteFindMin rewards + in (Map.map (Set.singleton . fst) mp, Map.filter (not . Set.null) $ Map.map snd mp) aggregateRewards :: forall crypto pp. @@ -200,7 +204,7 @@ aggregateRewards :: Map (Credential 'Staking crypto) (Set (Reward crypto)) -> Map (Credential 'Staking crypto) Coin aggregateRewards pp rewards = - Map.map (foldMap' rewardAmount) $ filterRewards pp rewards + Map.map (foldMap' rewardAmount) $ fst $ filterRewards pp rewards data LeaderOnlyReward crypto = LeaderOnlyReward { lRewardPool :: !(KeyHash 'StakePool crypto), diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs index bc112444523..eb033bfd992 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/NewEpoch.hs @@ -78,6 +78,7 @@ instance data NewEpochEvent era = DeltaRewardEvent (Event (Core.EraRule "RUPD" era)) + | RestrainedRewards EpochNo (Map.Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))) (Set (Credential 'Staking (Crypto era))) | TotalRewardEvent EpochNo (Map.Map (Credential 'Staking (Crypto era)) (Set (Reward (Crypto era)))) | EpochEvent (Event (Core.EraRule "EPOCH" era)) | MirEvent (Event (Core.EraRule "MIR" era)) @@ -156,7 +157,8 @@ newEpochTransition = do let updateRewards ru'@(RewardUpdate dt dr rs_ df _) = do let totRs = sumRewards (esPrevPp es) rs_ Val.isZero (dt <> (dr <> toDeltaCoin totRs <> df)) ?! CorruptRewardUpdate ru' - let (es', regRU) = applyRUpd' ru' es + let (es', regRU, eraIgnored, unregistered) = applyRUpd' ru' es + tellEvent $ RestrainedRewards e eraIgnored unregistered -- This event (which is only generated once per epoch) must be generated even if the -- map is empty (db-sync depends on it). tellEvent $ TotalRewardEvent e regRU diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs index ecad4482614..cb1a1058dc8 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Rewards.hs @@ -782,7 +782,7 @@ eventsMirrorRewards events nes = same eventRew compRew (completed, lastevent) = complete pulser total = getMostRecentTotalRewardEvent events aggevent = aggIncrementalRewardEvents events - (aggFilteredEvent, _) = filterAllRewards aggevent (nesEs nes) + (aggFilteredEvent, _, _, _) = filterAllRewards aggevent (nesEs nes) same x y = withMaxSuccess 1 $ counterexample message (x === y) where message =