Base stake pool listing on GetRewardProvenance query

• Remove local state queries `GetNonMyopicMemberRewards` and `GetStakeDistribution` This speeds up the entire query. • We compute non-myopic member rewards and desirabilities scores ourselves. • Change `stakeDistribution` to no longer take user stake as input • Change `StakePoolSummary` type
cardano-foundation · Aug 3, 2021 · 7950f5b · 7950f5b
1 parent b57a179
commit 7950f5b
Show file tree

Hide file tree

Showing 5 changed files with 320 additions and 296 deletions.
diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
@@ -167,8 +167,7 @@ data NetworkLayer m block = NetworkLayer
         -- ^ Broadcast a transaction to the chain producer
 
     , stakeDistribution
-        :: Coin -- Stake to consider for rewards
-        -> m StakePoolsSummary
+        :: m (Maybe StakePoolsSummary)
 
     , getCachedRewardAccountBalance
         :: RewardAccount

diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
@@ -88,13 +88,14 @@ module Cardano.Wallet.Primitive.Types
     , IsDelegatingTo (..)
 
     -- * Stake Pools
-    , StakePoolsSummary (..)
-    , StakePoolDesirability (..)
     , PoolId(..)
     , PoolOwner(..)
     , poolIdBytesLength
     , decodePoolIdBech32
     , encodePoolIdBech32
+    , StakePoolsSummary (..)
+    , RewardParams (..)
+    , RewardProvenancePool (..)
     , StakePoolMetadata (..)
     , StakePoolMetadataHash (..)
     , StakePoolMetadataUrl (..)
@@ -736,37 +737,60 @@ instance FromJSON PoolOwner where
 instance ToJSON PoolOwner where
     toJSON = toJSON . toText
 
-data StakePoolsSummary = StakePoolsSummary
-    { nOpt :: Int
-    , rewards :: Map PoolId Coin
-    , desirabilities :: Map PoolId StakePoolDesirability
-    , stake :: Map PoolId Percentage
-    , ownerStake :: Map PoolId Coin
+-- | Information need for the computation of rewards, such as the
+-- stake currently delegated to a pool, or the pool cost and margin.
+data RewardProvenancePool = RewardProvenancePool
+    { stakeRelative :: Percentage -- ^ sigma = pool stake / total stake
+    , ownerPledge :: Coin -- ^ pledge of pool owner(s)
+    , ownerStake :: Coin -- ^ absolute stake delegated by pool owner(s)
+    , ownerStakeRelative :: Percentage -- ^ s = owner stake / total stake
+    , cost :: Coin
+    , margin :: Percentage
+    , performanceEstimate :: Percentage
     } deriving (Show, Eq)
 
-instance Buildable StakePoolsSummary where
-    build StakePoolsSummary{nOpt,rewards,desirabilities,stake,ownerStake} = listF' id
-        [ "Stake: " <> mapF (Map.toList stake)
-        , "Stake owned by pool owners: " <> mapF (Map.toList ownerStake)
-        , "Non-myopic member rewards: " <> mapF (Map.toList rewards)
-        , "Desirability scores for ranking: " <> mapF (Map.toList desirabilities)
-        , "Optimum number of pools: " <> pretty nOpt
+instance Buildable RewardProvenancePool where
+    build RewardProvenancePool
+            {stakeRelative,ownerPledge,ownerStake,ownerStakeRelative
+            ,cost,margin,performanceEstimate
+            }
+      = listF' id
+        [ "Stake (relative): " <> build stakeRelative
+        , "Pledge: " <> build ownerPledge
+        , "Owner stake: " <> build ownerStake
+        , "Owner stake (relative): " <> build ownerStakeRelative
+        , "Pool cost: " <> build cost
+        , "Pool margin: " <> build margin
+        , "Pool performance: " <> build performanceEstimate
         ]
 
--- | Information used for ranking stake pools.
--- Pools with higher desirability scores should be ranked first.
---
--- Mirrors the 'Shelley.Spec.Ledger.RewardProvenance.Desirability' type
--- in cardano-ledger-specs.
-data StakePoolDesirability = StakePoolDesirability
-    { desirabilityScore :: !Double
-    , hitRateEstimate :: !Double
+-- | Global parameters used for computing rewards
+data RewardParams = RewardParams
+    { nOpt :: Int -- ^ desired number of stake pools
+    , a0   :: Rational -- ^ influence of the pool owner's pledge on rewards
+    , r    :: Coin -- ^ Total rewards available for the given epoch
+    , totalStake :: Coin -- ^ Maximum lovelace supply minus treasury
     } deriving (Show, Eq)
+-- NOTE: In the ledger, @a0@ has type 'NonNegativeInterval'.
+
+instance Buildable RewardParams where
+    build RewardParams{nOpt,a0,r,totalStake} = blockListF' "" id
+        [ "Desired number of stake pools: " <> build nOpt
+        , "Pledge influence parameter, a0: " <> build a0
+        , "Total rewards for this epoch: " <> build r
+        , "Total stake: " <> build totalStake
+        ]
 
-instance Buildable StakePoolDesirability where
-    build StakePoolDesirability{desirabilityScore,hitRateEstimate} = listF' id
-        [ "Pool desirability: " <> pretty desirabilityScore
-        , "Pool hit rate (estimate): " <> pretty hitRateEstimate
+-- | Summary of stake distribution and stake pools obtained from network
+data StakePoolsSummary = StakePoolsSummary
+    { params :: RewardParams
+    , pools  :: Map PoolId RewardProvenancePool
+    } deriving (Show, Eq)
+
+instance Buildable StakePoolsSummary where
+    build StakePoolsSummary{params,pools} = blockListF' "" id
+        [ "Global reward parameters: " <> build params
+        , "Individual pools: " <> mapF (Map.toList pools)
         ]
 
 {-------------------------------------------------------------------------------

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
@@ -79,9 +79,8 @@ module Cardano.Wallet.Shelley.Compatibility
       -- ** Stake pools
     , fromPoolId
     , fromPoolDistr
+    , mkStakePoolsSummary
     , fromNonMyopicMemberRewards
-    , getDesirabilities
-    , getOwnerStakes
     , optimumNumberOfPools
     , getProducer
 
@@ -740,27 +739,43 @@ fromNonMyopicMemberRewards =
     . Map.mapKeys (bimap fromShelleyCoin fromStakeCredential)
     . O.unNonMyopicMemberRewards
 
-getDesirabilities
+fromRewardProvenancePool
     :: forall crypto. ()
-    => SL.RewardProvenance crypto
-    -> Map W.PoolId W.StakePoolDesirability
-getDesirabilities =
-    Map.map fromDesirability
-    . Map.mapKeys fromPoolId
-    . SL.desirabilities
-    where
-    fromDesirability (SL.Desirability x y) = W.StakePoolDesirability x y
+    => W.Coin
+    -> SL.RewardProvenancePool crypto
+    -> W.RewardProvenancePool
+fromRewardProvenancePool totalStake SL.RewardProvenancePool{..} =
+  W.RewardProvenancePool
+    { stakeRelative = unsafeMkPercentage sigmaP
+    , ownerPledge = toWalletCoin (SL._poolPledge poolParamsP)
+    , ownerStake = toWalletCoin ownerStakeP
+    , ownerStakeRelative = unsafeMkPercentage
+        $ fromIntegral (SL.unCoin ownerStakeP)
+        / fromIntegral (W.unCoin totalStake)
+    , cost = toWalletCoin (SL._poolCost poolParamsP)
+    , margin = fromUnitInterval (SL._poolMargin poolParamsP)
+    , performanceEstimate = unsafeMkPercentage appPerfP
+    }
 
-getOwnerStakes
-    :: forall crypto. ()
-    => SL.RewardProvenance crypto
-    -> Map W.PoolId W.Coin
-getOwnerStakes =
-    Map.map fromRewardProvenancePool
-    . Map.mapKeys fromPoolId
-    . SL.pools
-    where
-    fromRewardProvenancePool = fromShelleyCoin . SL.ownerStakeP
+mkStakePoolsSummary
+    :: forall era crypto. ()
+    => SLAPI.PParams era
+    -> SL.RewardProvenance crypto
+    -> W.StakePoolsSummary
+mkStakePoolsSummary SL.PParams{_a0,_nOpt} SL.RewardProvenance{totalStake,pools,r}
+  = W.StakePoolsSummary
+    { params = p
+    , pools
+        = Map.map (fromRewardProvenancePool $ toWalletCoin totalStake)
+        $ Map.mapKeys fromPoolId pools
+    }
+  where
+    p = W.RewardParams 
+        { nOpt = fromIntegral _nOpt
+        , a0   = fromNonNegativeInterval _a0
+        , r    = toWalletCoin r
+        , totalStake = toWalletCoin totalStake
+        }
 
 optimumNumberOfPools
     :: forall era. (SLAPI.PParams era ~ SL.Core.PParams era)
@@ -1048,6 +1063,9 @@ fromUnitInterval x =
         , show x
         ]
 
+fromNonNegativeInterval :: SL.NonNegativeInterval -> Rational
+fromNonNegativeInterval = SL.unboundRational
+
 -- | SealedTx are the result of rightfully constructed shelley transactions so, it
 -- is relatively safe to unserialize them from CBOR.
 unsealShelleyTx

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -69,21 +69,16 @@ import Cardano.Wallet.Shelley.Compatibility
     , StandardCrypto
     , fromCardanoHash
     , fromChainHash
-    , fromNonMyopicMemberRewards
-    , fromPoolDistr
     , fromShelleyCoin
     , fromShelleyPParams
     , fromStakeCredential
     , fromTip
     , fromTip'
-    , getDesirabilities
-    , getOwnerStakes
+    , mkStakePoolsSummary
     , nodeToClientVersion
-    , optimumNumberOfPools
     , slottingParametersFromGenesis
     , toCardanoEra
     , toPoint
-    , toShelleyCoin
     , toStakeCredential
     , unsealShelleyTx
     )
@@ -141,8 +136,6 @@ import Data.Maybe
     ( fromMaybe )
 import Data.Proxy
     ( Proxy (..) )
-import Data.Quantity
-    ( Percentage )
 import Data.Set
     ( Set )
 import Data.Text
@@ -494,75 +487,25 @@ withNetworkLayerBase tr np conn (versionData, _) tol action = do
                     SubmitSuccess -> pure ()
                     SubmitFail err -> throwE $ ErrPostTxBadRequest $ T.pack (show err)
 
-
-    _stakeDistribution queue coin = do
-        liftIO $ traceWith tr $ MsgWillQueryRewardsForStake coin
-
-        let mkStakePoolsSummary4 m1 m2 m3 m4 = do
-                (r3, r5) <- m3
-                W.StakePoolsSummary <$> m1 <*> m2 <*> pure r3 <*> m4 <*> pure r5
-        let qry :: LSQ (CardanoBlock StandardCrypto) IO (Maybe W.StakePoolsSummary)
-            qry = mkStakePoolsSummary4
-                <$> getNOpt
-                <*> queryNonMyopicMemberRewards
-                <*> queryRewardsProvenance
-                <*> stakeDistr
+    _stakeDistribution queue = do
+        liftIO $ traceWith tr $ MsgWillQueryRewards
 
         mres <- bracketQuery "stakePoolsSummary" tr $
-            queue `send` (SomeLSQ qry)
+            queue `send` (SomeLSQ qryStakePoolSummary)
         traceWith tr $ MsgFetchStakePoolsData mres
 
-        -- The result will be Nothing if query occurs during the byron era
         case mres of
-            Just res@W.StakePoolsSummary{rewards,stake} -> do
-                liftIO $ traceWith tr $ MsgFetchStakePoolsDataSummary
-                    (Map.size stake)
-                    (Map.size rewards)
-                pure res
-            Nothing -> pure $ W.StakePoolsSummary 0 mempty mempty mempty mempty
+            Just W.StakePoolsSummary{pools} ->
+                traceWith tr $ MsgFetchStakePoolsDataSummary (Map.size pools)
+            Nothing  -> pure () -- we seem to be in the Byron era
+        pure mres
       where
-
-        stakeDistr
-            :: LSQ (CardanoBlock StandardCrypto) IO
-                (Maybe (Map W.PoolId Percentage))
-        stakeDistr = shelleyBased
-            (fromPoolDistr <$> LSQry Shelley.GetStakeDistribution)
-
-        getNOpt :: LSQ (CardanoBlock StandardCrypto) IO (Maybe Int)
-        getNOpt = shelleyBased $
-            optimumNumberOfPools <$> LSQry Shelley.GetCurrentPParams
-
-        queryRewardsProvenance
-            :: LSQ (CardanoBlock StandardCrypto) IO
-                ( Maybe
-                    ( Map W.PoolId W.StakePoolDesirability
-                    , Map W.PoolId W.Coin
-                    )
-                )
-        queryRewardsProvenance = shelleyBased $ do
-            r <- LSQry Shelley.GetRewardProvenance
-            pure (getDesirabilities r, getOwnerStakes r)
-
-        queryNonMyopicMemberRewards
-            :: LSQ (CardanoBlock StandardCrypto) IO
-                    (Maybe (Map W.PoolId W.Coin))
-        queryNonMyopicMemberRewards = shelleyBased $
-            (getRewardMap . fromNonMyopicMemberRewards)
-                <$> LSQry (Shelley.GetNonMyopicMemberRewards stake)
-          where
-            stake :: Set (Either SL.Coin a)
-            stake = Set.singleton $ Left $ toShelleyCoin coin
-
-            fromJustRewards = fromMaybe
-                (error "stakeDistribution: requested rewards not included in response")
-
-            getRewardMap
-                :: Map
-                    (Either W.Coin W.RewardAccount)
-                    (Map W.PoolId W.Coin)
-                -> Map W.PoolId W.Coin
-            getRewardMap =
-                fromJustRewards . Map.lookup (Left coin)
+        qryStakePoolSummary
+            :: LSQ (CardanoBlock StandardCrypto) IO (Maybe W.StakePoolsSummary)
+        qryStakePoolSummary = shelleyBased $
+            mkStakePoolsSummary
+            <$> LSQry Shelley.GetCurrentPParams
+            <*> LSQry Shelley.GetRewardProvenance
 
     _watchNodeTip readTip cb = do
         observeForever readTip $ \tip -> do
@@ -1187,11 +1130,11 @@ data NetworkLayerLog where
         -> SL.RewardAccounts era
         -> NetworkLayerLog
     MsgDestroyCursor :: ThreadId -> NetworkLayerLog
-    MsgWillQueryRewardsForStake :: W.Coin -> NetworkLayerLog
+    MsgWillQueryRewards :: NetworkLayerLog
     MsgFetchStakePoolsData :: Maybe W.StakePoolsSummary -> NetworkLayerLog
-    MsgFetchStakePoolsDataSummary :: Int -> Int -> NetworkLayerLog
-      -- ^ Number of pools in stake distribution, and rewards map,
-      -- respectively.
+    MsgFetchStakePoolsDataSummary
+        :: Int -- ^ Number of pools in rewards provenance.
+        -> NetworkLayerLog
     MsgWatcherUpdate :: W.BlockHeader -> BracketLog -> NetworkLayerLog
     MsgChainSyncCmd :: (ChainSyncLog Text Text) -> NetworkLayerLog
     MsgInterpreter :: CardanoInterpreter StandardCrypto -> NetworkLayerLog
@@ -1271,16 +1214,14 @@ instance ToText NetworkLayerLog where
             [ "Destroying cursor connection at"
             , T.pack (show threadId)
             ]
-        MsgWillQueryRewardsForStake c ->
-            "Will query non-myopic rewards using the stake " <> pretty c
+        MsgWillQueryRewards ->
+            "Will query pool rewards and stake distribution"
         MsgFetchStakePoolsData d ->
             "Fetched pool data from node tip using LSQ: " <> pretty d
-        MsgFetchStakePoolsDataSummary inStake inRewards -> mconcat
+        MsgFetchStakePoolsDataSummary inRewards -> mconcat
             [ "Fetched pool data from node tip using LSQ. Got "
-            , T.pack (show inStake)
-            , " pools in the stake distribution, and "
             , T.pack (show inRewards)
-            , " pools in the non-myopic member reward map."
+            , " pools in the reward provenance."
             ]
         MsgWatcherUpdate tip b ->
             "Update watcher with tip: " <> pretty tip <>
@@ -1317,7 +1258,7 @@ instance HasSeverityAnnotation NetworkLayerLog where
         MsgLocalStateQueryEraMismatch{}    -> Debug
         MsgAccountDelegationAndRewards{}   -> Debug
         MsgDestroyCursor{}                 -> Debug
-        MsgWillQueryRewardsForStake{}      -> Info
+        MsgWillQueryRewards{}              -> Info
         MsgFetchStakePoolsData{}           -> Debug
         MsgFetchStakePoolsDataSummary{}    -> Info
         MsgWatcherUpdate{}                 -> Debug