Skip to content

Reward calculation investigation #5529

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
Lucsanszky wants to merge 3 commits into
base: master
Choose a base branch
from
Draft

Reward calculation investigation #5529

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
6a0a811
wip - reproducer
Lucsanszky Jan 7, 2026
4e5cd50
wip - block submitting
Lucsanszky Jan 9, 2026
b26f7b1
Fix order of actions in `TwoPools`
Lucsanszky Jan 20, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions eras/babbage/impl/cardano-ledger-babbage.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -148,6 +148,7 @@ library testlib
Test.Cardano.Ledger.Babbage.Era
Test.Cardano.Ledger.Babbage.Examples
Test.Cardano.Ledger.Babbage.Imp
Test.Cardano.Ledger.Babbage.Imp.EpochSpec
Test.Cardano.Ledger.Babbage.Imp.UtxoSpec
Test.Cardano.Ledger.Babbage.Imp.UtxosSpec
Test.Cardano.Ledger.Babbage.Imp.UtxowSpec
Expand Down Expand Up @@ -188,6 +189,7 @@ library testlib
generic-random,
microlens,
microlens-ghc,
mtl,
plutus-ledger-api,
small-steps >=1.1,
time,
Expand Down
21 changes: 20 additions & 1 deletion eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,13 +4,19 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Babbage.Imp (spec) where

import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.State
import Cardano.Ledger.Shelley.Rules
import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp
import Test.Cardano.Ledger.Alonzo.ImpTest
import qualified Test.Cardano.Ledger.Babbage.Imp.EpochSpec as Epoch
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxosSpec as Utxos
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
Expand All @@ -27,6 +33,19 @@ spec = do
Utxow.spec
Utxos.spec @era

babbageEraSpecificSpec ::
forall era.
( BabbageEraImp era
, ShelleyEraAccounts era
, Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era
) =>
SpecWith (ImpInit (LedgerSpec era))
babbageEraSpecificSpec = do
describe "Babbage era specific Imp spec" $
describe "EPOCH" Epoch.babbageEraSpecificSpec

instance EraSpecificSpec BabbageEra where
eraSpecificSpec =
ShelleyImp.shelleyEraSpecificSpec >> AlonzoImp.alonzoEraSpecificSpec
ShelleyImp.shelleyEraSpecificSpec
>> AlonzoImp.alonzoEraSpecificSpec
>> babbageEraSpecificSpec
101 changes: 101 additions & 0 deletions eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp/EpochSpec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,101 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Babbage.Imp.EpochSpec (babbageEraSpecificSpec) where

import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.State
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential
import Cardano.Ledger.Shelley.Rules
import Control.Monad.Writer (listen)
import Data.Coerce
import Data.Map ((!))
import qualified Data.Set as Set
import Data.Typeable (cast)
import Test.Cardano.Ledger.Babbage.ImpTest
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Imp.Common (mkAddr)

babbageEraSpecificSpec ::
forall era.
( BabbageEraImp era
, ShelleyEraAccounts era
, Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era
) =>
SpecWith (ImpInit (LedgerSpec era))
babbageEraSpecificSpec = do
it "Pool to pool member rewards" $ do
-- This test attempts to reproduce the issue that appeared with the release of
-- `cardano-db-sync-10.6.1` (using `cardano-ledger-shelley-1.17.0.0`),
-- where all of a sudden some rewards gone missing.
-- Pools didn't receive member rewards when their reward accounts were delegated
-- to other pools. This was only observed pre-Conway, see the `simpleRewards` test here:
-- https://github.com/IntersectMBO/cardano-db-sync/blob/b8748fbbcb8c2d7e7a69e771914cc077bcdb3fa6/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Reward.hs
-- Also consult the genesis file which we try to immitate with the setup below:
-- https://github.com/IntersectMBO/cardano-db-sync/blob/b8748fbbcb8c2d7e7a69e771914cc077bcdb3fa6/cardano-chain-gen/test/testfiles/config/genesis.json

pools@[p1, p2, p3] <- replicateM 3 freshKeyHash
poolSCreds@[s3, s7, _s8] <- replicateM 3 (KeyHashObj <$> freshKeyHash)
screds@[s2, s4, s5] <- replicateM 3 (KeyHashObj <$> freshKeyHash)
pcreds <- replicateM 6 (freshKeyHash @Payment)
let addrs = zipWith mkAddr pcreds $ poolSCreds <> screds

rewAccs <- mapM registerStakeCredential poolSCreds >>= \ras -> ras <$ withTxsInBlock_ (pure ras)
withTxsInBlock_ $ mapM_ registerStakeCredential screds
withTxsInBlock_ $ mapM_ (\(p, ra) -> registerPoolWithRewardAccount p ra) $ zip pools rewAccs
withTxsInBlock_ $
delegateStake s4 (coerce p3)
>> delegateStake s5 (coerce p1)
>> delegateStake s7 (coerce p3)
>> delegateStake s3 (coerce p1)
>> delegateStake s2 (coerce p2)

-- Some transactions in order to fill up the fees pot and to make sure
-- that our pools produce blocks so they can hand out rewards.
withIssuerAndTxsInBlock_ (coerce p1) $ mapM_ (`sendCoinTo_` Coin 300_000_000) addrs
withIssuerAndTxsInBlock_ (coerce p2) $ mapM_ (`sendCoinTo_` Coin 300_000_000) addrs
withIssuerAndTxsInBlock_ (coerce p3) $ mapM_ (`sendCoinTo_` Coin 300_000_000) addrs

replicateM_ 3 $ do
evs <- listen passEpoch
logDoc $ "EVs: " <> ansiExpr evs

-- Some more transactions in order to fill up the fees pot and to make sure
-- that our pools produce blocks so they can hand out rewards.
withIssuerAndTxsInBlock_ (coerce p1) $ mapM_ (`sendCoinTo_` Coin 30_000_000) addrs
withIssuerAndTxsInBlock_ (coerce p2) $ mapM_ (`sendCoinTo_` Coin 30_000_000) addrs
withIssuerAndTxsInBlock_ (coerce p3) $ mapM_ (`sendCoinTo_` Coin 30_000_000) addrs

-- We want to make sure that `s7`, the reward account associated with `p2`, receives
-- member rewards (because they delegated to `p3`, which is producing blocks).
let
isRewardEvent (SomeSTSEvent ev)
| Just (TickNewEpochEvent (TotalRewardEvent _ m) :: ShelleyTickEvent era) <- cast ev =
Set.size (Set.filter (\rew -> rewardType rew == MemberReward) (m ! s7)) > 0
isRewardEvent _ = False

evs <- impEventsFrom passEpoch
logDoc $ "EVs: " <> ansiExpr evs
finalEvs <- impEventsFrom passEpoch
logDoc $ "FINAL EVs: " <> ansiExpr finalEvs

let res = filter isRewardEvent finalEvs
logDoc $ ansiExpr res

nes <- getsNES id
logDoc $ ansiExpr nes

-- This assertion should fail if pool-to-pool delegation
-- fails to yield member rewards. However, that is not the
-- case here, so ultimately I could not reproduce the behaviour
-- that was observed in `cardano-db-syn-10.6.1`.
pure $ length res `shouldNotBe` 0
1 change: 1 addition & 0 deletions eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Rupd.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -128,6 +128,7 @@ rupdTransition = do
k <- asks securityParameter -- Maximum number of blocks we are allowed to roll back
return (slotsPerEpoch, slot, slot +* Duration sr, maxLL, asc, k, e)
let maxsupply = Coin (fromIntegral maxLL)

case determineRewardTiming s slot slotForce of
-- Waiting for the stability point, do nothing, keep waiting
RewardsTooEarly -> pure SNothing
Expand Down
59 changes: 51 additions & 8 deletions eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -70,6 +70,8 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
withTxsInFailingBlock,
withTxsInFailingBlockM,
withTxsInBlockEither,
withIssuerAndTxsInBlock_,
withIssuerAndTxsInBlock,
tryTxsInBlock,
impShelleyExpectTxSuccess,
modifyNES,
Expand Down Expand Up @@ -1364,6 +1366,16 @@ submitFailingBlockM ::
ImpTestM era ()
submitFailingBlockM = withTxsInFailingBlockM . traverse_ submitTx_

-- | Gather all the txs submitted by @act@ and resubmit them as a block that's expected to succeed.
withIssuerAndTxsInBlock_ ::
( HasCallStack
, ShelleyEraImp era
) =>
KeyHash BlockIssuer ->
ImpTestM era a ->
ImpTestM era ()
withIssuerAndTxsInBlock_ blockIssuer = void . withIssuerAndTxsInBlock blockIssuer . void

-- | Gather all the txs submitted by @act@ and resubmit them as a block that's expected to succeed.
withTxsInBlock_ ::
( HasCallStack
Expand All @@ -1373,14 +1385,23 @@ withTxsInBlock_ ::
ImpTestM era ()
withTxsInBlock_ = void . withTxsInBlock . void

withIssuerAndTxsInBlock ::
( HasCallStack
, ShelleyEraImp era
) =>
KeyHash BlockIssuer ->
ImpTestM era () ->
ImpTestM era (Block BHeaderView era)
withIssuerAndTxsInBlock blockIssuer = expectRightDeepExpr <=< withTxsInBlockEither (Just blockIssuer)

-- | Gather all the txs submitted by @act@ and resubmit them as a block that's expected to succeed.
withTxsInBlock ::
( HasCallStack
, ShelleyEraImp era
) =>
ImpTestM era () ->
ImpTestM era (Block BHeaderView era)
withTxsInBlock = expectRightDeepExpr <=< withTxsInBlockEither
withTxsInBlock = expectRightDeepExpr <=< withTxsInBlockEither Nothing

-- | Gather all the txs submitted by @act@ and resubmit them as a block
-- that's expected to fail with the given predicate failures.
Expand All @@ -1403,7 +1424,7 @@ withTxsInFailingBlockM ::
(Block BHeaderView era -> ImpTestM era (NonEmpty (PredicateFailure (EraRule "BBODY" era)))) ->
ImpTestM era ()
withTxsInFailingBlockM act mkExpectedFailures = do
(predFailures, block) <- expectLeftDeepExpr <=< withTxsInBlockEither $ act
(predFailures, block) <- expectLeftDeepExpr <=< withTxsInBlockEither Nothing $ act
expectedFailures <- mkExpectedFailures block
predFailures `shouldBeExpr` expectedFailures

Expand All @@ -1413,19 +1434,22 @@ withTxsInFailingBlockM act mkExpectedFailures = do
withTxsInBlockEither ::
forall era.
ShelleyEraImp era =>
Maybe (KeyHash BlockIssuer) ->
ImpTestM era () ->
ImpTestM
era
( Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)), Block BHeaderView era)
(Block BHeaderView era)
)
withTxsInBlockEither act = do
withTxsInBlockEither mIssuer act = do
stateBefore <- get
txs <- impRecordSubmittedTxs act
stateAfter <- get
put stateBefore
tryTxsInBlock txs stateAfter
case mIssuer of
Nothing -> tryTxsInBlock txs stateAfter
Just blockIssuer -> tryTxsInBlock' txs stateAfter blockIssuer

-- | Given a sequence of fixed-up transactions and an expected final test state,
-- try to submit the transactions as a block.
Expand All @@ -1444,6 +1468,21 @@ tryTxsInBlock ::
)
tryTxsInBlock txs finalState = do
blockIssuer <- freshKeyHash
tryTxsInBlock' txs finalState blockIssuer

tryTxsInBlock' ::
forall era.
ShelleyEraImp era =>
StrictSeq (Tx TopTx era) ->
ImpTestState era ->
KeyHash BlockIssuer ->
ImpTestM
era
( Either
(NonEmpty (PredicateFailure (EraRule "BBODY" era)), Block BHeaderView era)
(Block BHeaderView era)
)
tryTxsInBlock' txs finalState blockIssuer = do
slotNo <- use impCurSlotNoG

let
Expand Down Expand Up @@ -1966,19 +2005,23 @@ freshPoolParams khPool rewardAccount = do
vrfHash <- freshKeyHashVRF
pp <- getsNES $ nesEsL . curPParamsEpochStateL
let minCost = pp ^. ppMinPoolCostL
poolCostExtra <- uniformRM (Coin 0, Coin 100_000_000)
pledge <- uniformRM (Coin 0, Coin 100_000_000)
_poolCostExtra <- uniformRM (Coin 0, Coin 100_000_000)
-- pledge <- uniformRM (Coin 0, Coin 100_000)
let pledge = Coin 0
let owners = case raCredential rewardAccount of
KeyHashObj credKh -> Set.fromList [credKh]
_ -> mempty
pure
StakePoolParams
{ sppVrf = vrfHash
, sppRewardAccount = rewardAccount
, sppRelays = mempty
, sppPledge = pledge
, sppOwners = mempty
, sppOwners = owners
, sppMetadata = SNothing
, sppMargin = def
, sppId = khPool
, sppCost = minCost <> poolCostExtra
, sppCost = minCost -- <> poolCostExtra
}

registerPool ::
Expand Down
6 changes: 3 additions & 3 deletions eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/TwoPools.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -234,14 +234,14 @@ expectedStEx1 =
. C.newLab blockEx1
. C.addFees feeTx1
. C.newUTxO txbodyEx1
. C.delegation Cast.aliceSHK (sppId aliceStakePoolParams')
. C.delegation Cast.bobSHK (sppId bobStakePoolParams')
. C.delegation Cast.carlSHK (sppId aliceStakePoolParams')
. C.newStakeCred Cast.aliceSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 0))
. C.newStakeCred Cast.bobSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 1))
. C.newStakeCred Cast.carlSHK (Ptr (SlotNo32 10) minBound (mkCertIxPartial 2))
. C.regPool aliceStakePoolParams'
. C.regPool bobStakePoolParams'
. C.delegation Cast.aliceSHK (sppId aliceStakePoolParams')
. C.delegation Cast.bobSHK (sppId bobStakePoolParams')
. C.delegation Cast.carlSHK (sppId aliceStakePoolParams')
$ initStTwoPools

-- === Block 1, Slot 10, Epoch 0
Expand Down