-
Notifications
You must be signed in to change notification settings - Fork 155
/
Wallet.hs
172 lines (165 loc) · 5.91 KB
/
Wallet.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
{-# LANGUAGE DataKinds #-}
module Shelley.Spec.Ledger.API.Wallet
( getNonMyopicMemberRewards,
getUTxO,
getFilteredUTxO,
getLeaderSchedule,
getTotalStake,
)
where
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.Crypto (VRF)
import Cardano.Ledger.Era (Crypto, Era)
import qualified Cardano.Ledger.Val as Val
import Cardano.Slotting.EpochInfo (epochInfoRange)
import Cardano.Slotting.Slot (SlotNo)
import qualified Data.ByteString.Short as BSS
import Data.Foldable (fold)
import Data.Functor.Identity (runIdentity)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import Data.Set (Set)
import qualified Data.Set as Set
import Shelley.Spec.Ledger.API.Protocol (ChainDepState (..))
import Shelley.Spec.Ledger.API.Validation (ShelleyState)
import Shelley.Spec.Ledger.Address (Addr (..), serialiseAddr)
import Shelley.Spec.Ledger.BaseTypes (Globals (..), Seed)
import Shelley.Spec.Ledger.BlockChain (checkLeaderValue, mkSeed, seedL)
import Shelley.Spec.Ledger.Coin (Coin (..))
import Shelley.Spec.Ledger.Credential (Credential (..))
import Shelley.Spec.Ledger.Delegation.Certificates (IndividualPoolStake (..), unPoolDistr)
import qualified Shelley.Spec.Ledger.EpochBoundary as EB
import Shelley.Spec.Ledger.Keys (KeyHash, KeyRole (..), SignKeyVRF)
import Shelley.Spec.Ledger.LedgerState
( AccountState (..),
DPState (..),
EpochState (..),
LedgerState (..),
NewEpochState (..),
UTxOState (..),
stakeDistr,
)
import Shelley.Spec.Ledger.OverlaySchedule (isOverlaySlot)
import Shelley.Spec.Ledger.PParams (PParams, PParams' (..))
import Shelley.Spec.Ledger.Rewards
( NonMyopic (..),
StakeShare (..),
getTopRankedPools,
nonMyopicMemberRew,
nonMyopicStake,
percentile',
)
import Shelley.Spec.Ledger.STS.Tickn (TicknState (..))
import Shelley.Spec.Ledger.TxBody (PoolParams (..), TxOut (..))
import Shelley.Spec.Ledger.UTxO (UTxO (..))
-- | Calculate the current total stake.
getTotalStake :: Globals -> ShelleyState era -> Coin
getTotalStake globals ss =
let supply = Coin . fromIntegral $ maxLovelaceSupply globals
EpochState acnt _ _ _ _ _ = nesEs ss
in supply Val.~~ (_reserves acnt)
-- | 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.
getNonMyopicMemberRewards ::
Era era =>
Globals ->
ShelleyState era ->
Set (Either Coin (Credential 'Staking era)) ->
Map (Either Coin (Credential 'Staking era)) (Map (KeyHash 'StakePool era) Coin)
getNonMyopicMemberRewards globals ss creds =
Map.fromList $
fmap
(\cred -> (cred, Map.mapWithKey (mkNMMRewards $ memShare cred) poolData))
(Set.toList creds)
where
total = fromIntegral $ maxLovelaceSupply globals
toShare (Coin x) = StakeShare (x % total)
memShare (Right cred) = toShare $ Map.findWithDefault (Coin 0) cred (EB.unStake stake)
memShare (Left coin) = toShare coin
es = nesEs ss
pp = esPp es
NonMyopic
{ likelihoodsNM = ls,
rewardPotNM = rPot
} = esNonMyopic es
utxo = _utxo . _utxoState . esLState $ es
dstate = _dstate . _delegationState . esLState $ es
pstate = _pstate . _delegationState . esLState $ es
EB.SnapShot stake delegs poolParams = stakeDistr utxo dstate pstate
poolData =
Map.mapWithKey
(\k p -> (percentile' (histLookup k), p, toShare . fold . EB.unStake $ EB.poolStake k delegs stake))
poolParams
histLookup k = fromMaybe mempty (Map.lookup k ls)
topPools = getTopRankedPools rPot (Coin total) pp poolParams (fmap percentile' ls)
mkNMMRewards ms k (ap, poolp, sigma) =
if checkPledge poolp
then nonMyopicMemberRew pp poolp rPot s ms nmps ap
else mempty
where
s = (toShare . _poolPledge) poolp
nmps = nonMyopicStake k sigma s pp topPools
checkPledge pool =
let ostake =
Set.foldl'
( \c o ->
c
<> ( fromMaybe mempty $
Map.lookup (KeyHashObj o) (EB.unStake stake)
)
)
mempty
(_poolOwners pool)
in _poolPledge poolp <= ostake
-- | Get the full UTxO.
getUTxO ::
ShelleyState era ->
UTxO era
getUTxO = _utxo . _utxoState . esLState . nesEs
-- | Get the UTxO filtered by address.
getFilteredUTxO ::
ShelleyState era ->
Set (Addr era) ->
UTxO era
getFilteredUTxO ss addrs =
UTxO $ Map.filter (\(TxOutCompact addrSBS _) -> addrSBS `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 (BSS.toShort . serialiseAddr) addrs
-- | 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 ->
ShelleyState era ->
ChainDepState era ->
KeyHash 'StakePool era ->
SignKeyVRF 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