{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- FIXME: use better names for record names
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module Cardano.Ledger.Shelley.API.Wallet (
  -- * UTxOs
  getUTxO,
  getUTxOSubset,
  getFilteredUTxO,

  -- * Stake Pools
  getPools,
  getPoolParameters,
  getTotalStake,
  poolsByTotalStakeFraction,
  RewardInfoPool (..),
  RewardParams (..),
  getRewardInfoPools,
  getRewardProvenance,
  getNonMyopicMemberRewards,

  -- * Transaction helpers
  addKeyWitnesses,

  -- * Ada pots
  AdaPots (..),
  totalAdaES,
  totalAdaPotsES,
)
where

import Cardano.Ledger.Address (Addr (..), compactAddr)
import Cardano.Ledger.BaseTypes (
  BlocksMade,
  Globals (..),
  NonNegativeInterval,
  UnitInterval,
  epochInfoPure,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  decodeDouble,
  encodeDouble,
 )
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import qualified Cardano.Ledger.EpochBoundary as EB
import Cardano.Ledger.Keys (KeyHash, KeyRole (..), WitVKey (..))
import Cardano.Ledger.PoolDistr (
  IndividualPoolStake (..),
  PoolDistr (..),
 )
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.AdaPots (
  AdaPots (..),
  totalAdaES,
  totalAdaPotsES,
 )
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.LedgerState (
  CertState (..),
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  PState (..),
  RewardUpdate,
  UTxOState (..),
  circulation,
  createRUpd,
  curPParamsEpochStateL,
  incrementalStakeDistr,
 )
import Cardano.Ledger.Shelley.PoolRank (
  NonMyopic (..),
  PerformanceEstimate (..),
  getTopRankedPoolsVMap,
  nonMyopicMemberRew,
  percentile',
 )
import Cardano.Ledger.Shelley.RewardProvenance (RewardProvenance)
import Cardano.Ledger.Shelley.Rewards (StakeShare (..))
import Cardano.Ledger.Shelley.Rules.NewEpoch (calculatePoolDistr)
import Cardano.Ledger.Slot (epochInfoSize)
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UTxO (UTxO (..), txInsFilter)
import Cardano.Slotting.Slot (EpochSize)
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (runReader)
import Data.Aeson (FromJSON, ToJSON)
import Data.Default (Default (def))
import Data.Foldable (foldMap')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.VMap as VMap
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)

--------------------------------------------------------------------------------
-- UTxOs
--------------------------------------------------------------------------------

-- | Get the full UTxO.
getUTxO ::
  NewEpochState era ->
  UTxO era
getUTxO :: forall era. NewEpochState era -> UTxO era
getUTxO = forall era. UTxOState era -> UTxO era
utxosUtxo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> UTxOState era
lsUTxOState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs

-- | Get the UTxO filtered by address.
getFilteredUTxO ::
  EraTxOut era =>
  NewEpochState era ->
  Set (Addr (EraCrypto era)) ->
  UTxO era
getFilteredUTxO :: forall era.
EraTxOut era =>
NewEpochState era -> Set (Addr (EraCrypto era)) -> UTxO era
getFilteredUTxO NewEpochState era
ss Set (Addr (EraCrypto era))
addrSet =
  forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter TxOut era -> Bool
checkAddr Map (TxIn (EraCrypto era)) (TxOut era)
fullUTxO
  where
    UTxO Map (TxIn (EraCrypto era)) (TxOut era)
fullUTxO = forall era. NewEpochState era -> UTxO era
getUTxO NewEpochState era
ss
    compactAddrSet :: Set (CompactAddr (EraCrypto era))
compactAddrSet = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall c. Addr c -> CompactAddr c
compactAddr Set (Addr (EraCrypto era))
addrSet
    checkAddr :: TxOut era -> Bool
checkAddr TxOut era
out =
      case TxOut era
out forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens'
  (TxOut era)
  (Either (Addr (EraCrypto era)) (CompactAddr (EraCrypto era)))
addrEitherTxOutL of
        Left Addr (EraCrypto era)
addr -> Addr (EraCrypto era)
addr forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (Addr (EraCrypto era))
addrSet
        Right CompactAddr (EraCrypto era)
cAddr -> CompactAddr (EraCrypto era)
cAddr forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (CompactAddr (EraCrypto era))
compactAddrSet
{-# INLINEABLE getFilteredUTxO #-}

getUTxOSubset ::
  NewEpochState era ->
  Set (TxIn (EraCrypto era)) ->
  UTxO era
getUTxOSubset :: forall era.
NewEpochState era -> Set (TxIn (EraCrypto era)) -> UTxO era
getUTxOSubset NewEpochState era
nes = forall era. UTxO era -> Set (TxIn (EraCrypto era)) -> UTxO era
txInsFilter (forall era. NewEpochState era -> UTxO era
getUTxO NewEpochState era
nes)

--------------------------------------------------------------------------------
-- Stake pools and pool rewards
--------------------------------------------------------------------------------

-- | Get the /current/ registered stake pools.
getPools ::
  NewEpochState era ->
  Set (KeyHash 'StakePool (EraCrypto era))
getPools :: forall era.
NewEpochState era -> Set (KeyHash 'StakePool (EraCrypto era))
getPools = forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {era}.
NewEpochState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
f
  where
    f :: NewEpochState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
f = forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
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 (EraCrypto era)) ->
  Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
getPoolParameters :: forall era.
NewEpochState era
-> Set (KeyHash 'StakePool (EraCrypto era))
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
getPoolParameters = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {era}.
NewEpochState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
f
  where
    f :: NewEpochState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
f = forall era.
PState era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs

-- | Get pool sizes, but in terms of total stake
--
-- The stake distribution uses active stake (so that the leader schedule is not
-- affected by undelegated stake), but the wallet wants to display pool
-- saturation for rewards purposes. For that, it needs the fraction of total
-- stake.
--
-- The fields `individualTotalPoolStake` and `pdTotalActiveStake` continue to
-- remain based on active stake and not total stake.
--
-- This is not based on any snapshot, but uses the current ledger state.
poolsByTotalStakeFraction ::
  forall era.
  EraGov era =>
  Globals ->
  NewEpochState era ->
  PoolDistr (EraCrypto era)
poolsByTotalStakeFraction :: forall era.
EraGov era =>
Globals -> NewEpochState era -> PoolDistr (EraCrypto era)
poolsByTotalStakeFraction Globals
globals NewEpochState era
ss =
  forall c.
Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> CompactForm Coin -> PoolDistr c
PoolDistr Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolsByTotalStake CompactForm Coin
totalActiveStake
  where
    snap :: SnapShot (EraCrypto era)
snap = forall era.
EraGov era =>
NewEpochState era -> SnapShot (EraCrypto era)
currentSnapshot NewEpochState era
ss
    Coin Integer
totalStake = forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss
    stakeRatio :: Rational
stakeRatio = Coin -> Integer
unCoin (forall a. Compactible a => CompactForm a -> a
fromCompact CompactForm Coin
totalActiveStake) forall a. Integral a => a -> a -> Ratio a
% Integer
totalStake
    PoolDistr Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolsByActiveStake CompactForm Coin
totalActiveStake = forall c. SnapShot c -> PoolDistr c
calculatePoolDistr SnapShot (EraCrypto era)
snap
    poolsByTotalStake :: Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolsByTotalStake = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map IndividualPoolStake (EraCrypto era)
-> IndividualPoolStake (EraCrypto era)
toTotalStakeFrac Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
poolsByActiveStake
    toTotalStakeFrac ::
      IndividualPoolStake (EraCrypto era) ->
      IndividualPoolStake (EraCrypto era)
    toTotalStakeFrac :: IndividualPoolStake (EraCrypto era)
-> IndividualPoolStake (EraCrypto era)
toTotalStakeFrac (IndividualPoolStake Rational
s CompactForm Coin
c VRFVerKeyHash 'StakePoolVRF (EraCrypto era)
vrf) =
      forall c.
Rational
-> CompactForm Coin
-> VRFVerKeyHash 'StakePoolVRF c
-> IndividualPoolStake c
IndividualPoolStake (Rational
s forall a. Num a => a -> a -> a
* Rational
stakeRatio) CompactForm Coin
c VRFVerKeyHash 'StakePoolVRF (EraCrypto era)
vrf

-- | Calculate the current total stake.
getTotalStake :: Globals -> NewEpochState era -> Coin
getTotalStake :: forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss =
  let supply :: Coin
supply = Integer -> Coin
Coin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
globals
      es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
   in forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
supply

-- | Calculate the Non-Myopic Pool Member Rewards for a set of credentials.
-- For each given credential, this function returns a map from each stake
-- pool (identified by the key hash of the pool operator) to the
-- non-myopic pool member reward for that stake pool.
--
-- This is not based on any snapshot, but uses the current ledger state.
getNonMyopicMemberRewards ::
  EraGov era =>
  Globals ->
  NewEpochState era ->
  Set (Either Coin (Credential 'Staking (EraCrypto era))) ->
  Map
    (Either Coin (Credential 'Staking (EraCrypto era)))
    (Map (KeyHash 'StakePool (EraCrypto era)) Coin)
getNonMyopicMemberRewards :: forall era.
EraGov era =>
Globals
-> NewEpochState era
-> Set (Either Coin (Credential 'Staking (EraCrypto era)))
-> Map
     (Either Coin (Credential 'Staking (EraCrypto era)))
     (Map (KeyHash 'StakePool (EraCrypto era)) Coin)
getNonMyopicMemberRewards Globals
globals NewEpochState era
ss =
  forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\Either Coin (Credential 'Staking (EraCrypto era))
cred -> forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (StakeShare
-> (PerformanceEstimate, PoolParams (EraCrypto era), StakeShare)
-> Coin
mkNMMRewards forall a b. (a -> b) -> a -> b
$ Either Coin (Credential 'Staking (EraCrypto era)) -> StakeShare
memShare Either Coin (Credential 'Staking (EraCrypto era))
cred) Map
  (KeyHash 'StakePool (EraCrypto era))
  (PerformanceEstimate, PoolParams (EraCrypto era), StakeShare)
poolData)
  where
    maxSupply :: Coin
maxSupply = Integer -> Coin
Coin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Globals -> Word64
maxLovelaceSupply Globals
globals
    Coin Integer
totalStake = forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
    toShare :: Coin -> StakeShare
toShare (Coin Integer
x) = Rational -> StakeShare
StakeShare (Integer
x forall a. Integral a => a -> a -> Ratio a
% Integer
totalStake)
    memShare :: Either Coin (Credential 'Staking (EraCrypto era)) -> StakeShare
memShare (Right Credential 'Staking (EraCrypto era)
cred) =
      Coin -> StakeShare
toShare forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Compactible a => CompactForm a -> a
fromCompact forall a b. (a -> b) -> a -> b
$ forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup Credential 'Staking (EraCrypto era)
cred (forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
EB.unStake Stake (EraCrypto era)
stake)
    memShare (Left Coin
coin) = Coin -> StakeShare
toShare Coin
coin
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    pp :: PParams era
pp = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    NonMyopic {likelihoodsNM :: forall c. NonMyopic c -> Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
ls, rewardPotNM :: forall c. NonMyopic c -> Coin
rewardPotNM = Coin
rPot} = forall era. EpochState era -> NonMyopic (EraCrypto era)
esNonMyopic EpochState era
es
    EB.SnapShot Stake (EraCrypto era)
stake VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams = forall era.
EraGov era =>
NewEpochState era -> SnapShot (EraCrypto era)
currentSnapshot NewEpochState era
ss
    poolData :: Map
  (KeyHash 'StakePool (EraCrypto era))
  (PerformanceEstimate, PoolParams (EraCrypto era), StakeShare)
poolData =
      forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList
        [ ( KeyHash 'StakePool (EraCrypto era)
k
          ,
            ( Likelihood -> PerformanceEstimate
percentile' (KeyHash 'StakePool (EraCrypto era) -> Likelihood
histLookup KeyHash 'StakePool (EraCrypto era)
k)
            , PoolParams (EraCrypto era)
p
            , Coin -> StakeShare
toShare forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Stake c -> Coin
EB.sumAllStake forall a b. (a -> b) -> a -> b
$ forall c.
KeyHash 'StakePool c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c
-> Stake c
EB.poolStake KeyHash 'StakePool (EraCrypto era)
k VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs Stake (EraCrypto era)
stake
            )
          )
        | (KeyHash 'StakePool (EraCrypto era)
k, PoolParams (EraCrypto era)
p) <- forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> [(k, v)]
VMap.toAscList VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
        ]
    histLookup :: KeyHash 'StakePool (EraCrypto era) -> Likelihood
histLookup KeyHash 'StakePool (EraCrypto era)
k = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty KeyHash 'StakePool (EraCrypto era)
k Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
ls
    topPools :: Set (KeyHash 'StakePool (EraCrypto era))
topPools =
      forall era.
EraPParams era =>
Coin
-> Coin
-> PParams era
-> VMap
     VB
     VB
     (KeyHash 'StakePool (EraCrypto era))
     (PoolParams (EraCrypto era))
-> Map (KeyHash 'StakePool (EraCrypto era)) PerformanceEstimate
-> Set (KeyHash 'StakePool (EraCrypto era))
getTopRankedPoolsVMap
        Coin
rPot
        (Integer -> Coin
Coin Integer
totalStake)
        PParams era
pp
        VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams
        (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Likelihood -> PerformanceEstimate
percentile' Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
ls)
    mkNMMRewards :: StakeShare
-> (PerformanceEstimate, PoolParams (EraCrypto era), StakeShare)
-> Coin
mkNMMRewards StakeShare
t (PerformanceEstimate
hitRateEst, PoolParams (EraCrypto era)
poolp, StakeShare
sigma) =
      if PoolParams (EraCrypto era) -> Bool
checkPledge PoolParams (EraCrypto era)
poolp
        then forall era c.
EraPParams era =>
PParams era
-> Coin
-> PoolParams c
-> StakeShare
-> StakeShare
-> StakeShare
-> Set (KeyHash 'StakePool c)
-> PerformanceEstimate
-> Coin
nonMyopicMemberRew PParams era
pp Coin
rPot PoolParams (EraCrypto era)
poolp StakeShare
s StakeShare
sigma StakeShare
t Set (KeyHash 'StakePool (EraCrypto era))
topPools PerformanceEstimate
hitRateEst
        else forall a. Monoid a => a
mempty
      where
        s :: StakeShare
s = (Coin -> StakeShare
toShare forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PoolParams c -> Coin
ppPledge) PoolParams (EraCrypto era)
poolp
        checkPledge :: PoolParams (EraCrypto era) -> Bool
checkPledge PoolParams (EraCrypto era)
pool =
          let ostake :: Coin
ostake = forall c. PoolParams c -> Stake c -> Coin
sumPoolOwnersStake PoolParams (EraCrypto era)
pool Stake (EraCrypto era)
stake
           in forall c. PoolParams c -> Coin
ppPledge PoolParams (EraCrypto era)
poolp forall a. Ord a => a -> a -> Bool
<= Coin
ostake

sumPoolOwnersStake :: PoolParams c -> EB.Stake c -> Coin
sumPoolOwnersStake :: forall c. PoolParams c -> Stake c -> Coin
sumPoolOwnersStake PoolParams c
pool Stake c
stake =
  let getStakeFor :: KeyHash 'Staking c -> Coin
getStakeFor KeyHash 'Staking c
o =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a. Compactible a => CompactForm a -> a
fromCompact forall a b. (a -> b) -> a -> b
$ forall k (kv :: * -> *) (vv :: * -> *) v.
(Ord k, Vector kv k, Vector vv v) =>
k -> VMap kv vv k v -> Maybe v
VMap.lookup (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'Staking c
o) (forall c.
Stake c -> VMap VB VP (Credential 'Staking c) (CompactForm Coin)
EB.unStake Stake c
stake)
   in forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' KeyHash 'Staking c -> Coin
getStakeFor (forall c. PoolParams c -> Set (KeyHash 'Staking c)
ppOwners PoolParams c
pool)

-- | Create a current snapshot of the ledger state.
--
-- When ranking pools, and reporting their saturation level, in the wallet, we
-- do not want to use one of the regular snapshots, but rather the most recent
-- ledger state.
currentSnapshot :: forall era. EraGov era => NewEpochState era -> EB.SnapShot (EraCrypto era)
currentSnapshot :: forall era.
EraGov era =>
NewEpochState era -> SnapShot (EraCrypto era)
currentSnapshot NewEpochState era
ss =
  forall era.
EraPParams era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> DState era
-> PState era
-> SnapShot (EraCrypto era)
incrementalStakeDistr PParams era
pp IncrementalStake (EraCrypto era)
incrementalStake DState era
dstate PState era
pstate
  where
    pp :: PParams era
pp = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    ledgerState :: LedgerState era
ledgerState = forall era. EpochState era -> LedgerState era
esLState forall a b. (a -> b) -> a -> b
$ forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    incrementalStake :: IncrementalStake (EraCrypto era)
incrementalStake = forall era. UTxOState era -> IncrementalStake (EraCrypto era)
utxosStakeDistr forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState
    dstate :: DState era
dstate = forall era. CertState era -> DState era
certDState forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ledgerState
    pstate :: PState era
pstate = forall era. CertState era -> PState era
certPState forall a b. (a -> b) -> a -> b
$ forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ledgerState

-- | Information about a stake pool
data RewardInfoPool = RewardInfoPool
  { RewardInfoPool -> Coin
stake :: Coin
  -- ^ Absolute stake delegated to this pool
  , RewardInfoPool -> Coin
ownerPledge :: Coin
  -- ^ Pledge of pool owner(s)
  , RewardInfoPool -> Coin
ownerStake :: Coin
  -- ^ Absolute stake delegated by pool owner(s)
  , RewardInfoPool -> Coin
cost :: Coin
  -- ^ Pool cost
  , RewardInfoPool -> UnitInterval
margin :: UnitInterval
  -- ^ Pool margin
  , RewardInfoPool -> Double
performanceEstimate :: Double
  -- ^ 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.)
  }
  deriving (RewardInfoPool -> RewardInfoPool -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardInfoPool -> RewardInfoPool -> Bool
$c/= :: RewardInfoPool -> RewardInfoPool -> Bool
== :: RewardInfoPool -> RewardInfoPool -> Bool
$c== :: RewardInfoPool -> RewardInfoPool -> Bool
Eq, Int -> RewardInfoPool -> ShowS
[RewardInfoPool] -> ShowS
RewardInfoPool -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardInfoPool] -> ShowS
$cshowList :: [RewardInfoPool] -> ShowS
show :: RewardInfoPool -> String
$cshow :: RewardInfoPool -> String
showsPrec :: Int -> RewardInfoPool -> ShowS
$cshowsPrec :: Int -> RewardInfoPool -> ShowS
Show, forall x. Rep RewardInfoPool x -> RewardInfoPool
forall x. RewardInfoPool -> Rep RewardInfoPool x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RewardInfoPool x -> RewardInfoPool
$cfrom :: forall x. RewardInfoPool -> Rep RewardInfoPool x
Generic)

instance NoThunks RewardInfoPool

instance NFData RewardInfoPool

deriving instance FromJSON RewardInfoPool

deriving instance ToJSON RewardInfoPool

-- | Global information that influences stake pool rewards
data RewardParams = RewardParams
  { RewardParams -> Natural
nOpt :: Natural
  -- ^ Desired number of stake pools
  , RewardParams -> NonNegativeInterval
a0 :: NonNegativeInterval
  -- ^ Influence of the pool owner's pledge on rewards
  , RewardParams -> Coin
rPot :: Coin
  -- ^ Total rewards available for the given epoch
  , RewardParams -> Coin
totalStake :: Coin
  -- ^ Maximum lovelace supply minus treasury
  }
  deriving (RewardParams -> RewardParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardParams -> RewardParams -> Bool
$c/= :: RewardParams -> RewardParams -> Bool
== :: RewardParams -> RewardParams -> Bool
$c== :: RewardParams -> RewardParams -> Bool
Eq, Int -> RewardParams -> ShowS
[RewardParams] -> ShowS
RewardParams -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardParams] -> ShowS
$cshowList :: [RewardParams] -> ShowS
show :: RewardParams -> String
$cshow :: RewardParams -> String
showsPrec :: Int -> RewardParams -> ShowS
$cshowsPrec :: Int -> RewardParams -> ShowS
Show, forall x. Rep RewardParams x -> RewardParams
forall x. RewardParams -> Rep RewardParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RewardParams x -> RewardParams
$cfrom :: forall x. RewardParams -> Rep RewardParams x
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.
--
-- 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 ::
  EraGov era =>
  Globals ->
  NewEpochState era ->
  (RewardParams, Map (KeyHash 'StakePool (EraCrypto era)) RewardInfoPool)
getRewardInfoPools :: forall era.
EraGov era =>
Globals
-> NewEpochState era
-> (RewardParams,
    Map (KeyHash 'StakePool (EraCrypto era)) RewardInfoPool)
getRewardInfoPools Globals
globals NewEpochState era
ss =
  (RewardParams
mkRewardParams, forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (forall (kv :: * -> *) k (vv :: * -> *) a b.
(Vector kv k, Vector vv a, Vector vv b) =>
(k -> a -> b) -> VMap kv vv k a -> VMap kv vv k b
VMap.mapWithKey KeyHash 'StakePool (EraCrypto era)
-> PoolParams (EraCrypto era) -> RewardInfoPool
mkRewardInfoPool VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams))
  where
    es :: EpochState era
es = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
ss
    pp :: PParams era
pp = EpochState era
es forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
    NonMyopic
      { likelihoodsNM :: forall c. NonMyopic c -> Map (KeyHash 'StakePool c) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
ls
      , rewardPotNM :: forall c. NonMyopic c -> Coin
rewardPotNM = Coin
rPot
      } = forall era. EpochState era -> NonMyopic (EraCrypto era)
esNonMyopic EpochState era
es
    histLookup :: KeyHash 'StakePool (EraCrypto era) -> Likelihood
histLookup KeyHash 'StakePool (EraCrypto era)
key = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty KeyHash 'StakePool (EraCrypto era)
key Map (KeyHash 'StakePool (EraCrypto era)) Likelihood
ls

    EB.SnapShot Stake (EraCrypto era)
stakes VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs VMap
  VB
  VB
  (KeyHash 'StakePool (EraCrypto era))
  (PoolParams (EraCrypto era))
poolParams = forall era.
EraGov era =>
NewEpochState era -> SnapShot (EraCrypto era)
currentSnapshot NewEpochState era
ss

    mkRewardParams :: RewardParams
mkRewardParams =
      RewardParams
        { a0 :: NonNegativeInterval
a0 = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
ppA0L
        , nOpt :: Natural
nOpt = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Natural
ppNOptL
        , totalStake :: Coin
totalStake = forall era. Globals -> NewEpochState era -> Coin
getTotalStake Globals
globals NewEpochState era
ss
        , rPot :: Coin
rPot = Coin
rPot
        }
    mkRewardInfoPool :: KeyHash 'StakePool (EraCrypto era)
-> PoolParams (EraCrypto era) -> RewardInfoPool
mkRewardInfoPool KeyHash 'StakePool (EraCrypto era)
key PoolParams (EraCrypto era)
poolp =
      RewardInfoPool
        { stake :: Coin
stake = Coin
pstake
        , ownerStake :: Coin
ownerStake = Coin
ostake
        , ownerPledge :: Coin
ownerPledge = forall c. PoolParams c -> Coin
ppPledge PoolParams (EraCrypto era)
poolp
        , margin :: UnitInterval
margin = forall c. PoolParams c -> UnitInterval
ppMargin PoolParams (EraCrypto era)
poolp
        , cost :: Coin
cost = forall c. PoolParams c -> Coin
ppCost PoolParams (EraCrypto era)
poolp
        , performanceEstimate :: Double
performanceEstimate =
            PerformanceEstimate -> Double
unPerformanceEstimate forall a b. (a -> b) -> a -> b
$ Likelihood -> PerformanceEstimate
percentile' forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool (EraCrypto era) -> Likelihood
histLookup KeyHash 'StakePool (EraCrypto era)
key
        }
      where
        pstake :: Coin
pstake = forall c. Stake c -> Coin
EB.sumAllStake forall a b. (a -> b) -> a -> b
$ forall c.
KeyHash 'StakePool c
-> VMap VB VB (Credential 'Staking c) (KeyHash 'StakePool c)
-> Stake c
-> Stake c
EB.poolStake KeyHash 'StakePool (EraCrypto era)
key VMap
  VB
  VB
  (Credential 'Staking (EraCrypto era))
  (KeyHash 'StakePool (EraCrypto era))
delegs Stake (EraCrypto era)
stakes
        ostake :: Coin
ostake = forall c. PoolParams c -> Stake c -> Coin
sumPoolOwnersStake PoolParams (EraCrypto era)
poolp Stake (EraCrypto era)
stakes

-- | 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 'getRewardInfoPools'.
--
-- TODO: Deprecate 'getRewardProvenance', because wallets are more
-- likely to use 'getRewardInfoPools' for up-to-date information
-- on stake pool rewards.
getRewardProvenance ::
  forall era.
  EraGov era =>
  Globals ->
  NewEpochState era ->
  (RewardUpdate (EraCrypto era), RewardProvenance (EraCrypto era))
getRewardProvenance :: forall era.
EraGov era =>
Globals
-> NewEpochState era
-> (RewardUpdate (EraCrypto era), RewardProvenance (EraCrypto era))
getRewardProvenance Globals
globals NewEpochState era
newepochstate =
  ( forall r a. Reader r a -> r -> a
runReader
      (forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> ShelleyBase (RewardUpdate (EraCrypto era))
createRUpd EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
blocksmade EpochState era
epochstate Coin
maxsupply ActiveSlotCoeff
asc Word64
secparam)
      Globals
globals
  , forall a. Default a => a
def
  )
  where
    epochstate :: EpochState era
epochstate = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
newepochstate
    maxsupply :: Coin
    maxsupply :: Coin
maxsupply = Integer -> Coin
Coin (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Globals -> Word64
maxLovelaceSupply Globals
globals))
    blocksmade :: BlocksMade (EraCrypto era)
    blocksmade :: BlocksMade (EraCrypto era)
blocksmade = forall era. NewEpochState era -> BlocksMade (EraCrypto era)
nesBprev NewEpochState era
newepochstate
    epochnumber :: EpochNo
epochnumber = forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
newepochstate
    slotsPerEpoch :: EpochSize
    slotsPerEpoch :: EpochSize
slotsPerEpoch = forall r a. Reader r a -> r -> a
runReader (HasCallStack =>
EpochInfo Identity -> EpochNo -> ShelleyBase EpochSize
epochInfoSize (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) EpochNo
epochnumber) Globals
globals
    asc :: ActiveSlotCoeff
asc = Globals -> ActiveSlotCoeff
activeSlotCoeff Globals
globals
    secparam :: Word64
secparam = Globals -> Word64
securityParameter Globals
globals

--------------------------------------------------------------------------------
-- Transaction helpers
--------------------------------------------------------------------------------

addKeyWitnesses :: EraTx era => Tx era -> Set (WitVKey 'Witness (EraCrypto era)) -> Tx era
addKeyWitnesses :: forall era.
EraTx era =>
Tx era -> Set (WitVKey 'Witness (EraCrypto era)) -> Tx era
addKeyWitnesses Tx era
tx Set (WitVKey 'Witness (EraCrypto era))
newWits = Tx era
tx forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (WitVKey 'Witness (EraCrypto era))
newWits

--------------------------------------------------------------------------------
-- CBOR instances
--------------------------------------------------------------------------------

instance EncCBOR RewardParams where
  encCBOR :: RewardParams -> Encoding
encCBOR (RewardParams Natural
p1 NonNegativeInterval
p2 Coin
p3 Coin
p4) =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Encode ('Closed 'Dense) t
Rec Natural -> NonNegativeInterval -> Coin -> Coin -> RewardParams
RewardParams
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Natural
p1
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To NonNegativeInterval
p2
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
p3
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
p4

instance DecCBOR RewardParams where
  decCBOR :: forall s. Decoder s RewardParams
decCBOR =
    forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Decode ('Closed 'Dense) t
RecD Natural -> NonNegativeInterval -> Coin -> Coin -> RewardParams
RewardParams
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance EncCBOR RewardInfoPool where
  encCBOR :: RewardInfoPool -> Encoding
encCBOR (RewardInfoPool Coin
p1 Coin
p2 Coin
p3 Coin
p4 UnitInterval
p5 Double
d6) =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Encode ('Closed 'Dense) t
Rec Coin
-> Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool
RewardInfoPool
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
p1
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
p2
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
p3
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Coin
p4
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To UnitInterval
p5
        forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
E Double -> Encoding
encodeDouble Double
d6

instance DecCBOR RewardInfoPool where
  decCBOR :: forall s. Decoder s RewardInfoPool
decCBOR =
    forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$
      forall t. t -> Decode ('Closed 'Dense) t
RecD Coin
-> Coin -> Coin -> Coin -> UnitInterval -> Double -> RewardInfoPool
RewardInfoPool
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall s. Decoder s Double
decodeDouble