-
Notifications
You must be signed in to change notification settings - Fork 155
/
TxAuxData.hs
378 lines (331 loc) · 12.9 KB
/
TxAuxData.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
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cardano.Ledger.Alonzo.TxAuxData (
-- * AlonzoTxAuxData
AlonzoTxAuxData (
AlonzoTxAuxData,
AlonzoTxAuxData',
atadMetadata,
atadTimelock,
atadPlutus,
atadMetadata',
atadTimelock',
atadPlutus'
),
AlonzoEraTxAuxData (..),
AlonzoTxAuxDataRaw,
mkAlonzoTxAuxData,
AuxiliaryDataHash (..),
hashAlonzoTxAuxData,
validateAlonzoTxAuxData,
getAlonzoTxAuxDataScripts,
translateAlonzoTxAuxData,
metadataAlonzoTxAuxDataL,
timelockScriptsAlonzoTxAuxDataL,
plutusScriptsAllegraTxAuxDataL,
-- * Deprecated
AuxiliaryData,
)
where
import Cardano.Crypto.Hash.Class (HashAlgorithm)
import Cardano.Ledger.Allegra.Scripts (Timelock, translateTimelock)
import Cardano.Ledger.Allegra.TxAuxData (AllegraEraTxAuxData (..), AllegraTxAuxData (..))
import Cardano.Ledger.Alonzo.Era
import Cardano.Ledger.Alonzo.Scripts (
AlonzoEraScript (..),
AlonzoScript (..),
mkBinaryPlutusScript,
plutusScriptBinary,
plutusScriptLanguage,
validScript,
)
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash (..))
import Cardano.Ledger.BaseTypes (ProtVer)
import Cardano.Ledger.Binary (
Annotator (..),
DecCBOR (..),
EncCBOR (..),
ToCBOR,
TokenType (..),
decodeStrictSeq,
peekTokenType,
)
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto (HASH))
import Cardano.Ledger.MemoBytes (
EqRaw,
Mem,
MemoBytes (..),
MemoHashIndex,
Memoized (RawType),
getMemoRawType,
getMemoSafeHash,
lensMemoRawType,
mkMemoized,
)
import Cardano.Ledger.Plutus.Language (Language (..), PlutusBinary (..), guardPlutus)
import Cardano.Ledger.SafeHash (HashAnnotated, SafeToHash (..), hashAnnotated)
import Cardano.Ledger.Shelley.TxAuxData (Metadatum, validMetadatum)
import Control.DeepSeq (NFData, deepseq)
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NE
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isNothing, mapMaybe)
import Data.Sequence.Strict (StrictSeq ((:<|)))
import qualified Data.Sequence.Strict as StrictSeq
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Stack
import Lens.Micro (Lens')
import NoThunks.Class (InspectHeapNamed (..), NoThunks)
class AllegraEraTxAuxData era => AlonzoEraTxAuxData era where
plutusScriptsTxAuxDataL :: Lens' (TxAuxData era) (Map Language (NE.NonEmpty PlutusBinary))
data AlonzoTxAuxDataRaw era = AlonzoTxAuxDataRaw
{ atadrMetadata :: !(Map Word64 Metadatum)
, atadrTimelock :: !(StrictSeq (Timelock era))
, atadrPlutus :: !(Map Language (NE.NonEmpty PlutusBinary))
}
deriving (Generic)
deriving instance Eq (Timelock era) => Eq (AlonzoTxAuxDataRaw era)
deriving instance Show (Timelock era) => Show (AlonzoTxAuxDataRaw era)
instance NFData (Timelock era) => NFData (AlonzoTxAuxDataRaw era)
deriving via
InspectHeapNamed "AlonzoTxAuxDataRaw" (AlonzoTxAuxDataRaw era)
instance
NoThunks (AlonzoTxAuxDataRaw era)
-- | Encodes memoized bytes created upon construction.
instance Era era => EncCBOR (AlonzoTxAuxData era)
instance Era era => EncCBOR (AlonzoTxAuxDataRaw era) where
encCBOR AlonzoTxAuxDataRaw {atadrMetadata, atadrTimelock, atadrPlutus} =
encode $
Tag 259 $
Keyed
( \m ts mps1 mps2 mps3 ->
AlonzoTxAuxDataRaw m ts $
Map.fromList
[ (pv, ps)
| (pv, Just ps) <-
[ (PlutusV1, mps1)
, (PlutusV2, mps2)
, (PlutusV3, mps3)
]
]
)
!> Omit null (Key 0 $ To atadrMetadata)
!> Omit null (Key 1 $ To atadrTimelock)
!> Omit isNothing (Key 2 $ E (maybe mempty encCBOR) (Map.lookup PlutusV1 atadrPlutus))
!> Omit isNothing (Key 3 $ E (maybe mempty encCBOR) (Map.lookup PlutusV2 atadrPlutus))
!> Omit isNothing (Key 4 $ E (maybe mempty encCBOR) (Map.lookup PlutusV3 atadrPlutus))
-- | Helper function that will construct Auxiliary data from Metadatum map and a list of scripts.
--
-- Note that the relative order of same type scripts will be preserved.
mkAlonzoTxAuxData ::
forall f era.
(Foldable f, AlonzoEraScript era) =>
Map Word64 Metadatum ->
f (AlonzoScript era) ->
AlonzoTxAuxData era
mkAlonzoTxAuxData atadrMetadata allScripts =
mkMemoized $ AlonzoTxAuxDataRaw {atadrMetadata, atadrTimelock, atadrPlutus}
where
partitionScripts (tss, pss) =
\case
TimelockScript ts -> (ts :<| tss, pss)
PlutusScript ps ->
let lang = plutusScriptLanguage ps
bs = plutusScriptBinary ps
in (tss, Map.alter (Just . maybe (pure bs) (NE.cons bs)) lang pss)
(atadrTimelock, atadrPlutus) =
foldr (flip partitionScripts) (mempty, Map.empty) allScripts
getAlonzoTxAuxDataScripts ::
forall era.
AlonzoEraScript era =>
AlonzoTxAuxData era ->
StrictSeq (AlonzoScript era)
getAlonzoTxAuxDataScripts AlonzoTxAuxData {atadTimelock = timelocks, atadPlutus = plutus} =
mconcat $
(TimelockScript <$> timelocks)
: [ StrictSeq.fromList $
-- It is fine to filter out unsupported languages with mapMaybe, because the invariant for
-- AlonzoTxAuxData is that it does not contain scripts with languages that are not
-- supported in this era
mapMaybe (fmap PlutusScript . mkBinaryPlutusScript lang) $
NE.toList plutusScripts
| lang <- [PlutusV1 .. eraMaxLanguage @era]
, Just plutusScripts <- [Map.lookup lang plutus]
]
instance Era era => DecCBOR (Annotator (AlonzoTxAuxDataRaw era)) where
decCBOR =
peekTokenType >>= \case
TypeMapLen -> decodeShelley
TypeMapLen64 -> decodeShelley
TypeMapLenIndef -> decodeShelley
TypeListLen -> decodeShelleyMA
TypeListLen64 -> decodeShelleyMA
TypeListLenIndef -> decodeShelleyMA
TypeTag -> decodeAlonzo
TypeTag64 -> decodeAlonzo
_ -> fail "Failed to decode AuxiliaryData"
where
decodeShelley =
decode
( Ann (Emit AlonzoTxAuxDataRaw)
<*! Ann From
<*! Ann (Emit StrictSeq.empty)
<*! Ann (Emit Map.empty)
)
decodeShelleyMA =
decode
( Ann (RecD AlonzoTxAuxDataRaw)
<*! Ann From
<*! D
(sequence <$> decodeStrictSeq decCBOR)
<*! Ann (Emit Map.empty)
)
decodeAlonzo =
decode $
TagD 259 $
SparseKeyed "AuxiliaryData" (pure emptyAuxData) auxDataField []
addPlutusScripts lang scripts ad =
case NE.nonEmpty scripts of
Nothing -> ad
Just neScripts ->
-- Avoid leaks by deepseq, since non empty list is lazy.
neScripts `deepseq` ad {atadrPlutus = Map.insert lang neScripts $ atadrPlutus ad}
auxDataField :: Word -> Field (Annotator (AlonzoTxAuxDataRaw era))
auxDataField 0 = fieldA (\x ad -> ad {atadrMetadata = x}) From
auxDataField 1 =
fieldAA
(\x ad -> ad {atadrTimelock = atadrTimelock ad <> x})
(D (sequence <$> decodeStrictSeq decCBOR))
auxDataField 2 = fieldA (addPlutusScripts PlutusV1) (D (guardPlutus PlutusV1 >> decCBOR))
auxDataField 3 = fieldA (addPlutusScripts PlutusV2) (D (guardPlutus PlutusV2 >> decCBOR))
auxDataField 4 = fieldA (addPlutusScripts PlutusV3) (D (guardPlutus PlutusV3 >> decCBOR))
auxDataField n = field (\_ t -> t) (Invalid n)
emptyAuxData :: AlonzoTxAuxDataRaw era
emptyAuxData = AlonzoTxAuxDataRaw mempty mempty mempty
-- ================================================================================
-- Version with serialized bytes.
newtype AlonzoTxAuxData era = AuxiliaryDataConstr (MemoBytes AlonzoTxAuxDataRaw era)
deriving (Generic)
deriving newtype (ToCBOR, SafeToHash)
instance Memoized AlonzoTxAuxData where
type RawType AlonzoTxAuxData = AlonzoTxAuxDataRaw
instance EqRaw (AlonzoTxAuxData era)
type AuxiliaryData era = AlonzoTxAuxData era
{-# DEPRECATED AuxiliaryData "Use `AlonzoTxAuxData` instead" #-}
instance Crypto c => EraTxAuxData (AlonzoEra c) where
type TxAuxData (AlonzoEra c) = AlonzoTxAuxData (AlonzoEra c)
mkBasicTxAuxData = AlonzoTxAuxData mempty mempty mempty
metadataTxAuxDataL = metadataAlonzoTxAuxDataL
upgradeTxAuxData (AllegraTxAuxData md scripts) =
mkMemoized $
AlonzoTxAuxDataRaw
{ atadrMetadata = md
, atadrTimelock = translateTimelock <$> scripts
, atadrPlutus = mempty
}
hashTxAuxData = hashAlonzoTxAuxData
validateTxAuxData = validateAlonzoTxAuxData
metadataAlonzoTxAuxDataL :: Era era => Lens' (AlonzoTxAuxData era) (Map Word64 Metadatum)
metadataAlonzoTxAuxDataL =
lensMemoRawType atadrMetadata $ \txAuxDataRaw md -> txAuxDataRaw {atadrMetadata = md}
hashAlonzoTxAuxData ::
(HashAlgorithm (HASH c), HashAnnotated x EraIndependentTxAuxData c) =>
x ->
AuxiliaryDataHash c
hashAlonzoTxAuxData x = AuxiliaryDataHash (hashAnnotated x)
validateAlonzoTxAuxData ::
(AlonzoEraScript era, Script era ~ AlonzoScript era) =>
ProtVer ->
AuxiliaryData era ->
Bool
validateAlonzoTxAuxData pv auxData@AlonzoTxAuxData {atadMetadata = metadata} =
all validMetadatum metadata
&& all (validScript pv) (getAlonzoTxAuxDataScripts auxData)
instance Crypto c => AllegraEraTxAuxData (AlonzoEra c) where
timelockScriptsTxAuxDataL = timelockScriptsAlonzoTxAuxDataL
timelockScriptsAlonzoTxAuxDataL ::
Era era => Lens' (AlonzoTxAuxData era) (StrictSeq (Timelock era))
timelockScriptsAlonzoTxAuxDataL =
lensMemoRawType atadrTimelock $ \txAuxDataRaw ts -> txAuxDataRaw {atadrTimelock = ts}
instance Crypto c => AlonzoEraTxAuxData (AlonzoEra c) where
plutusScriptsTxAuxDataL = plutusScriptsAllegraTxAuxDataL
plutusScriptsAllegraTxAuxDataL ::
Era era => Lens' (AlonzoTxAuxData era) (Map Language (NE.NonEmpty PlutusBinary))
plutusScriptsAllegraTxAuxDataL =
lensMemoRawType atadrPlutus $ \txAuxDataRaw ts -> txAuxDataRaw {atadrPlutus = ts}
instance EraCrypto era ~ c => HashAnnotated (AuxiliaryData era) EraIndependentTxAuxData c where
hashAnnotated = getMemoSafeHash
deriving newtype instance NFData (AuxiliaryData era)
deriving instance Eq (AuxiliaryData era)
deriving instance HashAlgorithm (HASH (EraCrypto era)) => Show (AuxiliaryData era)
type instance MemoHashIndex AlonzoTxAuxDataRaw = EraIndependentTxAuxData
deriving via
InspectHeapNamed "AlonzoTxAuxDataRaw" (AuxiliaryData era)
instance
NoThunks (AuxiliaryData era)
deriving via
(Mem AlonzoTxAuxDataRaw era)
instance
Era era => DecCBOR (Annotator (AuxiliaryData era))
-- | Construct auxiliary data. Make sure not to supply plutus script versions that are not
-- supported in this era, because it will result in a runtime exception. Use
-- `mkAlonzoTxAuxData` instead if you need runtime safety guarantees.
pattern AlonzoTxAuxData ::
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum ->
StrictSeq (Timelock era) ->
Map Language (NE.NonEmpty PlutusBinary) ->
AlonzoTxAuxData era
pattern AlonzoTxAuxData {atadMetadata, atadTimelock, atadPlutus} <-
(getMemoRawType -> AlonzoTxAuxDataRaw atadMetadata atadTimelock atadPlutus)
where
AlonzoTxAuxData atadrMetadata atadrTimelock atadrPlutus =
let unsupportedScripts =
Map.filterWithKey (\lang _ -> lang > eraMaxLanguage @era) atadrPlutus
prefix =
intercalate "," (show <$> Map.keys unsupportedScripts)
++ if Map.size unsupportedScripts > 1 then " languages are" else " language is"
in if Map.null unsupportedScripts
then mkMemoized $ AlonzoTxAuxDataRaw {atadrMetadata, atadrTimelock, atadrPlutus}
else error $ prefix ++ " not supported in " ++ eraName @era
{-# COMPLETE AlonzoTxAuxData #-}
pattern AlonzoTxAuxData' ::
forall era.
Map Word64 Metadatum ->
StrictSeq (Timelock era) ->
Map Language (NE.NonEmpty PlutusBinary) ->
AlonzoTxAuxData era
pattern AlonzoTxAuxData' {atadMetadata', atadTimelock', atadPlutus'} <-
(getMemoRawType -> AlonzoTxAuxDataRaw atadMetadata' atadTimelock' atadPlutus')
translateAlonzoTxAuxData ::
(AlonzoEraScript era1, AlonzoEraScript era2, EraCrypto era1 ~ EraCrypto era2) =>
AlonzoTxAuxData era1 ->
AlonzoTxAuxData era2
translateAlonzoTxAuxData AlonzoTxAuxData {atadMetadata, atadTimelock, atadPlutus} =
AlonzoTxAuxData
{ atadMetadata = atadMetadata
, atadTimelock = translateTimelock <$> atadTimelock
, atadPlutus = atadPlutus
}