diff --git a/cardano-node/ledger_events.cddl b/cardano-node/ledger_events.cddl index 009e4f464d1..5ef0888985e 100644 --- a/cardano-node/ledger_events.cddl +++ b/cardano-node/ledger_events.cddl @@ -9,9 +9,9 @@ rule = ledger-event anchored-event = - { 0: block-header-hash ; The block header hash from where this event was emitted. - , 1: slot ; The slot number corresponding to the aforementioned header hash. - , 2: ledger-event ; The actual ledger event. + { 0: block-header-hash ; The block header hash from where this event was emitted. + , 1: slot ; The slot number corresponding to the aforementioned header hash. + , 2: ledger-event ; The actual ledger event. } ; ============= ; @@ -20,42 +20,83 @@ anchored-event = ledger-event = [ 0, ledger-event.epoch - // 1, ledger-event.body - // 2, ledger-event.tick + // 1, ledger-event.reward-update + // 2, ledger-event.body + // 3, ledger-event.tick ] ledger-event.epoch = [ 0, epoch.mir-distribution // 1, epoch.stake-pool-reaping // 2, epoch.stake-distribution - // 3, epoch.incremental-rewards - // 4, epoch.delta-rewards - // 5, epoch.restrained-rewards - // 6, epoch.total-rewards - // 7, epoch.starts-at + // 3, epoch.restrained-rewards + // 4, epoch.total-rewards + // 5, epoch.starts-at ] +ledger-event.reward-update = + [ 0, reward-update.incremental-rewards + // 1, reward-update.delta-rewards + ] + +ledger-event.body = + any + +ledger-event.tick = + any + +; -- Epoch / MIR Distribution -------------------------------------------------- +; +; Describes any tokens that are being added to reward accounts via MIR +; certificates. +; +; → This event only occurs on epoch boundaries. epoch.mir-distribution = - ( stake-distribution ; Rewards paid from the Reserve into stake credentials - , stake-distribution ; Rewards paid from the Treasury into stake credentials - , delta-coin ; Transfer from the Reserve into the Treasury - , delta-coin ; Transfer from the Treasury into the Reserve + ( { * stake-credential => coin } ; Rewards paid from the Reserve into stake credentials + , { * stake-credential => coin } ; Rewards paid from the Treasury into stake credentials + , delta-coin ; Transfer from the Reserve into the Treasury + , delta-coin ; Transfer from the Treasury into the Reserve ) + +; -- Epoch / Stake Pool Reaping ------------------------------------------------ +; +; Provides information about retired stake pools. In particular, it provides +; all stake pool registration deposit amounts which are being returned. +; +; When a stake pool retires, a refund of the deposit is sent to the declared +; reward account of the stake pool. Note that any given stake credential can be +; registered to multiple stake pools as reward account. Which is why the +; 'refund-distribution' goes from a stake credential (the reward account), to a +; map of pool identifiers. +; +; The second 'refund-distribution' holds unclaimed deposits which corresponds +; to ; deposits that ought to have been returned but for which the reward +; account did no longer exist (because its owner had already de-registered it). +; Those rewards end up being sent to the Treasury. +; +; → This event only occurs on epoch boundaries. epoch.stake-pool-reaping = - ( epoch - , refund-distribution - , refund-distribution + ( epoch ; Epoch in which the pool reaping occurs + , { * stake-credential => { 1* pool-id => coin } } ; Stake pools refunds after retirement + , { * stake-credential => { 1* pool-id => coin } } ; Unclaimed deposit after retirement ) -epoch.stake-distribution = - any -epoch.incremental-rewards = - any - -epoch.delta-rewards = - any +; -- Epoch / Stake Distribution ------------------------------------------------ +; +; A new stake distribution snapshot is taken on every epoch boundary, +; corresponding to the "mark" snapshot as described in the Shelley ledger formal +; specification. +; +; This event provides the new snapshot which is a map from registered stake +; credentials to the stake pool it is registered to and the amount of stake (in +; lovelace) that it controls. +; +; → This event only occurs on epoch boundaries. +epoch.stake-distribution = + ( { * stake-credential => [ coin, pool-id ] } + ) epoch.restrained-rewards = any @@ -66,11 +107,18 @@ epoch.total-rewards = epoch.starts-at = epoch -ledger-event.body = - any +; -- Epoch / Incremental Rewards ------------------------------------------------ +; +reward-update.incremental-rewards = + ( epoch ; Epoch at which the rewards will become available + , { * stake-credential => [ * reward ] } ; Incremental rewards iteration + ) -ledger-event.tick = - any + +reward-update.delta-rewards = + ( epoch ; Epoch at which the rewards will become available + , { * stake-credential => [ * reward ] } ; Incremental rewards iteration + ) ; ============== ; ; Common schemas ; @@ -91,19 +139,16 @@ epoch = pool-id = $hash28 -refund-distribution = - { * stake-credential => { * $hash28 => coin } } - reward = - { 0: reward-type - , 1: pool-id - , 2: coin - } + [ reward-type + , pool-id + , coin + ] reward-type = - [ 0 ; member rewards - // 1 ; leader rewards - ] + ( 0 ; member rewards + / 1 ; leader rewards + ) slot = uint @@ -113,10 +158,6 @@ stake-credential = // 1, $hash28 ; Script hash digest ] -stake-distribution = - { * stake-credential => coin - } - version = uint diff --git a/cardano-node/src/Cardano/Node/LedgerEvent.hs b/cardano-node/src/Cardano/Node/LedgerEvent.hs index b01c3ce94cf..2201663c6ce 100644 --- a/cardano-node/src/Cardano/Node/LedgerEvent.hs +++ b/cardano-node/src/Cardano/Node/LedgerEvent.hs @@ -22,6 +22,7 @@ module Cardano.Node.LedgerEvent ( AnchoredEvent (..) , LedgerEvent (..) , LedgerNewEpochEvent (..) + , LedgerRewardUpdateEvent (..) , deserializeAnchoredEvent , serializeAnchoredEvent , ledgerEventName @@ -118,6 +119,7 @@ type LedgerState crypto = data LedgerEvent crypto = LedgerNewEpochEvent !(LedgerNewEpochEvent crypto) + | LedgerRewardUpdateEvent !(LedgerRewardUpdateEvent crypto) -- TODO complete those vvv | LedgerBody -- | LedgerUtxoTotalDeposits @@ -127,6 +129,36 @@ data LedgerEvent crypto | LedgerTick deriving (Eq, Show) +-- TODO: Review encoding & make future-proof (i.e. favor records over lists/tuples) +instance Crypto crypto => EncCBOR (LedgerEvent crypto) where + encCBOR = encode . \case + LedgerNewEpochEvent e -> + Sum LedgerNewEpochEvent 0 + !> To e + LedgerRewardUpdateEvent e -> + Sum LedgerRewardUpdateEvent 1 + !> To e + LedgerBody -> + Sum LedgerBody 2 + LedgerTick -> + Sum LedgerTick 3 + +instance Crypto crypto => DecCBOR (LedgerEvent crypto) where + decCBOR = decode (Summands "LedgerEvent" decRaw) + where + decRaw 0 = + SumD LedgerNewEpochEvent + EncCBOR (LedgerEvent crypto) where - encCBOR = encode . \case - LedgerNewEpochEvent e -> Sum LedgerNewEpochEvent 0 !> To e - LedgerBody -> Sum LedgerBody 1 - LedgerTick -> Sum LedgerTick 2 - instance Crypto crypto => EncCBOR (LedgerNewEpochEvent crypto) where encCBOR = encode . \case LedgerMirDist fromReserve fromTreasury deltaReserve deltaTreasury -> @@ -205,28 +225,20 @@ instance Crypto crypto => EncCBOR (LedgerNewEpochEvent crypto) where LedgerStakeDistEvent stakeDist -> Sum LedgerStakeDistEvent 2 !> To stakeDist - LedgerIncrementalRewards epoch rewards -> - Sum LedgerIncrementalRewards 3 - !> To epoch - !> To rewards - LedgerDeltaRewards epoch rewards -> - Sum LedgerDeltaRewards 4 - !> To epoch - !> To rewards LedgerRestrainedRewards epoch rewards credentials -> - Sum LedgerRestrainedRewards 5 + Sum LedgerRestrainedRewards 3 !> To epoch !> To rewards !> To credentials LedgerTotalRewards epoch rewards -> - Sum LedgerTotalRewards 6 + Sum LedgerTotalRewards 4 !> To epoch !> To rewards LedgerStartAtEpoch epoch -> - Sum LedgerStartAtEpoch 7 + Sum LedgerStartAtEpoch 5 !> To epoch LedgerTotalAdaPots treasuryAdaPot reservesAdaPot rewardsAdaPot utxoAdaPot keyDepositAdaPot poolDepositAdaPot depositsAdaPot feesAdaPot -> - Sum LedgerTotalAdaPots 8 + Sum LedgerTotalAdaPots 6 !> To treasuryAdaPot !> To reservesAdaPot !> To rewardsAdaPot @@ -236,53 +248,86 @@ instance Crypto crypto => EncCBOR (LedgerNewEpochEvent crypto) where !> To depositsAdaPot !> To feesAdaPot -instance Crypto crypto => DecCBOR (LedgerEvent crypto) where - decCBOR = decode (Summands "LedgerEvent" decRaw) - where - decRaw 0 = SumD LedgerNewEpochEvent DecCBOR (LedgerNewEpochEvent crypto) where decCBOR = decode (Summands "LedgerNewEpochEvent" decRaw) where - decRaw 0 = SumD LedgerMirDist - EncCBOR (LedgerRewardUpdateEvent crypto) where + encCBOR = encode . \case + LedgerIncrementalRewards epoch rewards -> + Sum LedgerIncrementalRewards 0 + !> To epoch + !> To rewards + LedgerDeltaRewards epoch rewards -> + Sum LedgerDeltaRewards 1 + !> To epoch + !> To rewards + +instance Crypto crypto => DecCBOR (LedgerRewardUpdateEvent crypto) where + decCBOR = decode (Summands "LedgerRewardUpdateEvent" decRaw) + where + decRaw 0 = SumD LedgerIncrementalRewards Maybe (Credential 'Staking StandardCrypto) @@ -294,23 +339,25 @@ parseStakeCredential str = instance Ord (LedgerEvent crypto) where a <= b = toOrdering a <= toOrdering b +-- TODO: Review order once we're done with the type modeling toOrdering :: LedgerEvent crypto -> Int toOrdering = \case - LedgerNewEpochEvent LedgerMirDist {} -> 0 - LedgerNewEpochEvent LedgerPoolReaping {} -> 1 - LedgerNewEpochEvent LedgerStakeDistEvent {} -> 2 - LedgerNewEpochEvent LedgerIncrementalRewards {} -> 3 - LedgerNewEpochEvent LedgerDeltaRewards {} -> 4 - LedgerNewEpochEvent LedgerRestrainedRewards {} -> 5 - LedgerNewEpochEvent LedgerTotalRewards {} -> 6 - LedgerNewEpochEvent LedgerStartAtEpoch {} -> 7 - LedgerNewEpochEvent LedgerTotalAdaPots {} -> 8 - LedgerBody -> 9 - LedgerTick -> 10 + LedgerNewEpochEvent LedgerMirDist {} -> 0 + LedgerNewEpochEvent LedgerPoolReaping {} -> 1 + LedgerNewEpochEvent LedgerStakeDistEvent {} -> 2 + LedgerRewardUpdateEvent LedgerIncrementalRewards {} -> 3 + LedgerRewardUpdateEvent LedgerDeltaRewards {} -> 4 + LedgerNewEpochEvent LedgerRestrainedRewards {} -> 5 + LedgerNewEpochEvent LedgerTotalRewards {} -> 6 + LedgerNewEpochEvent LedgerStartAtEpoch {} -> 7 + LedgerNewEpochEvent LedgerTotalAdaPots {} -> 8 + LedgerBody -> 9 + LedgerTick -> 10 ledgerEventName :: LedgerEvent crypto -> Text ledgerEventName = \case - LedgerNewEpochEvent e -> ledgerNewEpochEventName e + LedgerNewEpochEvent e -> ledgerNewEpochEventName e + LedgerRewardUpdateEvent e -> ledgerRewardUpdateEventName e LedgerBody {} -> "LedgerBody" LedgerTick {} -> "LedgerTick" @@ -319,13 +366,16 @@ ledgerNewEpochEventName = \case LedgerMirDist {} -> "LedgerMirDist" LedgerPoolReaping {} -> "LedgerPoolReaping" LedgerStakeDistEvent {} -> "LedgerStakeDistEvent" - LedgerIncrementalRewards {} -> "LedgerIncrementalRewards" - LedgerDeltaRewards {} -> "LedgerDeltaRewards" LedgerRestrainedRewards {} -> "LedgerRestrainedRewards" LedgerTotalRewards {} -> "LedgerTotalRewards" LedgerStartAtEpoch {} -> "LedgerStartAtEpoch" LedgerTotalAdaPots {} -> "LedgerTotalAdaPots" +ledgerRewardUpdateEventName :: LedgerRewardUpdateEvent crypto -> Text +ledgerRewardUpdateEventName = \case + LedgerIncrementalRewards {} -> "LedgerIncrementalRewards" + LedgerDeltaRewards {} -> "LedgerDeltaRewards" + fromAuxLedgerEvent :: forall xs crypto. (All ConvertLedgerEvent xs, crypto ~ StandardCrypto) => AuxLedgerEvent (Abstract.LedgerState (HardForkBlock xs)) @@ -370,9 +420,9 @@ toLedgerEventShelley evt = ShelleyLedgerEventTICK (TickNewEpochEvent (Shelley.RestrainedRewards epoch rewards credentials)) -> Just $ LedgerNewEpochEvent $ LedgerRestrainedRewards epoch rewards credentials ShelleyLedgerEventTICK (TickNewEpochEvent (Shelley.DeltaRewardEvent (RupdEvent epoch rewards))) -> - Just $ LedgerNewEpochEvent $ LedgerDeltaRewards epoch rewards + Just $ LedgerRewardUpdateEvent $ LedgerDeltaRewards epoch (Set.toList <$> rewards) ShelleyLedgerEventTICK (TickRupdEvent (RupdEvent epoch rewards)) -> - Just $ LedgerNewEpochEvent $ LedgerIncrementalRewards epoch rewards + Just $ LedgerRewardUpdateEvent $ LedgerIncrementalRewards epoch (Set.toList <$> rewards) ShelleyLedgerEventTICK (TickNewEpochEvent (Shelley.MirEvent transfer)) -> case transfer of MirTransfer (InstantaneousRewards fromReserve fromTreasury deltaReserve deltaTreasury) -> @@ -423,7 +473,7 @@ toConwayEventShelley evt = ShelleyLedgerEventTICK (TickNewEpochEvent (Conway.RestrainedRewards epoch rewards credentials)) -> Just $ LedgerNewEpochEvent $ LedgerRestrainedRewards epoch rewards credentials ShelleyLedgerEventTICK (TickNewEpochEvent (Conway.DeltaRewardEvent (RupdEvent epoch rewards))) -> - Just $ LedgerNewEpochEvent $ LedgerDeltaRewards epoch rewards + Just $ LedgerRewardUpdateEvent $ LedgerDeltaRewards epoch (Set.toList <$> rewards) ShelleyLedgerEventTICK (TickNewEpochEvent (Conway.DeltaRewardEvent _)) -> Nothing -- Or else getting "Pattern not exhaustif" warning, but can't seem to find the missing constructor. ShelleyLedgerEventTICK (TickNewEpochEvent (Conway.EpochEvent (Conway.PoolReapEvent (RetiredPools refunded unclaimed epoch)))) -> @@ -445,7 +495,7 @@ toConwayEventShelley evt = (ShelleyAPI.depositsAdaPot adaPots) (ShelleyAPI.feesAdaPot adaPots) ShelleyLedgerEventTICK (TickRupdEvent (RupdEvent epoch rewards)) -> - Just $ LedgerNewEpochEvent $ LedgerIncrementalRewards epoch rewards + Just $ LedgerRewardUpdateEvent $ LedgerIncrementalRewards epoch (Set.toList <$> rewards) ShelleyLedgerEventBBODY _ -> Nothing diff --git a/cardano-node/test/Test/Cardano/Node/LedgerEvent.hs b/cardano-node/test/Test/Cardano/Node/LedgerEvent.hs index 3b9fd42c64a..536d212a86c 100644 --- a/cardano-node/test/Test/Cardano/Node/LedgerEvent.hs +++ b/cardano-node/test/Test/Cardano/Node/LedgerEvent.hs @@ -13,10 +13,11 @@ import qualified Codec.CBOR.Schema as CDDL import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Hex import Data.ByteString.Lazy(fromStrict) -import Data.ByteString.Short (toShort) +import Data.ByteString.Short (ShortByteString, toShort) import Data.Map (Map) import Data.Maybe (fromJust) import Data.String (IsString(..)) +import Data.Set (Set) import Data.Text (Text) import Hedgehog (Property, discover, footnote, (===)) import qualified Hedgehog @@ -29,6 +30,7 @@ import qualified Data.Text.IO as TIO specification :: Text specification = unsafePerformIO $ TIO.readFile "./ledger_events.cddl" +{-# NOINLINE specification #-} prop_roundtrip_LedgerEvent_CBOR :: Property prop_roundtrip_LedgerEvent_CBOR = @@ -56,13 +58,18 @@ prop_LedgerEvent_CDDL_conformance = -- Generators -- +type StakePoolId = KeyHash 'StakePool StandardCrypto + +type StakeCredential = Credential 'Staking StandardCrypto + genAnchoredEvent :: Hedgehog.Gen AnchoredEvent genAnchoredEvent = AnchoredEvent - <$> (toShort <$> Gen.bytes (Range.constant 32 32)) - <*> (fromIntegral <$> Gen.word64 Range.constantBounded) + <$> genBlockHeaderHash + <*> genSlotNo <*> Gen.choice [ LedgerNewEpochEvent <$> genLedgerNewEpochEvent + , LedgerRewardUpdateEvent <$> genLedgerRewardUpdateEvent ] genLedgerNewEpochEvent :: Hedgehog.Gen (LedgerNewEpochEvent StandardCrypto) @@ -76,15 +83,31 @@ genLedgerNewEpochEvent = Gen.choice <$> genEpoch <*> genStakePoolRefunds <*> genStakePoolRefunds + , LedgerStakeDistEvent + <$> genExtendedStakeDistribution , LedgerStartAtEpoch <$> genEpoch ] +genLedgerRewardUpdateEvent :: Hedgehog.Gen (LedgerRewardUpdateEvent StandardCrypto) +genLedgerRewardUpdateEvent = Gen.choice + [ LedgerIncrementalRewards + <$> genEpoch + <*> genRewardDistribution + , LedgerDeltaRewards + <$> genEpoch + <*> genRewardDistribution + ] + +genBlockHeaderHash :: Hedgehog.Gen ShortByteString +genBlockHeaderHash = + toShort <$> Gen.bytes (Range.constant 32 32) + genCoin :: Hedgehog.Gen Coin genCoin = Coin . fromIntegral <$> Gen.word32 Range.constantBounded -genCredential :: Hedgehog.Gen (Credential 'Staking StandardCrypto) +genCredential :: Hedgehog.Gen StakeCredential genCredential = Gen.choice [ ScriptHashObj <$> genScriptHash , KeyHashObj <$> genKeyHash @@ -98,42 +121,48 @@ genEpoch :: Hedgehog.Gen EpochNo genEpoch = fromIntegral <$> Gen.word16 Range.constantBounded +genExtendedStakeDistribution :: Hedgehog.Gen (Map StakeCredential (Coin, StakePoolId)) +genExtendedStakeDistribution = + genStakeCredentialMap $ (,) <$> genCoin <*> genKeyHash + genKeyHash :: Hedgehog.Gen (KeyHash any StandardCrypto) genKeyHash = KeyHash . unsafeHashFromBytes <$> Gen.bytes (Range.singleton 28) +genReward :: Hedgehog.Gen (Reward StandardCrypto) +genReward = Reward + <$> Gen.enumBounded + <*> genKeyHash + <*> genCoin + +genRewardDistribution :: Hedgehog.Gen (Map StakeCredential [Reward StandardCrypto]) +genRewardDistribution = + genStakeCredentialMap $ Gen.list (Range.linear 1 3) genReward + genScriptHash :: Hedgehog.Gen (ScriptHash StandardCrypto) genScriptHash = ScriptHash . unsafeHashFromBytes <$> Gen.bytes (Range.singleton 28) -genStakeDistribution :: Hedgehog.Gen (Map (Credential 'Staking StandardCrypto) Coin) +genSlotNo :: Hedgehog.Gen SlotNo +genSlotNo = + fromIntegral <$> Gen.word64 Range.constantBounded + +genStakeDistribution :: Hedgehog.Gen (Map StakeCredential Coin) genStakeDistribution = - Gen.map - (Range.linear 0 3) - ((,) <$> genCredential <*> genCoin) - -genStakePoolRefunds - :: Hedgehog.Gen - (Map - (Credential 'Staking StandardCrypto) - (Map - (KeyHash 'StakePool StandardCrypto) - Coin - ) - ) + genStakeCredentialMap genCoin + +genStakePoolRefunds :: Hedgehog.Gen (Map StakeCredential (Map StakePoolId Coin)) genStakePoolRefunds = - Gen.map - (Range.linear 0 3) - ((,) <$> genCredential - <*> Gen.map - (Range.linear 0 3) - ((,) <$> genKeyHash <*> genCoin) - ) + genStakeCredentialMap $ Gen.map (Range.linear 1 3) $ (,) <$> genKeyHash <*> genCoin -- -- Helpers -- +genStakeCredentialMap :: Hedgehog.Gen a -> Hedgehog.Gen (Map StakeCredential a) +genStakeCredentialMap genValue = + Gen.map (Range.linear 0 3) ((,) <$> genCredential <*> genValue) + labelName :: AnchoredEvent -> Hedgehog.LabelName