force the reward pulser to completion sooner

Some tools, such ad db-sync and the stake credential history tool rely
on being able to inspect the ledger state for the reward update. If the
pulser does not finish before the end of the epoch (which has happened
on the Shelley-QA network, see
IntersectMBO/cardano-db-sync#882) then the
pulser is forced to completion at the moment it is applied, as is
therefore invisible to downstream tools.

To solve this problem, we force completion of the reward pulser by
(2k/f)-many slots before the end of the epoch (one day on mainnet).

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs

@@ -1115,7 +1115,20 @@ startStep slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) max
       numPools = fromIntegral (Map.size poolParams)
       k = fromIntegral secparam
       f = unboundRational (activeSlotVal asc)
-      pulseSize = max 1 (ceiling ((numPools * f) / (6 * k)))
+
+      -- We expect approximately (10k/f)-many blocks to be produced each epoch.
+      -- The reward calculation begins (4k/f)-many slots into the epoch,
+      -- and we guarantee that it ends (2k/f)-many slots before the end
+      -- of the epoch (to allow tools such as db-sync to see the reward
+      -- values in advance of them being applied to the ledger state).
+      --
+      -- Therefore to evenly space out the reward calculation, we divide
+      -- the number of stake pools by 4k/f in order to determine how many
+      -- stake pools' rewards we should calculate each block.
+      -- If it does not finish in this amount of time, the calculation is
+      -- forced to completion.
+      pulseSize = max 1 (ceiling ((numPools * f) / (4 * k)))
+
       Coin reserves = _reserves acnt
       ds = _dstate $ _delegationState ls
       -- reserves and rewards change

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Rupd.hs

@@ -102,6 +102,18 @@ instance
   initialRules = [pure SNothing]
   transitionRules = [rupdTransition]
 
+-- | The Goldilocks labeling of when to do the reward calculation.
+data RewardTiming = RewardsTooEarly | RewardsJustRight | RewardsTooLate
+
+determineRewardTiming :: SlotNo -> SlotNo -> SlotNo -> RewardTiming
+determineRewardTiming currentSlot startAftterSlot endSlot =
+  if currentSlot > endSlot
+    then RewardsTooLate
+    else
+      if currentSlot <= startAftterSlot
+        then RewardsTooEarly
+        else RewardsJustRight
+
 rupdTransition ::
   ( Era era,
     HasField "_a0" (Core.PParams era) NonNegativeInterval,
@@ -114,7 +126,7 @@ rupdTransition ::
   TransitionRule (RUPD era)
 rupdTransition = do
   TRC (RupdEnv b es, ru, s) <- judgmentContext
-  (slotsPerEpoch, slot, maxLL, asc, k) <- liftSTS $ do
+  (slotsPerEpoch, slot, slotForce, maxLL, asc, k) <- liftSTS $ do
     ei <- asks epochInfo
     sr <- asks randomnessStabilisationWindow
     e <- epochInfoEpoch ei s
@@ -123,14 +135,21 @@ rupdTransition = do
     maxLL <- asks maxLovelaceSupply
     asc <- asks activeSlotCoeff
     k <- asks securityParameter -- Maximum number of blocks we are allowed to roll back
-    return (slotsPerEpoch, slot, maxLL, asc, k)
+    return (slotsPerEpoch, slot, (slot +* Duration sr), maxLL, asc, k)
   let maxsupply = Coin (fromIntegral maxLL)
-  case s <= slot of
+  case determineRewardTiming s slot slotForce of
     -- Waiting for the stabiliy point, do nothing, keep waiting
-    True -> pure SNothing
+    RewardsTooEarly -> pure SNothing
     -- More blocks to come, get things started or take a step
-    False ->
+    RewardsJustRight ->
       case ru of
         SNothing -> liftSTS $ runProvM $ pure $ SJust $ fst $ startStep slotsPerEpoch b es maxsupply asc k
         (SJust p@(Pulsing _ _)) -> liftSTS $ runProvM $ (SJust <$> pulseStep p)
         (SJust p@(Complete _)) -> pure (SJust p)
+    -- Time to force the completion of the pulser so that downstream tools such as db-sync
+    -- have time to see the reward update before the epoch boundary rollover.
+    RewardsTooLate ->
+      case ru of
+        SNothing -> SJust <$> (liftSTS . runProvM . completeStep . fst $ startStep slotsPerEpoch b es maxsupply asc k)
+        SJust p@(Pulsing _ _) -> SJust <$> (liftSTS . runProvM . completeStep $ p)
+        complete@(SJust (Complete _)) -> pure complete

eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolLifetime.hs

@@ -13,6 +13,7 @@
 module Test.Cardano.Ledger.Shelley.Examples.PoolLifetime
   ( makePulser,
     makePulser',
+    makeCompletedPulser,
     poolLifetimeExample,
   )
 where
@@ -39,8 +40,9 @@ import Cardano.Ledger.Shelley.API (getRewardProvenance)
 import qualified Cardano.Ledger.Shelley.EpochBoundary as EB
 import Cardano.Ledger.Shelley.LedgerState
   ( NewEpochState (..),
-    PulsingRewUpdate,
+    PulsingRewUpdate (..),
     RewardUpdate (..),
+    completeRupd,
     decayFactor,
     emptyRewardUpdate,
     startStep,
@@ -94,6 +96,7 @@ import Cardano.Protocol.TPraos
   )
 import Cardano.Protocol.TPraos.BHeader (BHeader, bhHash, hashHeaderToNonce)
 import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
+import Control.Provenance (runProvM)
 import Data.Default.Class (def)
 import Data.Foldable (fold)
 import Data.Group (invert)
@@ -353,8 +356,16 @@ makePulser' ::
   PulsingRewUpdate (Crypto era)
 makePulser' = makePulser (BlocksMade mempty)
 
+makeCompletedPulser ::
+  forall era.
+  (C.UsesPP era) =>
+  BlocksMade (Crypto era) ->
+  ChainState era ->
+  PulsingRewUpdate (Crypto era)
+makeCompletedPulser bs cs = Complete . runShelleyBase . runProvM . completeRupd $ makePulser bs cs
+
 pulserEx2 :: forall c. (ExMock (Crypto (ShelleyEra c))) => PulsingRewUpdate c
-pulserEx2 = makePulser (BlocksMade mempty) expectedStEx1
+pulserEx2 = makeCompletedPulser (BlocksMade mempty) expectedStEx1
 
 expectedStEx2 ::
   forall c.
@@ -486,7 +497,7 @@ blockEx4 =
     (mkOCert (coreNodeKeysBySchedule @(ShelleyEra c) ppEx 190) 0 (KESPeriod 0))
 
 pulserEx4 :: forall c. (ExMock c) => PulsingRewUpdate c
-pulserEx4 = makePulser (BlocksMade mempty) expectedStEx3
+pulserEx4 = makeCompletedPulser (BlocksMade mempty) expectedStEx3
 
 rewardUpdateEx4 :: forall c. RewardUpdate c
 rewardUpdateEx4 =
@@ -620,7 +631,7 @@ rewardUpdateEx6 =
     }
 
 pulserEx6 :: forall c. (ExMock c) => PulsingRewUpdate c
-pulserEx6 = makePulser (BlocksMade mempty) expectedStEx5
+pulserEx6 = makeCompletedPulser (BlocksMade mempty) expectedStEx5
 
 expectedStEx6 :: forall c. (ExMock (Crypto (ShelleyEra c))) => ChainState (ShelleyEra c)
 expectedStEx6 =
@@ -735,7 +746,7 @@ nonMyopicEx8 =
     rewardPot8
 
 pulserEx8 :: forall c. (ExMock c) => PulsingRewUpdate c
-pulserEx8 = makePulser (BlocksMade $ Map.singleton (hk Cast.alicePoolKeys) 1) expectedStEx7
+pulserEx8 = makeCompletedPulser (BlocksMade $ Map.singleton (hk Cast.alicePoolKeys) 1) expectedStEx7
 
 rewardUpdateEx8 :: forall c. Cr.Crypto c => RewardUpdate c
 rewardUpdateEx8 =
@@ -1027,7 +1038,7 @@ nonMyopicEx11 =
     (Coin 0)
 
 pulserEx11 :: forall c. (ExMock c) => PulsingRewUpdate c
-pulserEx11 = makePulser (BlocksMade mempty) expectedStEx10
+pulserEx11 = makeCompletedPulser (BlocksMade mempty) expectedStEx10
 
 rewardUpdateEx11 :: forall c. Cr.Crypto c => RewardUpdate c
 rewardUpdateEx11 =
@@ -1121,7 +1132,7 @@ poolLifetimeExample =
   testGroup
     "pool lifetime"
     [ testCase "initial registrations" $ testCHAINExample poolLifetime1,
-      testCase "elegate stake and create reward update" $ testCHAINExample poolLifetime2,
+      testCase "delegate stake and create reward update" $ testCHAINExample poolLifetime2,
       testCase "new epoch changes" $ testCHAINExample poolLifetime3,
       testCase "second reward update" $ testCHAINExample poolLifetime4,
       testCase "nonempty pool distr" $ testCHAINExample poolLifetime5,

eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/PoolReReg.hs

@@ -16,7 +16,8 @@ module Test.Cardano.Ledger.Shelley.Examples.PoolReReg
 where
 
 import Cardano.Ledger.BaseTypes
-  ( Globals (..),
+  ( BlocksMade (..),
+    Globals (..),
     Nonce,
     StrictMaybe (..),
   )
@@ -65,7 +66,7 @@ import Test.Cardano.Ledger.Shelley.Examples.Init
     nonce0,
     ppEx,
   )
-import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makePulser')
+import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makeCompletedPulser)
 import Test.Cardano.Ledger.Shelley.Generator.Core
   ( AllIssuerKeys (..),
     NatNonce (..),
@@ -249,7 +250,7 @@ poolReReg2A :: (ExMock (Crypto (ShelleyEra c))) => CHAINExample BHeader (Shelley
 poolReReg2A = CHAINExample expectedStEx1 blockEx2A (Right expectedStEx2A)
 
 pulserEx2 :: forall c. (ExMock c) => PulsingRewUpdate c
-pulserEx2 = makePulser' expectedStEx2
+pulserEx2 = makeCompletedPulser (BlocksMade mempty) expectedStEx2
 
 expectedStEx2B :: forall c. (ExMock (Crypto (ShelleyEra c))) => ChainState (ShelleyEra c)
 expectedStEx2B =

eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs

@@ -121,7 +121,7 @@ import Test.Cardano.Ledger.Shelley.Examples.Init
     nonce0,
     ppEx,
   )
-import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makePulser)
+import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makeCompletedPulser)
 import Test.Cardano.Ledger.Shelley.Generator.Core
   ( AllIssuerKeys (..),
     NatNonce (..),
@@ -773,7 +773,7 @@ pulserEx9 ::
   PParams era ->
   PulsingRewUpdate (Crypto era)
 pulserEx9 pp =
-  makePulser
+  makeCompletedPulser
     ( BlocksMade $
         Map.fromList
           [(hk Cast.alicePoolKeys, 2), (hk Cast.bobPoolKeys, 1)]

eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Updates.hs

@@ -15,7 +15,8 @@ module Test.Cardano.Ledger.Shelley.Examples.Updates
 where
 
 import Cardano.Ledger.BaseTypes
-  ( Nonce,
+  ( BlocksMade (..),
+    Nonce,
     StrictMaybe (..),
     mkNonceFromNumber,
     (⭒),
@@ -74,7 +75,7 @@ import Test.Cardano.Ledger.Shelley.Examples.Init
     nonce0,
     ppEx,
   )
-import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makePulser')
+import Test.Cardano.Ledger.Shelley.Examples.PoolLifetime (makeCompletedPulser)
 import Test.Cardano.Ledger.Shelley.Generator.Core
   ( AllIssuerKeys (..),
     NatNonce (..),
@@ -353,7 +354,7 @@ blockEx3 =
     (mkOCert (coreNodeKeysBySchedule @(ShelleyEra c) ppEx 80) 0 (KESPeriod 0))
 
 pulserEx3 :: forall c. (ExMock c) => PulsingRewUpdate c
-pulserEx3 = makePulser' expectedStEx2
+pulserEx3 = makeCompletedPulser (BlocksMade mempty) expectedStEx2
 
 expectedStEx3 :: forall c. (ExMock (Crypto (ShelleyEra c))) => ChainState (ShelleyEra c)
 expectedStEx3 =