Skip to content

Commit b3f8866

Browse files
lehinslehins
authored
Merge pull request #3342 from input-output-hk/lehins/improve-evaluateTransactionBalance
Improve evaluate transaction balance
2 parents e33290b + 8661576 commit b3f8866

File tree

23 files changed

+423
-120
lines changed

23 files changed

+423
-120
lines changed

‎eras/mary/impl/src/Cardano/Ledger/Mary/UTxO.hs

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -6,13 +6,14 @@
66

77
module Cardano.Ledger.Mary.UTxO (getConsumedMaryValue) where
88

9-
import Cardano.Ledger.Core
9+
import Cardano.Ledger.Coin (Coin)
10+
import Cardano.Ledger.Credential (StakeCredential)
1011
import Cardano.Ledger.Crypto
12+
import Cardano.Ledger.Mary.Core
1113
import Cardano.Ledger.Mary.Era (MaryEra)
12-
import Cardano.Ledger.Mary.TxBody (MaryEraTxBody (..))
14+
import Cardano.Ledger.Mary.TxBody ()
1315
import Cardano.Ledger.Mary.Value (MaryValue)
14-
import Cardano.Ledger.Shelley.LedgerState (DPState, keyTxRefunds)
15-
import Cardano.Ledger.Shelley.TxBody (Withdrawals (..))
16+
import Cardano.Ledger.Shelley.LedgerState (keyCertsRefunds)
1617
import Cardano.Ledger.Shelley.UTxO (
1718
ShelleyScriptsNeeded (..),
1819
getShelleyScriptsNeeded,
@@ -49,17 +50,17 @@ instance Crypto c => EraUTxO (MaryEra c) where
4950
getConsumedMaryValue ::
5051
(MaryEraTxBody era, Value era ~ MaryValue (EraCrypto era)) =>
5152
PParams era ->
52-
DPState (EraCrypto era) ->
53+
(StakeCredential (EraCrypto era) -> Maybe Coin) ->
5354
UTxO era ->
5455
TxBody era ->
5556
MaryValue (EraCrypto era)
56-
getConsumedMaryValue pp dpstate (UTxO u) txBody = consumedValue <> txBody ^. mintValueTxBodyF
57+
getConsumedMaryValue pp lookupRefund (UTxO u) txBody = consumedValue <> txBody ^. mintValueTxBodyF
5758
where
5859
{- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds pp tx -}
5960
consumedValue =
6061
balance (UTxO (Map.restrictKeys u (txBody ^. inputsTxBodyL)))
6162
<> inject (refunds <> withdrawals)
62-
refunds = keyTxRefunds pp dpstate txBody
63+
refunds = keyCertsRefunds pp lookupRefund (txBody ^. certsTxBodyG)
6364
withdrawals = fold . unWithdrawals $ txBody ^. withdrawalsTxBodyL
6465

6566
-- | Computes the set of script hashes required to unlock the transaction inputs and the

‎eras/shelley/impl/CHANGELOG.md

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,11 @@
2828
* `Likelihood` and `NonMyopic`
2929
* `RewardUpdate` and `PulsingRewUpdate`
3030
* Added of `ToJSON`/`FromJSON` instances for `LogWeight`
31+
* Change `totalCertsDeposits` to accept a function that checks for registered pools,
32+
rather than the `DPState`. Use `totalCertsDepositsDPState` for the previous behavior
33+
* Added `getProducedValue` and `totalCertsDepositsDPState`.
34+
* Deprecate `evaluateTransactionBalance`
35+
* Change types in `StakePoolRetirementWrongEpochPOOL` from `Word64` to `EpochNo`
3136

3237
### `testlib`
3338

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

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -97,6 +97,7 @@ import Cardano.Ledger.Shelley.LedgerState (
9797
RewardUpdate,
9898
UTxOState (..),
9999
circulation,
100+
consumed,
100101
createRUpd,
101102
incrementalStakeDistr,
102103
produced,
@@ -510,7 +511,8 @@ evaluateTransactionBalance ::
510511
-- | The difference between what the transaction consumes and what it produces.
511512
Value era
512513
evaluateTransactionBalance pp dpstate u txb =
513-
getConsumedValue pp dpstate u txb <-> produced pp dpstate txb
514+
consumed pp dpstate u txb <-> produced pp dpstate txb
515+
{-# DEPRECATED evaluateTransactionBalance "In favor of new API function `Cardano.Ledger.Api.Tx.Body.evalBalanceTxBody`" #-}
514516

515517
--------------------------------------------------------------------------------
516518
-- Shelley specifics

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs

Lines changed: 38 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -76,8 +76,9 @@ totalAdaPotsES (EpochState (AccountState treasury_ reserves_) _ ls _ _ _) =
7676
DPState dstate _ = lsDPState ls
7777
rewards_ = fromCompact $ sumRewardsView (rewards dstate)
7878
coins = coinBalance u
79-
keyDeposits_ = (fromCompact . sumDepositView . RewardDeposits . dsUnified . dpsDState . lsDPState) ls
80-
poolDeposits_ = fold ((psDeposits . dpsPState . lsDPState) ls)
79+
keyDeposits_ =
80+
fromCompact . sumDepositView . RewardDeposits . dsUnified . dpsDState $ lsDPState ls
81+
poolDeposits_ = fold (psDeposits . dpsPState $ lsDPState ls)
8182

8283
-- | Calculate the total ada in the epoch state
8384
totalAdaES :: EraTxOut era => EpochState era -> Coin
@@ -94,10 +95,10 @@ totalAdaES cs =
9495
, reservesAdaPot
9596
, rewardsAdaPot
9697
, utxoAdaPot
97-
, -- keyDepositAdaPot, -- We don't count these two, as their
98-
-- poolDepositAdaPot, -- sum is always depositsAdaPot
99-
depositsAdaPot
98+
, depositsAdaPot
10099
, feesAdaPot
100+
-- , keyDepositAdaPot -- We don't count these two, as their
101+
-- , poolDepositAdaPot -- sum is always depositsAdaPot
101102
} = totalAdaPotsES cs
102103

103104
-- =============================================
@@ -110,15 +111,32 @@ data Consumed = Consumed
110111

111112
instance Show Consumed where
112113
show (Consumed (Coin i) (Coin r) (Coin w)) =
113-
"Consumed(Inputs " ++ show i ++ ", Refunds " ++ show r ++ ", Withdrawals " ++ show w ++ ") = " ++ show (i + r + w)
114+
"Consumed(Inputs "
115+
++ show i
116+
++ ", Refunds "
117+
++ show r
118+
++ ", Withdrawals "
119+
++ show w
120+
++ ") = "
121+
++ show (i + r + w)
114122

115123
-- | Itemizing what is Produced by a transaction
116124
data Produced = Produced
117-
{proOutputs :: !Coin, proFees :: !Coin, proDeposits :: !Coin}
125+
{ proOutputs :: !Coin
126+
, proFees :: !Coin
127+
, proDeposits :: !Coin
128+
}
118129

119130
instance Show Produced where
120131
show (Produced (Coin out) (Coin f) (Coin d)) =
121-
"Produced(Outputs " ++ show out ++ ", Fees " ++ show f ++ ", Deposits " ++ show d ++ ") = " ++ show (out + f + d)
132+
"Produced(Outputs "
133+
++ show out
134+
++ ", Fees "
135+
++ show f
136+
++ ", Deposits "
137+
++ show d
138+
++ ") = "
139+
++ show (out + f + d)
122140

123141
-- =========================
124142

@@ -130,11 +148,12 @@ consumedTxBody ::
130148
DPState (EraCrypto era) ->
131149
UTxO era ->
132150
Consumed
133-
consumedTxBody txBody pp dpstate (UTxO u) = Consumed {conInputs = i, conRefunds = r, conWithdrawals = w}
134-
where
135-
i = coinBalance (UTxO (Map.restrictKeys u (txBody ^. inputsTxBodyL)))
136-
r = keyTxRefunds pp dpstate txBody
137-
w = fold . unWithdrawals $ txBody ^. withdrawalsTxBodyL
151+
consumedTxBody txBody pp dpstate (UTxO u) =
152+
Consumed
153+
{ conInputs = coinBalance (UTxO (Map.restrictKeys u (txBody ^. inputsTxBodyL)))
154+
, conRefunds = keyTxRefunds pp dpstate txBody
155+
, conWithdrawals = fold . unWithdrawals $ txBody ^. withdrawalsTxBodyL
156+
}
138157

139158
-- | Compute the Coin part of what is produced by a TxBody, itemized as a 'Produced'
140159
producedTxBody ::
@@ -143,8 +162,9 @@ producedTxBody ::
143162
PParams era ->
144163
DPState (EraCrypto era) ->
145164
Produced
146-
producedTxBody txBody pp dpstate = Produced {proOutputs = out, proFees = f, proDeposits = d}
147-
where
148-
out = coinBalance (txouts txBody)
149-
f = txBody ^. feeTxBodyL
150-
d = totalTxDeposits pp dpstate txBody
165+
producedTxBody txBody pp dpstate =
166+
Produced
167+
{ proOutputs = coinBalance (txouts txBody)
168+
, proFees = txBody ^. feeTxBodyL
169+
, proDeposits = totalTxDeposits pp dpstate txBody
170+
}

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/Internal.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,4 +65,5 @@ compareAdaPots xlabel x ylabel y =
6565
]
6666
where
6767
n = 25
68-
oneline name f = pad n name ++ pad n (show (f x)) ++ pad n (show (f y)) ++ pad n (show (f y <-> f x))
68+
oneline name f =
69+
pad n name ++ pad n (show (f x)) ++ pad n (show (f y)) ++ pad n (show (f y <-> f x))

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ module Cardano.Ledger.Shelley.LedgerState (
4747
nullWitHashes,
4848
diffWitHashes,
4949
minfee,
50+
consumed,
5051
produced,
5152
witsFromTxWitnesses,
5253

@@ -57,7 +58,9 @@ module Cardano.Ledger.Shelley.LedgerState (
5758
totalTxDeposits,
5859
obligationDPState,
5960
keyCertsRefunds,
61+
keyCertsRefundsDPState,
6062
totalCertsDeposits,
63+
totalCertsDepositsDPState,
6164

6265
-- * Epoch boundary
6366
incrementalStakeDistr,
@@ -107,7 +110,7 @@ import Cardano.Ledger.Shelley.PParams (
107110
import Cardano.Ledger.Shelley.RewardUpdate
108111
import Cardano.Ledger.Shelley.Rules.Ppup (PPUPPredFailure, ShelleyPPUPState (..))
109112
import Cardano.Ledger.Shelley.Tx (minfee, witsFromTxWitnesses)
110-
import Cardano.Ledger.Shelley.UTxO (produced)
113+
import Cardano.Ledger.Shelley.UTxO (consumed, produced)
111114
import Data.Default.Class (def)
112115
import Data.Set (Set)
113116
import qualified Data.Set as Set

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs

Lines changed: 67 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,27 @@
11
{-# LANGUAGE BangPatterns #-}
22
{-# LANGUAGE DataKinds #-}
33
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE NamedFieldPuns #-}
46
{-# LANGUAGE PatternSynonyms #-}
57
{-# LANGUAGE ScopedTypeVariables #-}
68
{-# LANGUAGE TypeApplications #-}
79

810
module Cardano.Ledger.Shelley.LedgerState.RefundsAndDeposits (
911
totalTxDeposits,
1012
totalCertsDeposits,
13+
totalCertsDepositsDPState,
1114
keyTxRefunds,
1215
keyCertsRefunds,
16+
keyCertsRefundsDPState,
1317
)
1418
where
1519

1620
import Cardano.Ledger.Coin (Coin (..))
1721
import Cardano.Ledger.Core
18-
import Cardano.Ledger.DPState (DPState (..), DState (..), PState (..))
22+
import Cardano.Ledger.Credential (StakeCredential)
23+
import Cardano.Ledger.DPState (DPState (..), PState (..), lookupDepositDState)
24+
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
1925
import Cardano.Ledger.Shelley.Delegation.Certificates (DCert (..), isRegKey)
2026
import Cardano.Ledger.Shelley.TxBody (
2127
PoolParams (..),
@@ -24,16 +30,11 @@ import Cardano.Ledger.Shelley.TxBody (
2430
pattern RegKey,
2531
pattern RegPool,
2632
)
27-
import Cardano.Ledger.UMapCompact (
28-
RDPair (..),
29-
View (RewardDeposits),
30-
compactCoinOrError,
31-
fromCompact,
32-
)
33-
import qualified Cardano.Ledger.UMapCompact as UM
3433
import Cardano.Ledger.Val ((<+>), (<×>))
35-
import Data.Foldable (foldl', toList)
34+
import Data.Foldable (foldMap', foldl')
3635
import qualified Data.Map.Strict as Map
36+
import Data.Monoid (Sum (..))
37+
import qualified Data.Set as Set
3738
import Lens.Micro ((^.))
3839

3940
-- | Determine the total deposit amount needed from a TxBody.
@@ -48,57 +49,84 @@ import Lens.Micro ((^.))
4849
-- Note that this is not an issue for key registrations since subsequent
4950
-- registration certificates would be invalid.
5051
totalCertsDeposits ::
51-
EraPParams era =>
52+
(EraPParams era, Foldable f) =>
5253
PParams era ->
53-
DPState c ->
54-
[DCert c] ->
54+
-- | Check whether a pool with a supplied PoolStakeId is already registered.
55+
(KeyHash 'StakePool (EraCrypto era) -> Bool) ->
56+
f (DCert (EraCrypto era)) ->
5557
Coin
56-
totalCertsDeposits pp dpstate certs =
58+
totalCertsDeposits pp isRegPool certs =
5759
numKeys <×> pp ^. ppKeyDepositL
58-
<+> snd (foldl' accum (regpools, Coin 0) certs)
60+
<+> numNewRegPoolCerts <×> pp ^. ppPoolDepositL
5961
where
60-
numKeys = length $ filter isRegKey certs
61-
regpools = psStakePoolParams (dpsPState dpstate)
62-
accum (!pools, !ans) (DCertPool (RegPool poolparam)) =
63-
if Map.member (ppId poolparam) pools -- We don't pay a deposit on a pool that is already registered
64-
then (pools, ans)
65-
else (Map.insert (ppId poolparam) poolparam pools, ans <+> pp ^. ppPoolDepositL)
66-
accum ans _ = ans
62+
numKeys = getSum @Int $ foldMap' (\x -> if isRegKey x then 1 else 0) certs
63+
numNewRegPoolCerts = Set.size (foldl' addNewPoolIds Set.empty certs)
64+
addNewPoolIds regPoolIds = \case
65+
DCertPool (RegPool (PoolParams {ppId}))
66+
-- We don't pay a deposit on a pool that is already registered or duplicated in the certs
67+
| not (isRegPool ppId || Set.member ppId regPoolIds) -> Set.insert ppId regPoolIds
68+
_ -> regPoolIds
69+
70+
totalCertsDepositsDPState ::
71+
(EraPParams era, Foldable f) =>
72+
PParams era ->
73+
DPState (EraCrypto era) ->
74+
f (DCert (EraCrypto era)) ->
75+
Coin
76+
totalCertsDepositsDPState pp dpstate =
77+
totalCertsDeposits pp (`Map.member` psStakePoolParams (dpsPState dpstate))
6778

79+
-- | Calculates the total amount of deposits needed for all pool registration and
80+
-- stake delegation certificates to be valid.
6881
totalTxDeposits ::
6982
ShelleyEraTxBody era =>
7083
PParams era ->
7184
DPState (EraCrypto era) ->
7285
TxBody era ->
7386
Coin
74-
totalTxDeposits pp dpstate txb = totalCertsDeposits pp dpstate (toList $ txb ^. certsTxBodyG)
87+
totalTxDeposits pp dpstate txb =
88+
totalCertsDepositsDPState pp dpstate (txb ^. certsTxBodyG)
89+
90+
-- | Compute the key deregistration refunds in a transaction
91+
keyCertsRefundsDPState ::
92+
(EraPParams era, Foldable f) =>
93+
PParams era ->
94+
DPState (EraCrypto era) ->
95+
f (DCert (EraCrypto era)) ->
96+
Coin
97+
keyCertsRefundsDPState pp dpstate = keyCertsRefunds pp (lookupDepositDState (dpsDState dpstate))
7598

7699
-- | Compute the key deregistration refunds in a transaction
77100
keyCertsRefunds ::
78-
EraPParams era =>
101+
(EraPParams era, Foldable f) =>
79102
PParams era ->
80-
DPState c ->
81-
[DCert c] ->
103+
-- | Function that can lookup current deposit, in case when the stake key is registered.
104+
(StakeCredential (EraCrypto era) -> Maybe Coin) ->
105+
f (DCert (EraCrypto era)) ->
82106
Coin
83-
keyCertsRefunds pp dpstate certs = snd (foldl' accum (initialKeys, Coin 0) certs)
107+
keyCertsRefunds pp lookupDeposit certs = snd (foldl' accum (mempty, Coin 0) certs)
84108
where
85-
initialKeys = (RewardDeposits . dsUnified . dpsDState) dpstate
86-
keyDeposit = compactCoinOrError (pp ^. ppKeyDepositL)
87-
accum (!keys, !ans) (DCertDeleg (RegKey k)) =
88-
-- Deposit is added locally to the growing 'keys'
89-
(RewardDeposits $ UM.insert k (RDPair mempty keyDeposit) keys, ans)
90-
accum (!keys, !ans) (DCertDeleg (DeRegKey k)) =
91-
-- If the key is registered, lookup the deposit in the locally growing 'keys'
92-
-- if it is not registered, then just return ans
93-
case UM.lookup k keys of
94-
Just (RDPair _ deposit) -> (keys, ans <+> fromCompact deposit)
95-
Nothing -> (keys, ans)
96-
accum ans _ = ans
109+
keyDeposit = pp ^. ppKeyDepositL
110+
accum (!regKeys, !totalRefunds) = \case
111+
DCertDeleg (RegKey k) ->
112+
-- Need to track new delegations in case that the same key is later deregistered in
113+
-- the same transaction.
114+
(Set.insert k regKeys, totalRefunds)
115+
DCertDeleg (DeRegKey k)
116+
-- We first check if there was already a registration certificate in this
117+
-- transaction.
118+
| Set.member k regKeys -> (Set.delete k regKeys, totalRefunds <+> keyDeposit)
119+
-- Check for the deposit left during registration in some previous
120+
-- transaction. This de-registration check will be matched first, despite being
121+
-- the last case to match, because registration is not possible without
122+
-- de-registration.
123+
| Just deposit <- lookupDeposit k -> (regKeys, totalRefunds <+> deposit)
124+
_ -> (regKeys, totalRefunds)
97125

98126
keyTxRefunds ::
99127
ShelleyEraTxBody era =>
100128
PParams era ->
101129
DPState (EraCrypto era) ->
102130
TxBody era ->
103131
Coin
104-
keyTxRefunds pp dpstate tx = keyCertsRefunds pp dpstate (toList $ tx ^. certsTxBodyG)
132+
keyTxRefunds pp dpstate tx = keyCertsRefundsDPState pp dpstate (tx ^. certsTxBodyG)

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,6 @@ module Cardano.Ledger.Shelley.Rules.Epoch (
2121
) where
2222

2323
import Cardano.Ledger.BaseTypes (ShelleyBase)
24-
import Cardano.Ledger.Coin (Coin (..))
2524
import Cardano.Ledger.EpochBoundary (SnapShots)
2625
import Cardano.Ledger.Shelley.Core
2726
import Cardano.Ledger.Shelley.Era (ShelleyEPOCH)
@@ -209,10 +208,10 @@ epochTransition = do
209208
-- kept (dsUnified of DState and psDeposits of PState) are adjusted by
210209
-- the rules, So we can recompute the utxosDeposited field using adjustedDPState
211210
-- since we have the invariant that: obligationDPState dpstate == utxosDeposited utxostate
212-
Coin oblgNew = obligationDPState adjustedDPstate
213-
Coin reserves = asReserves acnt'
214-
utxoSt''' = utxoSt'' {utxosDeposited = Coin oblgNew}
215-
acnt'' = acnt' {asReserves = Coin reserves}
211+
oblgNew = obligationDPState adjustedDPstate
212+
reserves = asReserves acnt'
213+
utxoSt''' = utxoSt'' {utxosDeposited = oblgNew}
214+
acnt'' = acnt' {asReserves = reserves}
216215
pure $
217216
epochState'
218217
{ esAccountState = acnt''

0 commit comments

Comments
 (0)