|
| 1 | +{-# LANGUAGE DataKinds #-} |
| 2 | +{-# LANGUAGE DeriveAnyClass #-} |
| 3 | +{-# LANGUAGE DeriveGeneric #-} |
| 4 | +{-# LANGUAGE FlexibleContexts #-} |
| 5 | +{-# LANGUAGE NamedFieldPuns #-} |
| 6 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 7 | +{-# LANGUAGE StandaloneDeriving #-} |
| 8 | + |
| 9 | +module Cardano.Ledger.Api.State.Query.Reward ( |
| 10 | + -- * Stable query result types |
| 11 | + QueryResultRewardInfoPools (..), |
| 12 | + |
| 13 | + -- * Queries |
| 14 | + queryNonMyopicMemberRewards, |
| 15 | + queryRewardInfoPools, |
| 16 | + queryRewardProvenance, |
| 17 | +) where |
| 18 | + |
| 19 | +import Cardano.Ledger.Api.State.Query.Snapshot (queryCurrentSnapshot) |
| 20 | +import Cardano.Ledger.BaseTypes (Globals (..), epochInfoPure, unNonZero, (%?)) |
| 21 | +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) |
| 22 | +import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!)) |
| 23 | +import Cardano.Ledger.Coin (Coin (..)) |
| 24 | +import Cardano.Ledger.Compactible (fromCompact) |
| 25 | +import Cardano.Ledger.Core (ppA0L, ppNOptL) |
| 26 | +import Cardano.Ledger.Credential (Credential (..)) |
| 27 | +import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool, Staking)) |
| 28 | +import Cardano.Ledger.Shelley.API.Wallet ( |
| 29 | + RewardInfoPool (..), |
| 30 | + RewardParams (..), |
| 31 | + ) |
| 32 | +import Cardano.Ledger.Shelley.LedgerState ( |
| 33 | + EpochState (..), |
| 34 | + NewEpochState (..), |
| 35 | + RewardUpdate, |
| 36 | + circulation, |
| 37 | + createRUpd, |
| 38 | + curPParamsEpochStateL, |
| 39 | + ) |
| 40 | +import Cardano.Ledger.Shelley.PoolRank ( |
| 41 | + NonMyopic (..), |
| 42 | + PerformanceEstimate (..), |
| 43 | + calcNonMyopicMemberReward, |
| 44 | + getTopRankedPools, |
| 45 | + percentile', |
| 46 | + ) |
| 47 | +import Cardano.Ledger.Shelley.RewardProvenance (RewardProvenance) |
| 48 | +import Cardano.Ledger.Shelley.Rewards (StakeShare (..)) |
| 49 | +import Cardano.Ledger.Slot (epochInfoSize) |
| 50 | +import Cardano.Ledger.State ( |
| 51 | + EraCertState, |
| 52 | + EraGov, |
| 53 | + EraStake, |
| 54 | + spssCost, |
| 55 | + spssMargin, |
| 56 | + spssPledge, |
| 57 | + spssSelfDelegatedOwnersStake, |
| 58 | + spssStake, |
| 59 | + ssStakePoolsSnapShot, |
| 60 | + ) |
| 61 | +import qualified Cardano.Ledger.State as LS |
| 62 | +import Control.DeepSeq (NFData) |
| 63 | +import Control.Monad.Trans.Reader (runReader) |
| 64 | +import Data.Aeson (ToJSON) |
| 65 | +import Data.Default (Default (def)) |
| 66 | +import Data.Map.Strict (Map) |
| 67 | +import qualified Data.Map.Strict as Map |
| 68 | +import Data.Set (Set) |
| 69 | +import qualified Data.VMap as VMap |
| 70 | +import Data.Word (Word64) |
| 71 | +import GHC.Generics (Generic) |
| 72 | +import Lens.Micro ((^.)) |
| 73 | +import NoThunks.Class (NoThunks) |
| 74 | + |
| 75 | +-- | Stable query result for per-pool reward information. |
| 76 | +data QueryResultRewardInfoPools = QueryResultRewardInfoPools |
| 77 | + { qrripParams :: !RewardParams |
| 78 | + , qrripPools :: !(Map (KeyHash StakePool) RewardInfoPool) |
| 79 | + } |
| 80 | + deriving (Show, Eq, Ord, Generic) |
| 81 | + |
| 82 | +deriving instance ToJSON QueryResultRewardInfoPools |
| 83 | + |
| 84 | +instance NFData QueryResultRewardInfoPools |
| 85 | + |
| 86 | +instance NoThunks QueryResultRewardInfoPools |
| 87 | + |
| 88 | +instance EncCBOR QueryResultRewardInfoPools where |
| 89 | + encCBOR (QueryResultRewardInfoPools params pools) = |
| 90 | + encode $ |
| 91 | + Rec QueryResultRewardInfoPools |
| 92 | + !> To params |
| 93 | + !> To pools |
| 94 | + |
| 95 | +instance DecCBOR QueryResultRewardInfoPools where |
| 96 | + decCBOR = |
| 97 | + decode $ |
| 98 | + RecD QueryResultRewardInfoPools |
| 99 | + <! From |
| 100 | + <! From |
| 101 | + |
| 102 | +-- | Query non-myopic pool member rewards for a set of credentials. |
| 103 | +-- Source: ouroboros-consensus:ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs:415 |
| 104 | +-- answerPureBlockQuery case for GetNonMyopicMemberRewards |
| 105 | +-- |
| 106 | +-- For each given credential (or hypothetical stake amount), returns a map from |
| 107 | +-- each stake pool to the estimated non-myopic member reward for that pool. |
| 108 | +-- Wallets use this to answer "how much would I earn if I delegated to pool X?". |
| 109 | +-- |
| 110 | +-- "Non-myopic" means rewards are estimated under the assumption that stake |
| 111 | +-- will eventually converge to a Nash equilibrium across pools, rather than |
| 112 | +-- using today's distribution naively. This avoids overestimating rewards for |
| 113 | +-- currently under-saturated pools. |
| 114 | +-- |
| 115 | +-- The input set contains @'Either' 'Coin' ('Credential' 'Staking')@ values: |
| 116 | +-- |
| 117 | +-- * @'Left' coin@ — a hypothetical stake amount (for "what if I delegated |
| 118 | +-- this much?" queries). |
| 119 | +-- * @'Right' cred@ — an existing credential whose current active stake is |
| 120 | +-- looked up from the ledger state. |
| 121 | +-- |
| 122 | +-- This uses a fresh snapshot derived from the current ledger state, not the |
| 123 | +-- stored mark\/set\/go snapshots. |
| 124 | +queryNonMyopicMemberRewards :: |
| 125 | + (EraGov era, EraStake era, EraCertState era) => |
| 126 | + -- | maxLovelaceSupply from genesis config |
| 127 | + Word64 -> |
| 128 | + NewEpochState era -> |
| 129 | + Set (Either Coin (Credential Staking)) -> |
| 130 | + Map |
| 131 | + (Either Coin (Credential Staking)) |
| 132 | + (Map (KeyHash StakePool) Coin) |
| 133 | +queryNonMyopicMemberRewards maxLovelaceSupply ss = Map.fromSet nmmRewards |
| 134 | + where |
| 135 | + maxSupply = Coin . fromIntegral $ maxLovelaceSupply |
| 136 | + totalStakeCoin@(Coin totalStake) = circulation es maxSupply |
| 137 | + toShare (Coin x) = StakeShare $ x %? totalStake |
| 138 | + memShare (Right cred) = |
| 139 | + toShare $ |
| 140 | + maybe mempty (fromCompact . unNonZero . LS.swdStake) $ |
| 141 | + VMap.lookup cred (LS.unActiveStake activeStake) |
| 142 | + memShare (Left coin) = toShare coin |
| 143 | + es = nesEs ss |
| 144 | + pp = es ^. curPParamsEpochStateL |
| 145 | + NonMyopic {likelihoodsNM = ls, rewardPotNM = rPot} = esNonMyopic es |
| 146 | + LS.SnapShot {LS.ssActiveStake = activeStake, LS.ssStakePoolsSnapShot = stakePoolsSnapShot} = queryCurrentSnapshot ss |
| 147 | + calcNMMRewards t poolId spss |
| 148 | + | spssPledge <= spssSelfDelegatedOwnersStake = |
| 149 | + calcNonMyopicMemberReward pp rPot poolId spssCost spssMargin s sigma t topPools hitRateEst |
| 150 | + | otherwise = mempty |
| 151 | + where |
| 152 | + LS.StakePoolSnapShot {spssSelfDelegatedOwnersStake, spssPledge, spssCost, spssMargin} = spss |
| 153 | + s = toShare spssPledge |
| 154 | + hitRateEst = percentile' (histLookup poolId) |
| 155 | + sigma = toShare (fromCompact (LS.spssStake spss)) |
| 156 | + |
| 157 | + nmmRewards cred = VMap.toMap $ VMap.mapWithKey (calcNMMRewards $ memShare cred) stakePoolsSnapShot |
| 158 | + histLookup k = VMap.findWithDefault mempty k ls |
| 159 | + topPools = |
| 160 | + getTopRankedPools rPot totalStakeCoin pp $ |
| 161 | + Map.intersectionWith (,) (VMap.toMap (VMap.map percentile' ls)) $ |
| 162 | + VMap.toMap stakePoolsSnapShot |
| 163 | + |
| 164 | +-- | Query per-pool reward information from the current stake distribution. |
| 165 | +-- Source: ouroboros-consensus:ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs:447 |
| 166 | +-- answerPureBlockQuery case for GetRewardInfoPools |
| 167 | +-- |
| 168 | +-- This is the primary query for wallets and tools that display pool ranking, |
| 169 | +-- saturation levels, and estimated returns. It returns per-pool data (stake, |
| 170 | +-- pledge, costs, margins, performance estimates) together with global reward |
| 171 | +-- parameters (a0, nOpt, totalStake, rPot). |
| 172 | +-- |
| 173 | +-- Uses a fresh snapshot from 'queryCurrentSnapshot' rather than the stored |
| 174 | +-- epoch-boundary snapshots, so the data reflects the most recent ledger state. |
| 175 | +queryRewardInfoPools :: |
| 176 | + (EraGov era, EraStake era, EraCertState era) => |
| 177 | + -- | maxLovelaceSupply from genesis config |
| 178 | + Word64 -> |
| 179 | + NewEpochState era -> |
| 180 | + QueryResultRewardInfoPools |
| 181 | +queryRewardInfoPools maxLovelaceSupply nes = |
| 182 | + QueryResultRewardInfoPools rewardParams poolInfos |
| 183 | + where |
| 184 | + es = nesEs nes |
| 185 | + pp = es ^. curPParamsEpochStateL |
| 186 | + NonMyopic {likelihoodsNM = ls, rewardPotNM = rPot} = esNonMyopic es |
| 187 | + histLookup poolId = VMap.findWithDefault mempty poolId ls |
| 188 | + |
| 189 | + LS.SnapShot {ssStakePoolsSnapShot} = queryCurrentSnapshot nes |
| 190 | + |
| 191 | + rewardParams = |
| 192 | + RewardParams |
| 193 | + { a0 = pp ^. ppA0L |
| 194 | + , nOpt = pp ^. ppNOptL |
| 195 | + , totalStake = |
| 196 | + let supply = Coin (fromIntegral maxLovelaceSupply) |
| 197 | + in circulation es supply |
| 198 | + , rPot = rPot |
| 199 | + } |
| 200 | + poolInfos = VMap.toMap $ VMap.mapWithKey mkRewardInfoPool ssStakePoolsSnapShot |
| 201 | + mkRewardInfoPool poolId LS.StakePoolSnapShot {spssStake, spssSelfDelegatedOwnersStake, spssPledge, spssMargin, spssCost} = |
| 202 | + RewardInfoPool |
| 203 | + { stake = fromCompact spssStake |
| 204 | + , ownerStake = spssSelfDelegatedOwnersStake |
| 205 | + , ownerPledge = spssPledge |
| 206 | + , margin = spssMargin |
| 207 | + , cost = spssCost |
| 208 | + , performanceEstimate = |
| 209 | + unPerformanceEstimate $ percentile' $ histLookup poolId |
| 210 | + } |
| 211 | + |
| 212 | +-- | Query reward provenance by computing a reward update (internally based on the go snapshot). |
| 213 | +-- Source: ouroboros-consensus:ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs:441 |
| 214 | +-- answerPureBlockQuery case for GetRewardProvenance |
| 215 | +-- |
| 216 | +-- __Note:__ The 'RewardProvenance' component of the result is always 'def' |
| 217 | +-- (empty\/default). Only the 'RewardUpdate' is meaningful. This matches the |
| 218 | +-- consensus implementation, which also discards provenance. |
| 219 | +-- |
| 220 | +-- This function requires the full 'Globals' because it internally runs |
| 221 | +-- 'createRUpd' in a 'Reader' monad that needs access to 'epochInfo', |
| 222 | +-- 'activeSlotCoeff', 'securityParameter', and 'maxLovelaceSupply'. |
| 223 | +queryRewardProvenance :: |
| 224 | + (EraGov era, EraCertState era) => |
| 225 | + Globals -> |
| 226 | + NewEpochState era -> |
| 227 | + (RewardUpdate, RewardProvenance) |
| 228 | +queryRewardProvenance globals newEpochState = |
| 229 | + ( runReader |
| 230 | + (createRUpd slotsPerEpoch blocksMade epochState maxSupply asc secparam) |
| 231 | + globals |
| 232 | + , def |
| 233 | + ) |
| 234 | + where |
| 235 | + epochState = nesEs newEpochState |
| 236 | + maxSupply = Coin (fromIntegral (maxLovelaceSupply globals)) |
| 237 | + blocksMade = nesBprev newEpochState |
| 238 | + epochNo = nesEL newEpochState |
| 239 | + slotsPerEpoch = epochInfoSize (epochInfoPure globals) epochNo |
| 240 | + asc = activeSlotCoeff globals |
| 241 | + secparam = securityParameter globals |
| 242 | +{-# DEPRECATED |
| 243 | + queryRewardProvenance |
| 244 | + "Wallets should prefer 'queryRewardInfoPools' for up-to-date reward information based on the current stake distribution." |
| 245 | + #-} |
0 commit comments