/
RefundsAndDeposits.hs
121 lines (114 loc) · 4.22 KB
/
RefundsAndDeposits.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
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cardano.Ledger.Shelley.LedgerState.RefundsAndDeposits (
totalTxDeposits,
totalCertsDeposits,
totalCertsDepositsDPState,
keyTxRefunds,
keyCertsRefunds,
)
where
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.DPState (DPState (..), DState (..), PState (..))
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
import Cardano.Ledger.Shelley.Delegation.Certificates (DCert (..), isRegKey)
import Cardano.Ledger.Shelley.TxBody (
PoolParams (..),
ShelleyEraTxBody (..),
pattern DeRegKey,
pattern RegKey,
pattern RegPool,
)
import Cardano.Ledger.UMapCompact (
RDPair (..),
View (RewardDeposits),
compactCoinOrError,
fromCompact,
)
import qualified Cardano.Ledger.UMapCompact as UM
import Cardano.Ledger.Val ((<+>), (<×>))
import Data.Foldable (foldMap', foldl', toList)
import qualified Data.Map.Strict as Map
import Data.Monoid (Sum (..))
import qualified Data.Set as Set
import Lens.Micro ((^.))
-- | Determine the total deposit amount needed from a TxBody.
-- The block may (legitimately) contain multiple registration certificates
-- for the same pool, where the first will be treated as a registration and
-- any subsequent ones as re-registration. As such, we must only take a
-- deposit for the first such registration. It is even possible for a single
-- transaction to have multiple pool registration for the same pool, so as
-- we process pool registrations, we must keep track of those that are already
-- registered, so we do not add a Deposit for the same pool twice.
--
-- Note that this is not an issue for key registrations since subsequent
-- registration certificates would be invalid.
totalCertsDeposits ::
(EraPParams era, Foldable f) =>
PParams era ->
-- | Check whether a pool with a supplied PoolStakeId is already registered.
(KeyHash 'StakePool (EraCrypto era) -> Bool) ->
f (DCert (EraCrypto era)) ->
Coin
totalCertsDeposits pp isRegPool certs =
numKeys <×> pp ^. ppKeyDepositL
<+> numNewRegPoolCerts <×> pp ^. ppPoolDepositL
where
numKeys = getSum @Int $ foldMap' (\x -> if isRegKey x then 1 else 0) certs
numNewRegPoolCerts = Set.size (foldl' addNewPoolIds Set.empty certs)
addNewPoolIds regPoolIds = \case
DCertPool (RegPool (PoolParams {ppId}))
-- We don't pay a deposit on a pool that is already registered or duplicated in the certs
| not (isRegPool ppId || Set.member ppId regPoolIds) -> Set.insert ppId regPoolIds
_ -> regPoolIds
totalCertsDepositsDPState ::
(EraPParams era, Foldable f) =>
PParams era ->
DPState (EraCrypto era) ->
f (DCert (EraCrypto era)) ->
Coin
totalCertsDepositsDPState pp dpstate =
totalCertsDeposits pp (`Map.member` psStakePoolParams (dpsPState dpstate))
totalTxDeposits ::
ShelleyEraTxBody era =>
PParams era ->
DPState (EraCrypto era) ->
TxBody era ->
Coin
totalTxDeposits pp dpstate txb =
totalCertsDepositsDPState pp dpstate (txb ^. certsTxBodyG)
-- | Compute the key deregistration refunds in a transaction
keyCertsRefunds ::
EraPParams era =>
PParams era ->
DPState c ->
[DCert c] ->
Coin
keyCertsRefunds pp dpstate certs = snd (foldl' accum (initialKeys, Coin 0) certs)
where
initialKeys = (RewardDeposits . dsUnified . dpsDState) dpstate
keyDeposit = compactCoinOrError (pp ^. ppKeyDepositL)
accum (!keys, !ans) (DCertDeleg (RegKey k)) =
-- Deposit is added locally to the growing 'keys'
(RewardDeposits $ UM.insert k (RDPair mempty keyDeposit) keys, ans)
accum (!keys, !ans) (DCertDeleg (DeRegKey k)) =
-- If the key is registered, lookup the deposit in the locally growing 'keys'
-- if it is not registered, then just return ans
case UM.lookup k keys of
Just (RDPair _ deposit) -> (keys, ans <+> fromCompact deposit)
Nothing -> (keys, ans)
accum ans _ = ans
keyTxRefunds ::
ShelleyEraTxBody era =>
PParams era ->
DPState (EraCrypto era) ->
TxBody era ->
Coin
keyTxRefunds pp dpstate tx = keyCertsRefunds pp dpstate (toList $ tx ^. certsTxBodyG)