-
Notifications
You must be signed in to change notification settings - Fork 156
/
Alonzo.hs
357 lines (324 loc) · 13 KB
/
Alonzo.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
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Cardano.DbSync.Era.Shelley.Generic.Tx.Alonzo (
fromAlonzoTx,
dataHashToBytes,
mkCollTxIn,
mkTxData,
mkTxScript,
resolveRedeemers,
extraKeyWits,
getPlutusSizes,
getScripts,
txDataWitness,
rmWdrl,
rmCerts,
rmInps,
) where
import qualified Cardano.Api.Shelley as Api
import qualified Cardano.Crypto.Hash as Crypto
import Cardano.Db (ScriptType (..))
import Cardano.DbSync.Era.Shelley.Generic.Metadata
import Cardano.DbSync.Era.Shelley.Generic.Tx.Allegra (getInterval)
import Cardano.DbSync.Era.Shelley.Generic.Tx.Shelley
import Cardano.DbSync.Era.Shelley.Generic.Tx.Types
import Cardano.DbSync.Era.Shelley.Generic.Util
import Cardano.DbSync.Era.Shelley.Generic.Witness
import Cardano.DbSync.Types (DataHash)
import qualified Cardano.Ledger.Address as Ledger
import Cardano.Ledger.Alonzo.Data (AlonzoAuxiliaryData (..))
import qualified Cardano.Ledger.Alonzo.Language as Alonzo
import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), txscriptfee)
import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
import Cardano.Ledger.Alonzo.TxBody (AlonzoEraTxBody, AlonzoTxOut)
import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo
import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import qualified Cardano.Ledger.CompactAddress as Ledger
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Era as Ledger
import qualified Cardano.Ledger.Keys as Ledger
import Cardano.Ledger.Mary.Value (MaryValue (..), policyID)
import qualified Cardano.Ledger.SafeHash as Ledger
import Cardano.Ledger.Shelley.Scripts (ScriptHash)
import qualified Cardano.Ledger.Shelley.Tx as ShelleyTx
import qualified Cardano.Ledger.Shelley.TxBody as Shelley
import qualified Cardano.Ledger.ShelleyMA.TxBody as ShelleyMa
import Cardano.Prelude
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.Short as SBS
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Lens.Micro
import Ouroboros.Consensus.Cardano.Block (StandardAlonzo, StandardCrypto)
fromAlonzoTx :: Bool -> Maybe Alonzo.Prices -> (Word64, Core.Tx StandardAlonzo) -> Tx
fromAlonzoTx ioExtraPlutus mprices (blkIndex, tx) =
Tx
{ txHash = txHashId tx
, txBlockIndex = blkIndex
, txSize = fromIntegral $ tx ^. Core.sizeTxF
, txValidContract = isValid2
, txInputs =
if not isValid2
then collInputs
else Map.elems $ rmInps finalMaps
, txCollateralInputs = collInputs
, txReferenceInputs = [] -- Alonzo does not have reference inputs
, txOutputs =
if not isValid2
then []
else outputs
, txCollateralOutputs = [] -- Alonzo does not have collateral outputs
, txFees =
if not isValid2
then Nothing
else Just $ Alonzo.txfee' txBody
, txOutSum =
if not isValid2
then Coin 0
else sumTxOutCoin outputs
, txInvalidBefore = invalidBefore
, txInvalidHereafter = invalidAfter
, txWithdrawalSum = calcWithdrawalSum txBody
, txMetadata = fromAlonzoMetadata <$> getTxMetadata tx
, txCertificates = snd <$> rmCerts finalMaps
, txWithdrawals = Map.elems $ rmWdrl finalMaps
, txParamProposal = mkTxParamProposal (Alonzo Standard) txBody
, txMint = Alonzo.mint' txBody
, txRedeemer = redeemers
, txData = txDataWitness tx
, txScriptSizes = getPlutusSizes tx
, txScripts = getScripts tx
, txExtraKeyWitnesses = extraKeyWits txBody
}
where
txBody :: Alonzo.AlonzoTxBody StandardAlonzo
txBody = tx ^. Core.bodyTxL
outputs :: [TxOut]
outputs = zipWith fromTxOut [0 ..] $ toList (Alonzo.outputs' txBody)
fromTxOut :: Word64 -> AlonzoTxOut StandardAlonzo -> TxOut
fromTxOut index txOut =
TxOut
{ txOutIndex = index
, txOutAddress = txOut ^. Core.addrTxOutL
, txOutAddressRaw = SBS.fromShort bs
, txOutAdaValue = Coin ada
, txOutMaValue = maMap
, txOutScript = Nothing
, txOutDatum = getMaybeDatumHash $ strictMaybeToMaybe mDataHash
}
where
Ledger.UnsafeCompactAddr bs = txOut ^. Core.compactAddrTxOutL
MaryValue ada maMap = txOut ^. Core.valueTxOutL
mDataHash = txOut ^. Alonzo.dataHashTxOutL
(finalMaps, redeemers) = resolveRedeemers ioExtraPlutus mprices tx
-- This is true if second stage contract validation passes or there are no contracts.
isValid2 :: Bool
isValid2 =
case Alonzo.isValid tx of
Alonzo.IsValid x -> x
(invalidBefore, invalidAfter) = getInterval $ Alonzo.vldt' txBody
collInputs = mkCollTxIn txBody
mkCollTxIn :: (Ledger.Crypto era ~ StandardCrypto, AlonzoEraTxBody era) => Core.TxBody era -> [TxIn]
mkCollTxIn txBody = map fromTxIn . toList $ txBody ^. Alonzo.collateralInputsTxBodyL
getScripts ::
forall era.
( Ledger.Crypto era ~ StandardCrypto
, Core.Script era ~ Alonzo.AlonzoScript era
, Core.AuxiliaryData era ~ AlonzoAuxiliaryData era
, Core.EraWitnesses era
, Core.EraTx era
) =>
Core.Tx era ->
[TxScript]
getScripts tx =
mkTxScript
<$> ( Map.toList (tx ^. (Core.witsTxL . Core.scriptWitsL))
++ getAuxScripts (tx ^. Core.auxDataTxL)
)
where
getAuxScripts ::
ShelleyMa.StrictMaybe (AlonzoAuxiliaryData era) ->
[(ScriptHash StandardCrypto, Alonzo.AlonzoScript era)]
getAuxScripts maux =
case strictMaybeToMaybe maux of
Nothing -> []
Just (AlonzoAuxiliaryData' _ scrs) ->
map (\scr -> (Core.hashScript @era scr, scr)) $ toList scrs
resolveRedeemers ::
forall era.
( Ledger.Crypto era ~ StandardCrypto
, Alonzo.AlonzoEraWitnesses era
, Shelley.ShelleyEraTxBody era
, Core.EraTx era
) =>
Bool ->
Maybe Alonzo.Prices ->
Core.Tx era ->
(RedeemerMaps, [(Word64, TxRedeemer)])
resolveRedeemers ioExtraPlutus mprices tx =
if not ioExtraPlutus then (initRedeemersMaps, [])
else mkRdmrAndUpdateRec (initRedeemersMaps, []) $
zip [0 ..] $
Map.toList (Alonzo.unRedeemers (tx ^. (Core.witsTxL . Alonzo.rdmrsWitsL)))
where
txBody = tx ^. Core.bodyTxL
withdrawalsNoRedeemers :: Map (Shelley.RewardAcnt StandardCrypto) TxWithdrawal
withdrawalsNoRedeemers =
Map.mapWithKey (curry mkTxWithdrawal) $
Shelley.unWdrl $
txBody ^. Shelley.wdrlsTxBodyL
txCertsNoRedeemers :: [(Shelley.DCert StandardCrypto, TxCertificate)]
txCertsNoRedeemers =
zipWith (\n dcert -> (dcert, mkTxCertificate n dcert)) [0 ..] $
toList $
txBody ^. Shelley.certsTxBodyL
txInsMissingRedeemer :: Map (ShelleyTx.TxIn StandardCrypto) TxIn
txInsMissingRedeemer = Map.fromList $ fmap (\inp -> (inp, fromTxIn inp)) $ toList $ txBody ^. Core.inputsTxBodyL
initRedeemersMaps :: RedeemerMaps
initRedeemersMaps = RedeemerMaps withdrawalsNoRedeemers txCertsNoRedeemers txInsMissingRedeemer
mkRdmrAndUpdateRec ::
(RedeemerMaps, [(Word64, TxRedeemer)]) ->
[(Word64, (Alonzo.RdmrPtr, (Alonzo.Data era, ExUnits)))] ->
(RedeemerMaps, [(Word64, TxRedeemer)])
mkRdmrAndUpdateRec (rdmrMaps, rdmrsAcc) [] = (rdmrMaps, reverse rdmrsAcc)
mkRdmrAndUpdateRec (rdmrMaps, rdmrsAcc) ((rdmrIx, rdmr) : rest) =
let (txRdmr, rdmrMaps') = handleRedeemer rdmrIx rdmr rdmrMaps
in mkRdmrAndUpdateRec (rdmrMaps', (rdmrIx, txRdmr) : rdmrsAcc) rest
handleRedeemer ::
Word64 ->
(Alonzo.RdmrPtr, (Alonzo.Data era, ExUnits)) ->
RedeemerMaps ->
(TxRedeemer, RedeemerMaps)
handleRedeemer rdmrIx (ptr@(Alonzo.RdmrPtr tag index), (dt, exUnits)) rdmrMps =
(txRdmr, rdmrMps')
where
(rdmrMps', mScript) = case strictMaybeToMaybe (Alonzo.rdptrInv txBody ptr) of
Just (Alonzo.Minting policyId) -> (rdmrMps, Just $ Right $ unScriptHash $ policyID policyId)
Just (Alonzo.Spending txIn) -> handleTxInPtr rdmrIx txIn rdmrMps
Just (Alonzo.Rewarding rwdAcnt) -> handleRewardPtr rdmrIx rwdAcnt rdmrMps
Just prp@(Alonzo.Certifying dcert) -> case strictMaybeToMaybe (Alonzo.rdptr txBody prp) of
Just ptr' | ptr == ptr' -> handleCertPtr rdmrIx dcert rdmrMps
_ -> (rdmrMps, Nothing)
Nothing -> (rdmrMps, Nothing)
txRdmr =
TxRedeemer
{ txRedeemerMem = fromIntegral $ exUnitsMem exUnits
, txRedeemerSteps = fromIntegral $ exUnitsSteps exUnits
, txRedeemerFee = (`txscriptfee` exUnits) <$> mprices
, txRedeemerPurpose = tag
, txRedeemerIndex = index
, txRedeemerScriptHash = mScript
, txRedeemerData = mkTxData (Alonzo.hashData dt, dt)
}
handleTxInPtr :: Word64 -> ShelleyTx.TxIn StandardCrypto -> RedeemerMaps -> (RedeemerMaps, Maybe (Either TxIn ByteString))
handleTxInPtr rdmrIx txIn mps = case Map.lookup txIn (rmInps mps) of
Nothing -> (mps, Nothing)
Just gtxIn ->
let gtxIn' = gtxIn {txInRedeemerIndex = Just rdmrIx}
in (mps {rmInps = Map.insert txIn gtxIn' (rmInps mps)}, Just (Left gtxIn'))
handleRewardPtr :: Word64 -> Shelley.RewardAcnt StandardCrypto -> RedeemerMaps -> (RedeemerMaps, Maybe (Either TxIn ByteString))
handleRewardPtr rdmrIx rwdAcnt mps = case Map.lookup rwdAcnt (rmWdrl mps) of
Nothing -> (mps, Nothing)
Just wdrl ->
let wdrl' = wdrl {txwRedeemerIndex = Just rdmrIx}
in (mps {rmWdrl = Map.insert rwdAcnt wdrl' (rmWdrl mps)}, Right <$> scriptHashAcnt rwdAcnt)
handleCertPtr :: Word64 -> Shelley.DCert StandardCrypto -> RedeemerMaps -> (RedeemerMaps, Maybe (Either TxIn ByteString))
handleCertPtr rdmrIx dcert mps =
(mps {rmCerts = map f (rmCerts mps)}, Right <$> scriptHashCert dcert)
where
f (dcert', cert) | dcert' == dcert = (dcert, cert {txcRedeemerIndex = Just rdmrIx})
f x = x
data RedeemerMaps = RedeemerMaps
{ rmWdrl :: Map (Shelley.RewardAcnt StandardCrypto) TxWithdrawal
, rmCerts :: [(Shelley.DCert StandardCrypto, TxCertificate)]
, rmInps :: Map (ShelleyTx.TxIn StandardCrypto) TxIn
}
mkTxScript ::
Ledger.Crypto era ~ StandardCrypto =>
(ScriptHash StandardCrypto, Alonzo.AlonzoScript era) ->
TxScript
mkTxScript (hsh, script) =
TxScript
{ txScriptHash = unScriptHash hsh
, txScriptType = getScriptType
, txScriptPlutusSize = getPlutusScriptSize script
, txScriptJson = timelockJsonScript
, txScriptCBOR = plutusCborScript
}
where
getScriptType :: ScriptType
getScriptType =
case script of
Alonzo.TimelockScript {} -> Timelock
Alonzo.PlutusScript Alonzo.PlutusV1 _s -> PlutusV1
Alonzo.PlutusScript Alonzo.PlutusV2 _s -> PlutusV2
timelockJsonScript :: Maybe ByteString
timelockJsonScript =
case script of
Alonzo.TimelockScript s ->
Just . LBS.toStrict . Aeson.encode $ Api.fromAllegraTimelock Api.TimeLocksInSimpleScriptV2 s
Alonzo.PlutusScript {} -> Nothing
plutusCborScript :: Maybe ByteString
plutusCborScript =
case script of
Alonzo.TimelockScript {} -> Nothing
plutusScript -> Just $ Ledger.originalBytes plutusScript
getPlutusSizes ::
forall era.
( Core.EraTx era
, Core.Script era ~ Alonzo.AlonzoScript era
) =>
Core.Tx era ->
[Word64]
getPlutusSizes tx =
mapMaybe getPlutusScriptSize $
Map.elems $
tx ^. (Core.witsTxL . Core.scriptWitsL)
-- | Returns Nothing for non-plutus scripts.
getPlutusScriptSize :: Alonzo.AlonzoScript era -> Maybe Word64
getPlutusScriptSize script =
case script of
Alonzo.TimelockScript {} -> Nothing
Alonzo.PlutusScript _lang sbs -> Just $ fromIntegral (SBS.length sbs)
txDataWitness ::
(Core.Witnesses era ~ Alonzo.TxWitness era, Core.EraTx era, Ledger.Crypto era ~ StandardCrypto) =>
Core.Tx era ->
[PlutusData]
txDataWitness tx =
mkTxData <$> Map.toList (Alonzo.unTxDats $ Alonzo.txdats' (tx ^. Core.witsTxL))
mkTxData :: (DataHash, Alonzo.Data era) -> PlutusData
mkTxData (dataHash, dt) = PlutusData dataHash (jsonData dt) (Ledger.originalBytes dt)
where
jsonData :: Alonzo.Data era -> ByteString
jsonData =
LBS.toStrict
. Aeson.encode
. Api.scriptDataToJson Api.ScriptDataJsonDetailedSchema
. Api.fromAlonzoData
extraKeyWits ::
AlonzoEraTxBody era =>
Core.TxBody era ->
[ByteString]
extraKeyWits txBody =
Set.toList $
Set.map (\(Ledger.KeyHash h) -> Crypto.hashToBytes h) $
txBody ^. Alonzo.reqSignerHashesTxBodyL
scriptHashAcnt :: Shelley.RewardAcnt StandardCrypto -> Maybe ByteString
scriptHashAcnt rewardAddr = getCredentialScriptHash $ Ledger.getRwdCred rewardAddr
scriptHashCert :: Shelley.DCert StandardCrypto -> Maybe ByteString
scriptHashCert cert =
case cert of
Shelley.DCertDeleg (Shelley.DeRegKey cred) ->
getCredentialScriptHash cred
Shelley.DCertDeleg (Shelley.Delegate (Shelley.Delegation cred _)) ->
getCredentialScriptHash cred
_ -> Nothing