/
Utxos.hs
253 lines (235 loc) · 8.51 KB
/
Utxos.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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Ledger.Babbage.Rules.Utxos (
BabbageUTXOS,
utxosTransition,
) where
import Cardano.Ledger.Alonzo.Language (Language (..))
import Cardano.Ledger.Alonzo.PlutusScriptApi (
collectTwoPhaseScriptInputs,
evalScripts,
)
import Cardano.Ledger.Alonzo.Rules (
AlonzoUtxosEvent (..),
AlonzoUtxosPredFailure (..),
TagMismatchDescription (..),
invalidBegin,
invalidEnd,
scriptFailuresToPlutusDebug,
scriptFailuresToPredicateFailure,
validBegin,
validEnd,
when2Phase,
)
import Cardano.Ledger.Alonzo.Scripts (AlonzoScript)
import Cardano.Ledger.Alonzo.TxInfo (EraPlutusContext, ExtendedUTxO, ScriptResult (Fails, Passes))
import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded)
import Cardano.Ledger.Babbage.Collateral (collAdaBalance, collOuts)
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Era (BabbageUTXOS)
import Cardano.Ledger.Babbage.Tx
import Cardano.Ledger.BaseTypes (ShelleyBase, epochInfo, strictMaybeToMaybe, systemStart)
import Cardano.Ledger.Binary (EncCBOR (..))
import Cardano.Ledger.SafeHash (hashAnnotated)
import Cardano.Ledger.Shelley.LedgerState (
PPUPPredFailure,
UTxOState (..),
keyTxRefunds,
totalTxDeposits,
updateStakeDistribution,
)
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules (
PpupEnv (..),
ShelleyPPUP,
ShelleyPpupPredFailure,
UtxoEnv (..),
updateUTxOState,
)
import Cardano.Ledger.Shelley.TxCert (ShelleyTxCert)
import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..))
import Cardano.Ledger.Val ((<->))
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.MapExtras (extractKeys)
import Debug.Trace (traceEvent)
import Lens.Micro
-- =====================================================
instance
forall era.
( AlonzoEraTx era
, AlonzoEraPParams era
, BabbageEraTxBody era
, ExtendedUTxO era
, EraUTxO era
, EraPlutusContext 'PlutusV1 era
, ScriptsNeeded era ~ AlonzoScriptsNeeded era
, Tx era ~ AlonzoTx era
, TxCert era ~ ShelleyTxCert era
, Script era ~ AlonzoScript era
, EraGovernance era
, GovernanceState era ~ ShelleyPPUPState era
, Embed (EraRule "PPUP" era) (BabbageUTXOS era)
, Environment (EraRule "PPUP" era) ~ PpupEnv era
, Signal (EraRule "PPUP" era) ~ Maybe (Update era)
, State (EraRule "PPUP" era) ~ ShelleyPPUPState era
, EncCBOR (PPUPPredFailure era) -- Serializing the PredicateFailure
, Eq (PPUPPredFailure era)
, Show (PPUPPredFailure era)
) =>
STS (BabbageUTXOS era)
where
type BaseM (BabbageUTXOS era) = ShelleyBase
type Environment (BabbageUTXOS era) = UtxoEnv era
type State (BabbageUTXOS era) = UTxOState era
type Signal (BabbageUTXOS era) = AlonzoTx era
type PredicateFailure (BabbageUTXOS era) = AlonzoUtxosPredFailure era
type Event (BabbageUTXOS era) = AlonzoUtxosEvent era
transitionRules = [utxosTransition]
instance
( Era era
, STS (ShelleyPPUP era)
, PPUPPredFailure era ~ ShelleyPpupPredFailure era
, Event (EraRule "PPUP" era) ~ Event (ShelleyPPUP era)
) =>
Embed (ShelleyPPUP era) (BabbageUTXOS era)
where
wrapFailed = UpdateFailure
wrapEvent = AlonzoPpupToUtxosEvent
utxosTransition ::
forall era.
( AlonzoEraTx era
, ExtendedUTxO era
, BabbageEraTxBody era
, EraUTxO era
, ScriptsNeeded era ~ AlonzoScriptsNeeded era
, Tx era ~ AlonzoTx era
, TxCert era ~ ShelleyTxCert era
, Script era ~ AlonzoScript era
, EraGovernance era
, GovernanceState era ~ ShelleyPPUPState era
, Environment (EraRule "PPUP" era) ~ PpupEnv era
, Signal (EraRule "PPUP" era) ~ Maybe (Update era)
, Embed (EraRule "PPUP" era) (BabbageUTXOS era)
, State (EraRule "PPUP" era) ~ ShelleyPPUPState era
, EncCBOR (PPUPPredFailure era)
, Eq (PPUPPredFailure era)
, Show (PPUPPredFailure era)
, EraPlutusContext 'PlutusV1 era
) =>
TransitionRule (BabbageUTXOS era)
utxosTransition =
judgmentContext >>= \(TRC (_, _, tx)) -> do
case tx ^. isValidTxL of
IsValid True -> scriptsYes
IsValid False -> scriptsNo
-- ===================================================================
scriptsYes ::
forall era.
( ExtendedUTxO era
, AlonzoEraTx era
, EraUTxO era
, ScriptsNeeded era ~ AlonzoScriptsNeeded era
, Tx era ~ AlonzoTx era
, Script era ~ AlonzoScript era
, STS (BabbageUTXOS era)
, Environment (EraRule "PPUP" era) ~ PpupEnv era
, Signal (EraRule "PPUP" era) ~ Maybe (Update era)
, Embed (EraRule "PPUP" era) (BabbageUTXOS era)
, GovernanceState era ~ ShelleyPPUPState era
, State (EraRule "PPUP" era) ~ ShelleyPPUPState era
, EraPlutusContext 'PlutusV1 era
) =>
TransitionRule (BabbageUTXOS era)
scriptsYes = do
TRC (UtxoEnv slot pp dpstate genDelegs, u@(UTxOState utxo _ _ pup _), tx) <-
judgmentContext
let txBody = body tx
{- refunded := keyRefunds pp txb -}
refunded = keyTxRefunds pp dpstate txBody
{- depositChange := (totalDeposits pp poolParams txcerts txb) − refunded -}
protVer = pp ^. ppProtocolVersionL
depositChange = totalTxDeposits pp dpstate txBody <-> refunded
tellEvent $ TotalDeposits (hashAnnotated txBody) depositChange
sysSt <- liftSTS $ asks systemStart
ei <- liftSTS $ asks epochInfo
-- We intentionally run the PPUP rule before evaluating any Plutus scripts.
-- We do not want to waste computation running plutus scripts if the
-- transaction will fail due to `PPUP`
ppup' <-
trans @(EraRule "PPUP" era) $
TRC
(PPUPEnv slot pp genDelegs, pup, strictMaybeToMaybe $ txBody ^. updateTxBodyG)
let !_ = traceEvent validBegin ()
{- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
Right sLst ->
{- isValid tx = evalScripts tx sLst = True -}
whenFailureFree $
when2Phase $
case evalScripts @era protVer tx sLst of
Fails _ fs ->
failBecause $
ValidationTagMismatch
(tx ^. isValidTxL)
(FailedUnexpectedly (scriptFailuresToPredicateFailure protVer fs))
Passes ps -> mapM_ (tellEvent . SuccessfulPlutusScriptsEvent) (nonEmpty ps)
Left info -> failBecause (CollectErrors info)
let !_ = traceEvent validEnd ()
pure $! updateUTxOState pp u txBody depositChange ppup'
scriptsNo ::
forall era.
( AlonzoEraTx era
, ExtendedUTxO era
, EraUTxO era
, ScriptsNeeded era ~ AlonzoScriptsNeeded era
, STS (BabbageUTXOS era)
, BabbageEraTxBody era
, Tx era ~ AlonzoTx era
, Script era ~ AlonzoScript era
, EraPlutusContext 'PlutusV1 era
) =>
TransitionRule (BabbageUTXOS era)
scriptsNo = do
TRC (UtxoEnv _ pp _ _, us@(UTxOState utxo _ fees _ _), tx) <- judgmentContext
{- txb := txbody tx -}
let txBody = tx ^. bodyTxL
sysSt <- liftSTS $ asks systemStart
ei <- liftSTS $ asks epochInfo
() <- pure $! traceEvent invalidBegin ()
case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
Right sLst ->
{- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
{- isValid tx = evalScripts tx sLst = False -}
whenFailureFree $
when2Phase $ case evalScripts @era (pp ^. ppProtocolVersionL) tx sLst of
Passes _ -> failBecause $ ValidationTagMismatch (tx ^. isValidTxL) PassedUnexpectedly
Fails ps fs -> do
mapM_ (tellEvent . SuccessfulPlutusScriptsEvent) (nonEmpty ps)
tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))
Left info -> failBecause (CollectErrors info)
() <- pure $! traceEvent invalidEnd ()
{- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
{- utxoDel = txBody ^. collateralInputsTxBodyL ◁ utxo -}
let !(utxoKeep, utxoDel) = extractKeys (unUTxO utxo) (txBody ^. collateralInputsTxBodyL)
UTxO collouts = collOuts txBody
collateralFees = collAdaBalance txBody utxoDel -- NEW to Babbage
pure $!
us {- (collInputs txb ⋪ utxo) ∪ collouts tx -}
{ utxosUtxo = UTxO (Map.union utxoKeep collouts) -- NEW to Babbage
{- fees + collateralFees -}
, utxosFees = fees <> collateralFees -- NEW to Babbage
, utxosStakeDistr = updateStakeDistribution pp (utxosStakeDistr us) (UTxO utxoDel) (UTxO collouts)
}