/
UTxO.hs
177 lines (161 loc) · 5.7 KB
/
UTxO.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
173
174
175
176
177
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Ledger.Shelley.UTxO (
ShelleyScriptsNeeded (..),
scriptsNeeded,
getShelleyScriptsNeeded,
scriptCred,
scriptStakeCred,
getConsumedCoin,
produced,
txup,
module UTxO,
)
where
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.BaseTypes (strictMaybeToMaybe)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.DPState (DPState (..), PState (..))
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
import Cardano.Ledger.Shelley.Delegation.Certificates (
DCert (..),
requiresVKeyWitness,
)
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.LedgerState.RefundsAndDeposits (
keyTxRefunds,
totalCertsDeposits,
)
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.TxBody (
ShelleyEraTxBody (..),
Withdrawals (..),
getRwdCred,
pattern DeRegKey,
pattern Delegate,
pattern Delegation,
)
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.UTxO as UTxO
import Cardano.Ledger.Val ((<+>))
import qualified Cardano.Ledger.Val as Val
import Data.Foldable (Foldable (fold), toList)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Lens.Micro ((^.))
txup :: (EraTx era, ShelleyEraTxBody era, ProtVerAtMost era 8) => Tx era -> Maybe (Update era)
txup tx = strictMaybeToMaybe (tx ^. bodyTxL . updateTxBodyL)
scriptStakeCred :: DCert c -> Maybe (ScriptHash c)
scriptStakeCred (DCertDeleg (DeRegKey (KeyHashObj _))) = Nothing
scriptStakeCred (DCertDeleg (DeRegKey (ScriptHashObj hs))) = Just hs
scriptStakeCred (DCertDeleg (Delegate (Delegation (KeyHashObj _) _))) = Nothing
scriptStakeCred (DCertDeleg (Delegate (Delegation (ScriptHashObj hs) _))) = Just hs
scriptStakeCred _ = Nothing
scriptCred :: Credential kr c -> Maybe (ScriptHash c)
scriptCred (KeyHashObj _) = Nothing
scriptCred (ScriptHashObj hs) = Just hs
-- | Computes the set of script hashes required to unlock the transaction inputs
-- and the withdrawals.
scriptsNeeded ::
forall era.
(EraTx era, ShelleyEraTxBody era) =>
UTxO era ->
Tx era ->
Set.Set (ScriptHash (EraCrypto era))
scriptsNeeded u tx =
case getShelleyScriptsNeeded u (tx ^. bodyTxL) of
ShelleyScriptsNeeded sn -> sn
{-# DEPRECATED scriptsNeeded "In favor of `getScriptsNeeded`" #-}
-- | Compute the subset of inputs of the set 'txInps' for which each input is
-- locked by a script in the UTxO 'u'.
txinsScriptHashes ::
EraTxOut era =>
Set.Set (TxIn (EraCrypto era)) ->
UTxO era ->
Set.Set (ScriptHash (EraCrypto era))
txinsScriptHashes txInps (UTxO u) = foldr add Set.empty txInps
where
-- to get subset, start with empty, and only insert those inputs in txInps
-- that are locked in u
add input ans = case Map.lookup input u of
Just txOut -> case txOut ^. addrTxOutL of
Addr _ (ScriptHashObj h) _ -> Set.insert h ans
_ -> ans
Nothing -> ans
getShelleyScriptsNeeded ::
ShelleyEraTxBody era =>
UTxO era ->
TxBody era ->
ShelleyScriptsNeeded era
getShelleyScriptsNeeded u txBody =
ShelleyScriptsNeeded
( scriptHashes
`Set.union` Set.fromList
[sh | w <- withdrawals, Just sh <- [scriptCred (getRwdCred w)]]
`Set.union` Set.fromList
[sh | c <- certificates, requiresVKeyWitness c, Just sh <- [scriptStakeCred c]]
)
where
withdrawals = Map.keys (unWithdrawals (txBody ^. withdrawalsTxBodyL))
scriptHashes = txinsScriptHashes (txBody ^. inputsTxBodyL) u
certificates = toList (txBody ^. certsTxBodyG)
-- | Compute the lovelace which are created by the transaction
produced ::
ShelleyEraTxBody era =>
PParams era ->
DPState (EraCrypto era) ->
TxBody era ->
Value era
produced pp dpstate =
getProducedValue pp (`Map.member` psStakePoolParams (dpsPState dpstate))
getProducedValue ::
ShelleyEraTxBody era =>
PParams era ->
-- | Check whether a pool with a supplied PoolStakeId is already registered.
(KeyHash 'StakePool (EraCrypto era) -> Bool) ->
TxBody era ->
Value era
getProducedValue pp isRegPoolId txBody =
sumAllValue (txBody ^. outputsTxBodyL)
<+> Val.inject
(txBody ^. feeTxBodyL <+> totalCertsDeposits pp isRegPoolId (txBody ^. certsTxBodyG))
-- | Compute the lovelace which are destroyed by the transaction
getConsumedCoin ::
ShelleyEraTxBody era =>
PParams era ->
DPState (EraCrypto era) ->
UTxO era ->
TxBody era ->
Coin
getConsumedCoin pp dpstate (UTxO u) txBody =
{- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds dpstate tx -}
coinBalance (UTxO (Map.restrictKeys u (txBody ^. inputsTxBodyL)))
<> refunds
<> withdrawals
where
refunds = keyTxRefunds pp dpstate txBody
withdrawals = fold . unWithdrawals $ txBody ^. withdrawalsTxBodyL
newtype ShelleyScriptsNeeded era = ShelleyScriptsNeeded (Set.Set (ScriptHash (EraCrypto era)))
deriving (Eq, Show)
instance Crypto c => EraUTxO (ShelleyEra c) where
type ScriptsNeeded (ShelleyEra c) = ShelleyScriptsNeeded (ShelleyEra c)
getConsumedValue = getConsumedCoin
getScriptsNeeded = getShelleyScriptsNeeded
getScriptsHashesNeeded (ShelleyScriptsNeeded scriptsHashes) = scriptsHashes