Ledger API function for stake distribution and pool parameters query

eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Wallet.hs

@@ -1,28 +1,41 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Ledger.Shelley.API.Wallet
   ( getNonMyopicMemberRewards,
+
+    -- * UTxOs
     getUTxO,
     getUTxOSubset,
     getFilteredUTxO,
+
+    -- * Stake Pools
     getLeaderSchedule,
     getPools,
     getPoolParameters,
     getTotalStake,
     poolsByTotalStakeFraction,
+    RewardInfoPool (..),
+    RewardParams (..),
+    getRewardInfoPools,
     getRewardInfo,
+
+    -- * Transaction helpers
     CLI (..),
     addShelleyKeyWitnesses,
-    -- | Ada Pots
+
+    -- * Ada Pots
     AdaPots (..),
     totalAdaES,
     totalAdaPotsES,
@@ -68,6 +81,7 @@ import Cardano.Ledger.Shelley.PParams (PParams, PParams' (..), ProtVer)
 import Cardano.Ledger.Shelley.RewardProvenance (RewardProvenance)
 import Cardano.Ledger.Shelley.Rewards
   ( NonMyopic (..),
+    PerformanceEstimate (..),
     StakeShare (..),
     getTopRankedPools,
     nonMyopicMemberRew,
@@ -88,8 +102,10 @@ import Cardano.Protocol.TPraos.BHeader (checkLeaderValue, mkSeed, seedL)
 import Cardano.Protocol.TPraos.Rules.Tickn (TicknState (..))
 import Cardano.Slotting.EpochInfo (epochInfoRange)
 import Cardano.Slotting.Slot (EpochSize, SlotNo)
+import Control.DeepSeq (NFData)
 import Control.Monad.Trans.Reader (runReader)
 import Control.Provenance (runWithProvM)
+import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.ByteString.Lazy as LBS
 import Data.Default.Class (Default (..))
 import Data.Either (fromRight)
@@ -103,9 +119,73 @@ import Data.Ratio ((%))
 import Data.Sequence.Strict (StrictSeq)
 import Data.Set (Set)
 import qualified Data.Set as Set
+import GHC.Generics (Generic)
 import GHC.Records (HasField (..), getField)
+import NoThunks.Class (NoThunks (..))
 import Numeric.Natural (Natural)
 
+--------------------------------------------------------------------------------
+-- UTxOs
+--------------------------------------------------------------------------------
+
+-- | Get the full UTxO.
+getUTxO ::
+  NewEpochState era ->
+  UTxO era
+getUTxO = _utxo . _utxoState . esLState . nesEs
+
+-- | Get the UTxO filtered by address.
+getFilteredUTxO ::
+  HasField "compactAddress" (Core.TxOut era) (CompactAddr (Crypto era)) =>
+  NewEpochState era ->
+  Set (Addr (Crypto era)) ->
+  UTxO era
+getFilteredUTxO ss addrs =
+  UTxO $
+    Map.filter
+      (\out -> getField @"compactAddress" out `Set.member` addrSBSs)
+      fullUTxO
+  where
+    UTxO fullUTxO = getUTxO ss
+    -- Instead of decompacting each address in the huge UTxO, compact each
+    -- address in the small set of address.
+    addrSBSs = Set.map compactAddr addrs
+
+getUTxOSubset ::
+  NewEpochState era ->
+  Set (TxIn (Crypto era)) ->
+  UTxO era
+getUTxOSubset ss txins =
+  UTxO $
+    fullUTxO `Map.restrictKeys` txins
+  where
+    UTxO fullUTxO = getUTxO ss
+
+--------------------------------------------------------------------------------
+-- Stake pools and pool rewards
+--------------------------------------------------------------------------------
+
+-- | Get the /current/ registered stake pool parameters for a given set of
+-- stake pools. The result map will contain entries for all the given stake
+-- pools that are currently registered.
+getPools ::
+  NewEpochState era ->
+  Set (KeyHash 'StakePool (Crypto era))
+getPools = Map.keysSet . f
+  where
+    f = _pParams . _pstate . _delegationState . esLState . nesEs
+
+-- | Get the /current/ registered stake pool parameters for a given set of
+-- stake pools. The result map will contain entries for all the given stake
+-- pools that are currently registered.
+getPoolParameters ::
+  NewEpochState era ->
+  Set (KeyHash 'StakePool (Crypto era)) ->
+  Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
+getPoolParameters = Map.restrictKeys . f
+  where
+    f = _pParams . _pstate . _delegationState . esLState . nesEs
+
 -- | Get pool sizes, but in terms of total stake
 --
 -- The stake distribution uses active stake (so that the leader schedule is not
@@ -238,92 +318,124 @@ currentSnapshot ss =
     dstate = _dstate . _delegationState . esLState $ es
     pstate = _pstate . _delegationState . esLState $ es
 
--- | Get the full UTxO.
-getUTxO ::
-  NewEpochState era ->
-  UTxO era
-getUTxO = _utxo . _utxoState . esLState . nesEs
+-- | Information about a stake pool
+data RewardInfoPool = RewardInfoPool
+  { -- | Absolute stake delegated to this pool
+    stake :: Coin,
+    -- | Pledge of pool owner(s)
+    ownerPledge :: Coin,
+    -- | Absolute stake delegated by pool owner(s)
+    ownerStake :: Coin,
+    -- | Pool cost
+    cost :: Coin,
+    -- | Pool margin
+    margin :: UnitInterval,
+    -- | Number of blocks produced divided by expected number of blocks.
+    -- Can be larger than @1.0@ for pool that gets lucky.
+    -- (If some pools get unlucky, some pools must get lucky.)
+    performanceEstimate :: Double
+  }
+  deriving (Eq, Show, Generic)
 
--- | Get the UTxO filtered by address.
-getFilteredUTxO ::
-  HasField "compactAddress" (Core.TxOut era) (CompactAddr (Crypto era)) =>
-  NewEpochState era ->
-  Set (Addr (Crypto era)) ->
-  UTxO era
-getFilteredUTxO ss addrs =
-  UTxO $
-    Map.filter
-      (\out -> getField @"compactAddress" out `Set.member` addrSBSs)
-      fullUTxO
-  where
-    UTxO fullUTxO = getUTxO ss
-    -- Instead of decompacting each address in the huge UTxO, compact each
-    -- address in the small set of address.
-    addrSBSs = Set.map compactAddr addrs
+instance NoThunks RewardInfoPool
 
-getUTxOSubset ::
-  NewEpochState era ->
-  Set (TxIn (Crypto era)) ->
-  UTxO era
-getUTxOSubset ss txins =
-  UTxO $
-    fullUTxO `Map.restrictKeys` txins
-  where
-    UTxO fullUTxO = getUTxO ss
+instance NFData RewardInfoPool
 
--- | Get the (private) leader schedule for this epoch.
+deriving instance FromJSON RewardInfoPool
+
+deriving instance ToJSON RewardInfoPool
+
+-- | Global information that influences stake pool rewards
+data RewardParams = RewardParams
+  { -- | Desired number of stake pools
+    nOpt :: Natural,
+    -- | Influence of the pool owner's pledge on rewards
+    a0 :: NonNegativeInterval,
+    -- | Total rewards available for the given epoch
+    rPot :: Coin,
+    -- | Maximum lovelace supply minus treasury
+    totalStake :: Coin
+  }
+  deriving (Eq, Show, Generic)
+
+instance NoThunks RewardParams
+
+instance NFData RewardParams
+
+deriving instance FromJSON RewardParams
+
+deriving instance ToJSON RewardParams
+
+-- | Retrieve the information necessary to calculate stake pool member rewards
+-- from the /current/ stake distribution.
 --
---   Given a private VRF key, returns the set of slots in which this node is
---   eligible to lead.
-getLeaderSchedule ::
-  ( Era era,
-    VRF.Signable
-      (VRF (Crypto era))
-      Seed
+-- This information includes the current stake distribution aggregated
+-- by stake pools and pool owners,
+-- the `current` pool costs and margins,
+-- and performance estimates.
+-- Also included are global information such as
+-- the total stake or protocol parameters.
+getRewardInfoPools ::
+  ( UsesValue era,
+    HasField "_a0" (Core.PParams era) NonNegativeInterval,
+    HasField "_nOpt" (Core.PParams era) Natural,
+    HasField "address" (Core.TxOut era) (Addr (Crypto era))
   ) =>
   Globals ->
   NewEpochState era ->
-  ChainDepState (Crypto era) ->
-  KeyHash 'StakePool (Crypto era) ->
-  SignKeyVRF (Crypto era) ->
-  PParams era ->
-  Set SlotNo
-getLeaderSchedule globals ss cds poolHash key pp = Set.filter isLeader epochSlots
+  (RewardParams, Map (KeyHash 'StakePool (Crypto era)) RewardInfoPool)
+getRewardInfoPools globals ss =
+  (mkRewardParams, Map.mapWithKey mkRewardInfoPool poolParams)
   where
-    isLeader slotNo =
-      let y = VRF.evalCertified () (mkSeed seedL slotNo epochNonce) key
-       in not (isOverlaySlot a (_d pp) slotNo)
-            && checkLeaderValue (VRF.certifiedOutput y) stake f
-    stake = maybe 0 individualPoolStake $ Map.lookup poolHash poolDistr
-    poolDistr = unPoolDistr $ nesPd ss
-    TicknState epochNonce _ = csTickn cds
-    currentEpoch = nesEL ss
-    ei = epochInfo globals
-    f = activeSlotCoeff globals
-    epochSlots = Set.fromList [a .. b]
-    (a, b) = runIdentity $ epochInfoRange ei currentEpoch
+    maxSupply = Coin . fromIntegral $ maxLovelaceSupply globals
+    totalStake = circulation es maxSupply
 
--- | Get the /current/ registered stake pool parameters for a given set of
--- stake pools. The result map will contain entries for all the given stake
--- pools that are currently registered.
-getPools ::
-  NewEpochState era ->
-  Set (KeyHash 'StakePool (Crypto era))
-getPools = Map.keysSet . f
-  where
-    f = _pParams . _pstate . _delegationState . esLState . nesEs
+    es = nesEs ss
+    pp = esPp es
+    NonMyopic
+      { likelihoodsNM = ls,
+        rewardPotNM = rPot
+      } = esNonMyopic es
+    histLookup key = fromMaybe mempty (Map.lookup key ls)
 
--- | Get the /current/ registered stake pool parameters for a given set of
--- stake pools. The result map will contain entries for all the given stake
--- pools that are currently registered.
-getPoolParameters ::
-  NewEpochState era ->
-  Set (KeyHash 'StakePool (Crypto era)) ->
-  Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-getPoolParameters = Map.restrictKeys . f
-  where
-    f = _pParams . _pstate . _delegationState . esLState . nesEs
+    EB.SnapShot stake delegs poolParams = currentSnapshot ss
+
+    mkRewardParams =
+      RewardParams
+        { a0 = getField @"_a0" pp,
+          nOpt = getField @"_nOpt" pp,
+          totalStake = totalStake,
+          rPot = rPot
+        }
+    mkRewardInfoPool key poolp =
+      RewardInfoPool
+        { stake = pstake,
+          ownerStake = ostake,
+          ownerPledge = _poolPledge poolp,
+          margin = _poolMargin poolp,
+          cost = _poolCost poolp,
+          performanceEstimate =
+            unPerformanceEstimate $ percentile' $ histLookup key
+        }
+      where
+        pstake = fold . EB.unStake $ EB.poolStake key delegs stake
+        ostake =
+          Set.foldl'
+            ( \c o ->
+                c
+                  <> fromMaybe
+                    mempty
+                    (Map.lookup (KeyHashObj o) (EB.unStake stake))
+            )
+            mempty
+            (_poolOwners poolp)
 
+-- | Calculate stake pool rewards from the snapshot labeled `go`.
+-- Also includes information on how the rewards were calculated
+-- ('RewardProvenance').
+--
+-- For a calculation of rewards based on the current stake distribution,
+-- see 'getRewardInfo'.
 getRewardInfo ::
   forall era.
   ( HasField "_a0" (Core.PParams era) NonNegativeInterval,
@@ -354,6 +466,42 @@ getRewardInfo globals newepochstate =
     asc = activeSlotCoeff globals
     secparam = securityParameter globals
 
+-- | Get the (private) leader schedule for this epoch.
+--
+--   Given a private VRF key, returns the set of slots in which this node is
+--   eligible to lead.
+getLeaderSchedule ::
+  ( Era era,
+    VRF.Signable
+      (VRF (Crypto era))
+      Seed
+  ) =>
+  Globals ->
+  NewEpochState era ->
+  ChainDepState (Crypto era) ->
+  KeyHash 'StakePool (Crypto era) ->
+  SignKeyVRF (Crypto era) ->
+  PParams era ->
+  Set SlotNo
+getLeaderSchedule globals ss cds poolHash key pp = Set.filter isLeader epochSlots
+  where
+    isLeader slotNo =
+      let y = VRF.evalCertified () (mkSeed seedL slotNo epochNonce) key
+       in not (isOverlaySlot a (_d pp) slotNo)
+            && checkLeaderValue (VRF.certifiedOutput y) stake f
+    stake = maybe 0 individualPoolStake $ Map.lookup poolHash poolDistr
+    poolDistr = unPoolDistr $ nesPd ss
+    TicknState epochNonce _ = csTickn cds
+    currentEpoch = nesEL ss
+    ei = epochInfo globals
+    f = activeSlotCoeff globals
+    epochSlots = Set.fromList [a .. b]
+    (a, b) = runIdentity $ epochInfoRange ei currentEpoch
+
+--------------------------------------------------------------------------------
+-- Transaction helpers
+--------------------------------------------------------------------------------
+
 -- | A collection of functons to help construction transactions
 --  from the cardano-cli.
 class