/
Data.hs
232 lines (196 loc) · 7.56 KB
/
Data.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
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# 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 #-}
-- This is needed for the `HeapWords (StrictMaybe (DataHash c))` instance
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Cardano.Ledger.Alonzo.Scripts.Data (
Data (Data),
DataHash,
hashData,
getPlutusData,
dataHashSize,
BinaryData,
hashBinaryData,
makeBinaryData,
binaryDataToData,
dataToBinaryData,
Datum (..),
datumDataHash,
)
where
import Cardano.Crypto.Hash.Class (HashAlgorithm)
import Cardano.HeapWords (HeapWords (..), heapWords0, heapWords1)
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Binary (
Annotator (..),
DecCBOR (..),
DecoderError (..),
EncCBOR (..),
ToCBOR (..),
decodeFullAnnotator,
decodeNestedCborBytes,
encodeTag,
fromPlainDecoder,
fromPlainEncoding,
)
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto (HASH))
import Cardano.Ledger.MemoBytes (
Mem,
MemoBytes (..),
MemoHashIndex,
Memoized (RawType),
getMemoRawType,
getMemoSafeHash,
mkMemoBytes,
mkMemoized,
shortToLazy,
)
import Cardano.Ledger.SafeHash (
HashAnnotated,
SafeToHash (..),
hashAnnotated,
)
import qualified Codec.Serialise as Cborg (Serialise (..))
import Control.DeepSeq (NFData)
import Data.Aeson (ToJSON (..), Value (Null))
import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import qualified PlutusLedgerApi.V1 as PV1 -- NOTE PV1.Data === PV2.Data
-- ============================================================================
-- the newtype Data is a wrapper around the type that Plutus expects as data.
-- The newtype will memoize the serialized bytes.
-- | This is a wrapper with a phantom era for PV1.Data, since we need
-- something with kind (* -> *) for MemoBytes
newtype PlutusData era = PlutusData PV1.Data
deriving newtype (Eq, Generic, Show, NFData, NoThunks, Cborg.Serialise)
instance Typeable era => EncCBOR (PlutusData era) where
encCBOR (PlutusData d) = fromPlainEncoding $ Cborg.encode d
instance Typeable era => DecCBOR (Annotator (PlutusData era)) where
decCBOR = pure <$> fromPlainDecoder Cborg.decode
newtype Data era = DataConstr (MemoBytes PlutusData era)
deriving (Eq, Generic)
deriving newtype (SafeToHash, ToCBOR, NFData)
-- | Encodes memoized bytes created upon construction.
instance Typeable era => EncCBOR (Data era)
instance Memoized Data where
type RawType Data = PlutusData
deriving instance HashAlgorithm (HASH (EraCrypto era)) => Show (Data era)
deriving via Mem PlutusData era instance Era era => DecCBOR (Annotator (Data era))
type instance MemoHashIndex PlutusData = EraIndependentData
instance (EraCrypto era ~ c) => HashAnnotated (Data era) EraIndependentData c where
hashAnnotated = getMemoSafeHash
instance Typeable era => NoThunks (Data era)
pattern Data :: Era era => PV1.Data -> Data era
pattern Data p <- (getMemoRawType -> PlutusData p)
where
Data p = mkMemoized $ PlutusData p
{-# COMPLETE Data #-}
getPlutusData :: Data era -> PV1.Data
getPlutusData (getMemoRawType -> PlutusData d) = d
-- | Inlined data must be stored in the most compact form because it contributes
-- to the memory overhead of the ledger state. Constructor is intentionally not
-- exported, in order to prevent invalid creation of data from arbitrary binary
-- data. Use `makeBinaryData` for smart construction.
newtype BinaryData era = BinaryData ShortByteString
deriving newtype (Eq, NoThunks, Ord, Show, SafeToHash)
deriving (Generic)
instance (EraCrypto era ~ c) => HashAnnotated (BinaryData era) EraIndependentData c
instance Typeable era => EncCBOR (BinaryData era) where
encCBOR (BinaryData sbs) = encodeTag 24 <> encCBOR sbs
instance Era era => DecCBOR (BinaryData era) where
decCBOR = do
bs <- decodeNestedCborBytes
either fail pure $! makeBinaryData (toShort bs)
-- | Construct `BinaryData` from a buffer of bytes, while ensuring that it can be later
-- safely converted to `Data` with `binaryDataToData`
makeBinaryData :: Era era => ShortByteString -> Either String (BinaryData era)
makeBinaryData sbs = do
let binaryData = BinaryData sbs
-- We need to verify that binary data is indeed valid Plutus Data.
case decodeBinaryData binaryData of
Left e -> Left $ "Invalid CBOR for Data: " <> show e
Right _d -> Right binaryData
decodeBinaryData :: forall era. Era era => BinaryData era -> Either DecoderError (Data era)
decodeBinaryData (BinaryData sbs) = do
plutusData <- decodeFullAnnotator (eraProtVerLow @era) "Data" decCBOR (fromStrict (fromShort sbs))
pure (DataConstr (mkMemoBytes plutusData $ shortToLazy sbs))
-- | It is safe to convert `BinaryData` to `Data` because the only way to
-- construct `BinaryData` is through the smart constructor `makeBinaryData` that
-- takes care of validation.
binaryDataToData :: Era era => BinaryData era -> Data era
binaryDataToData binaryData =
case decodeBinaryData binaryData of
Left errMsg ->
error $ "Impossible: incorrectly encoded data: " ++ show errMsg
Right d -> d
dataToBinaryData :: Era era => Data era -> BinaryData era
dataToBinaryData (DataConstr (Memo _ sbs)) = BinaryData sbs
hashBinaryData :: Era era => BinaryData era -> DataHash (EraCrypto era)
hashBinaryData = hashAnnotated
-- =============================================================================
hashData :: Era era => Data era -> DataHash (EraCrypto era)
hashData = hashAnnotated
-- Size of the datum hash attached to the output (could be Nothing)
dataHashSize :: StrictMaybe (DataHash c) -> Integer
dataHashSize SNothing = 0
dataHashSize (SJust _) = 10
instance (Crypto c) => HeapWords (StrictMaybe (DataHash c)) where
heapWords SNothing = heapWords0
heapWords (SJust a) = heapWords1 a
-- ============================================================================
-- Datum
-- | Datum can be described by a either a data hash or binary data, but not
-- both. It can also be neither one of them.
data Datum era
= NoDatum
| DatumHash !(DataHash (EraCrypto era))
| Datum !(BinaryData era)
deriving (Eq, Generic, NoThunks, Ord, Show)
instance Era era => EncCBOR (Datum era) where
encCBOR d = encode $ case d of
DatumHash dh -> Sum DatumHash 0 !> To dh
Datum d' -> Sum Datum 1 !> To d'
NoDatum -> OmitC NoDatum
instance Era era => DecCBOR (Datum era) where
decCBOR = decode (Summands "Datum" decodeDatum)
where
decodeDatum 0 = SumD DatumHash <! From
decodeDatum 1 = SumD Datum <! From
decodeDatum k = Invalid k
instance Era era => ToJSON (Datum era) where
toJSON d =
case datumDataHash d of
SNothing -> Null
SJust dh -> toJSON dh
toEncoding d =
case datumDataHash d of
SNothing -> toEncoding Null
SJust dh -> toEncoding dh
-- | Get the Hash of the datum.
datumDataHash :: Era era => Datum era -> StrictMaybe (DataHash (EraCrypto era))
datumDataHash = \case
NoDatum -> SNothing
DatumHash dh -> SJust dh
Datum bd -> SJust (hashBinaryData bd)