Skip to content

Commit 9e0e501

Browse files
koslambroukoslambrou
committed
Add ToJSON/FromJSON instances for EraTxAuxData
* Add ToJSON/FromJSON and NFData as EraTxAuxData superclass constraints * Add ToJSON/FromJSON for Metadatum * Add ToJSON/FromJSON for Data era and PlutusBinary * Add FromJSON for PoolCert, ConwayGovCert, DijkstraDelegCert, DijkstraTxCert era * Add ToJSON/FromJSON for ShelleyTxAuxData, AllegraTxAuxData, AlonzoTxAuxData * Add round-trip JSON property test for TxAuxData era
1 parent 5f4d015 commit 9e0e501

12 files changed

Lines changed: 203 additions & 5 deletions

File tree

‎eras/allegra/impl/CHANGELOG.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
## 1.10.0.0
44

55
* Add `generate-cbor` executable
6+
* Add `ToJSON` and `FromJSON` instances for `AllegraTxAuxData era`
67
* Change `Signal` to `StAnnTx TopTx era` for: `AllegraUTXOW`, `AllegraUTXO`
78
* Add `FromJSON` instance for `ValidityInterval`
89
* Add `ApplyTick` instance for `AllegraEra`

‎eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ module Cardano.Ledger.Allegra.TxAuxData (
3030

3131
import Cardano.Ledger.Allegra.Era (AllegraEra)
3232
import Cardano.Ledger.Allegra.Scripts (AllegraEraScript)
33+
import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..))
3334
import Cardano.Ledger.Binary (
3435
Annotator,
3536
DecCBOR (..),
@@ -62,6 +63,9 @@ import Codec.CBOR.Decoding (
6263
),
6364
)
6465
import Control.DeepSeq (NFData, deepseq)
66+
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
67+
import qualified Data.Aeson as Aeson
68+
import qualified Data.Foldable as F
6569
import Data.Map.Strict (Map)
6670
import Data.Sequence.Strict (StrictSeq)
6771
import qualified Data.Sequence.Strict as StrictSeq
@@ -204,3 +208,26 @@ instance
204208
<*! Ann From
205209
<*! D (sequence <$> decCBOR)
206210
)
211+
212+
instance
213+
(Era era, EncCBOR (NativeScript era), ToJSON (NativeScript era)) =>
214+
ToKeyValuePairs (AllegraTxAuxData era)
215+
where
216+
toKeyValuePairs (AllegraTxAuxData metadata nativeScripts) =
217+
[ "metadata" .= metadata
218+
, "nativeScripts" .= F.toList nativeScripts
219+
]
220+
221+
deriving via
222+
KeyValuePairs (AllegraTxAuxData era)
223+
instance
224+
(Era era, EncCBOR (NativeScript era), ToJSON (NativeScript era)) => ToJSON (AllegraTxAuxData era)
225+
226+
instance
227+
(Era era, EncCBOR (NativeScript era), FromJSON (NativeScript era)) =>
228+
FromJSON (AllegraTxAuxData era)
229+
where
230+
parseJSON = Aeson.withObject "AllegraTxAuxData" $ \o ->
231+
AllegraTxAuxData
232+
<$> o .: "metadata"
233+
<*> (maybe mempty StrictSeq.fromList <$> o .:? "nativeScripts")

‎eras/alonzo/impl/CHANGELOG.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
## 1.16.0.0
44

55
* Add `generate-cbor` executable
6+
* Add `ToJSON` and `FromJSON` instances for `AlonzoTxAuxData era`
67
* Replace `scriptsProvided` and `scriptsNeeded` in `mkScriptIntegrity` signature with `Set Language`
78
* Add `plutusLanguagesUsedStAnnTx` to `AlonzoEraUTxO` and a helper to implement it `plutusLanguagesUsedAlonzoStAnnTx`
89
* Add `plutusScriptsWithContextStAnnTx` to `AlonzoEraUTxO` and a helper to implement it `plutusScriptsWithContextAlonzoStAnnTx`

‎eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs‎

Lines changed: 32 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -88,6 +88,9 @@ import Cardano.Ledger.MemoBytes (
8888
import Cardano.Ledger.Plutus.Language (Language (..), PlutusBinary (..), guardPlutus)
8989
import Cardano.Ledger.Shelley.TxAuxData (Metadatum)
9090
import Control.DeepSeq (NFData, deepseq)
91+
import Control.Monad (forM)
92+
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=))
93+
import Data.Foldable (toList)
9194
import Data.List (intercalate)
9295
import qualified Data.List.NonEmpty as NE
9396
import Data.Map (Map)
@@ -186,7 +189,7 @@ getAlonzoTxAuxDataScripts AlonzoTxAuxData {atadNativeScripts = timelocks, atadPl
186189
-- AlonzoTxAuxData is that it does not contain scripts with languages that are not
187190
-- supported in this era
188191
mapMaybe (fmap PlutusScript . mkBinaryPlutusScript lang) $
189-
NE.toList plutusScripts
192+
toList plutusScripts
190193
| lang <- [PlutusV1 .. eraMaxLanguage @era]
191194
, Just plutusScripts <- [Map.lookup lang plutus]
192195
]
@@ -344,6 +347,34 @@ deriving via
344347
instance
345348
NoThunks (AlonzoTxAuxData era)
346349

350+
instance
351+
( AlonzoEraScript era
352+
, ToJSON (NativeScript era)
353+
) =>
354+
ToJSON (AlonzoTxAuxData era)
355+
where
356+
toJSON AlonzoTxAuxData {atadMetadata, atadNativeScripts, atadPlutusScripts} =
357+
object
358+
[ "metadata" .= atadMetadata
359+
, "nativeScripts" .= toList atadNativeScripts
360+
, "plutusScripts" .= fmap toList atadPlutusScripts
361+
]
362+
363+
instance
364+
( AlonzoEraScript era
365+
, FromJSON (NativeScript era)
366+
) =>
367+
FromJSON (AlonzoTxAuxData era)
368+
where
369+
parseJSON = withObject "AlonzoTxAuxData" $ \o -> do
370+
metadata <- o .: "metadata"
371+
nativeScripts <- o .:? "nativeScripts" .!= mempty
372+
plutusScriptsLangMap <- o .:? "plutusScripts" .!= mempty
373+
plutusScripts <-
374+
fmap concat $ forM (Map.toList plutusScriptsLangMap) $ \(lang, plutusScripts) ->
375+
traverse (fmap PlutusScript . mkBinaryPlutusScript lang) plutusScripts
376+
pure $ mkAlonzoTxAuxData metadata $ fmap NativeScript nativeScripts <> plutusScripts
377+
347378
-- | Construct auxiliary data. Make sure not to supply plutus script versions that are not
348379
-- supported in this era, because it will result in a runtime exception. Use
349380
-- `mkAlonzoTxAuxData` instead if you need runtime safety guarantees.

‎eras/shelley/impl/CHANGELOG.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
## 1.19.0.0
44

55
* Add `generate-cbor` executable
6+
* Add `ToJSON` and `FromJSON` instances for `ShelleyTxAuxData era`
67
* Change `NoThunks` instance for `BlockTransitionError` to not check for thunks in its contents
78
* Add `NFData` constraint to `BlockTransitionError` constructor.
89
* Add `injectStakeCredentials`, `injectStakePools`, `resolveInjectionSource`, `injectInitialFundsAndStaking` to `Cardano.Ledger.Shelley.Transition`

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,7 @@ import Cardano.Ledger.MemoBytes (
4343
import Cardano.Ledger.Metadata (Metadatum (..))
4444
import Cardano.Ledger.Shelley.Era (ShelleyEra)
4545
import Control.DeepSeq (NFData)
46+
import Data.Aeson (FromJSON (..), ToJSON (..))
4647
import Data.Map.Strict (Map)
4748
import Data.Word (Word64)
4849
import GHC.Generics (Generic)
@@ -97,6 +98,12 @@ instance EraTxAuxData ShelleyEra where
9798

9899
instance EqRaw (ShelleyTxAuxData era)
99100

101+
instance Era era => ToJSON (ShelleyTxAuxData era) where
102+
toJSON (ShelleyTxAuxData m) = toJSON m
103+
104+
instance Era era => FromJSON (ShelleyTxAuxData era) where
105+
parseJSON v = ShelleyTxAuxData <$> parseJSON v
106+
100107
instance HashAnnotated (ShelleyTxAuxData era) EraIndependentTxAuxData where
101108
hashAnnotated = getMemoSafeHash
102109

‎libs/cardano-ledger-core/CHANGELOG.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,9 @@
2828
* Remove `ToCBOR` and `FromCBOR` instances for `Nonce`
2929
* Remove default implementation of `fromPlutusData` in `ToPlutusData` typeclass.
3030
* Add `modifyTxAuxData` in `Cardano.Ledger.Core`.
31+
* Add `ToJSON`, `FromJSON` and `NFData` as `EraTxAuxData` superclass constraints
32+
* Add `ToJSON` and `FromJSON` instances for `Metadatum`
33+
* Add `ToJSON` and `FromJSON` instances for `Data era` and `PlutusBinary`
3134
* Rename `kindObject` (which returned `Value`) to `kindObjectValue`
3235
* Add `kindObject :: Text -> [Pair] -> Object` returning an `Aeson.Object`
3336
* Add `NFData (Script era)`, `ToJSON (Script era)`, `FromJSON (Script era)`, `ToJSON (NativeScript era)`, and `FromJSON (NativeScript era)` as superclass constraints to `EraScript`
@@ -52,6 +55,7 @@
5255
* Modify `ToExpr` instance for `Mismatch` to display type-level `r` parameter using `Typeable`
5356
* Add `Arbitrary (NativeScript era)` and `ToExpr (NativeScript era)` constraints to `EraConstraints`
5457
* Add round-trip JSON property test for `NativeScript era` and `Script era` to the shared era spec
58+
* Add round-trip JSON property test for `TxAuxData era` to the shared era spec
5559

5660
## 1.20.0.0
5761

‎libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -465,6 +465,9 @@ class
465465
, EqRaw (TxAuxData era)
466466
, Show (TxAuxData era)
467467
, NoThunks (TxAuxData era)
468+
, NFData (TxAuxData era)
469+
, ToJSON (TxAuxData era)
470+
, FromJSON (TxAuxData era)
468471
, ToCBOR (TxAuxData era)
469472
, EncCBOR (TxAuxData era)
470473
, DecCBOR (Annotator (TxAuxData era))

‎libs/cardano-ledger-core/src/Cardano/Ledger/Metadata.hs‎

Lines changed: 47 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,11 +39,19 @@ import Cardano.Ledger.Binary (
3939
peekTokenType,
4040
)
4141
import Cardano.Ledger.Orphans ()
42+
import Control.Applicative ((<|>))
4243
import Control.DeepSeq (NFData (rnf))
4344
import Control.Monad (when)
45+
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
46+
import qualified Data.Aeson as Aeson
4447
import Data.Array.Byte (ByteArray (..))
48+
import qualified Data.ByteString as BS
49+
import qualified Data.ByteString.Base16 as B16
50+
import qualified Data.ByteString.Short as SBS
51+
import Data.MemPack.Buffer (byteArrayToShortByteString)
4552
import qualified Data.Primitive.ByteArray as Prim
4653
import qualified Data.Text as T
54+
import qualified Data.Text.Encoding as TE
4755
import qualified Data.Text.Foreign as TF
4856
import GHC.Generics (Generic)
4957
import NoThunks.Class (NoThunks (..))
@@ -73,6 +81,45 @@ instance EncCBOR Metadatum where
7381
instance DecCBOR Metadatum where
7482
decCBOR = decodeMetadatum
7583

84+
instance ToJSON Metadatum where
85+
toJSON = \case
86+
Map kvs ->
87+
Aeson.object
88+
[ "map"
89+
.= [ Aeson.object
90+
[ "k" .= toJSON k
91+
, "v" .= toJSON v
92+
]
93+
| (k, v) <- kvs
94+
]
95+
]
96+
List xs -> Aeson.object ["list" .= xs]
97+
I n -> Aeson.object ["int" .= n]
98+
B ba ->
99+
Aeson.object
100+
[ "bytes" .= TE.decodeLatin1 (B16.encode $ SBS.fromShort $ byteArrayToShortByteString ba)
101+
]
102+
S t -> Aeson.object ["string" .= t]
103+
104+
instance FromJSON Metadatum where
105+
parseJSON =
106+
Aeson.withObject "Metadatum" $ \o ->
107+
(Map <$> (o .: "map" >>= traverse parseMetadatumKeyValue))
108+
<|> (List <$> o .: "list")
109+
<|> (I <$> o .: "int")
110+
<|> ( o .: "bytes" >>= \s ->
111+
case B16.decode (TE.encodeUtf8 s) of
112+
Left e -> fail $ "Metadatum bytes: invalid hex: " <> e
113+
Right bs -> pure $ B (Prim.byteArrayFromList (BS.unpack bs))
114+
)
115+
<|> (S <$> o .: "string")
116+
where
117+
parseMetadatumKeyValue =
118+
Aeson.withObject "Metadatum Inner Map" $ \kvo -> do
119+
!k <- kvo .: "k" >>= parseJSON
120+
!v <- kvo .: "v" >>= parseJSON
121+
pure (k, v)
122+
76123
-------------------------------------------------------------------------------
77124
-- CBOR encoding and decoding
78125

‎libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs‎

Lines changed: 65 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE BangPatterns #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE DeriveAnyClass #-}
34
{-# LANGUAGE DeriveGeneric #-}
@@ -64,11 +65,18 @@ import Cardano.Ledger.MemoBytes (
6465
)
6566
import Cardano.Ledger.MemoBytes.Internal (mkMemoBytesShort)
6667
import qualified Codec.Serialise as Cborg (Serialise (..))
68+
import Control.Applicative (asum)
6769
import Control.DeepSeq (NFData)
68-
import Data.Aeson (ToJSON (..), Value (Null))
70+
import Control.Monad ((<$!>))
71+
import Data.Aeson (FromJSON (..), ToJSON (..), Value (Null), object, withObject, (.:), (.=))
72+
import qualified Data.Aeson as Aeson
73+
import Data.Aeson.Types (Parser)
74+
import qualified Data.ByteString.Base16 as BS16
6975
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
7076
import Data.Coerce (coerce)
7177
import Data.MemPack
78+
import Data.Text.Encoding (encodeUtf8)
79+
import qualified Data.Text.Encoding as Text (decodeUtf8)
7280
import Data.Typeable (Typeable)
7381
import GHC.Generics (Generic)
7482
import NoThunks.Class (NoThunks)
@@ -92,6 +100,12 @@ instance Typeable era => DecCBOR (PlutusData era) where
92100
instance Typeable era => DecCBOR (Annotator (PlutusData era)) where
93101
decCBOR = pure <$> fromPlainDecoder Cborg.decode
94102

103+
instance ToJSON (PlutusData era) where
104+
toJSON (PlutusData d) = plutusDataToJson d
105+
106+
instance FromJSON (PlutusData era) where
107+
parseJSON v = PlutusData <$> plutusDataFromJson v
108+
95109
newtype Data era = MkData (MemoBytes (PlutusData era))
96110
deriving (Eq, Generic)
97111
deriving newtype (SafeToHash, ToCBOR, NFData, DecCBOR)
@@ -117,6 +131,56 @@ instance HashAnnotated (Data era) EraIndependentData where
117131

118132
instance Typeable era => NoThunks (Data era)
119133

134+
instance ToJSON (Data era) where
135+
toJSON = toJSON . getMemoRawType
136+
137+
instance Era era => FromJSON (Data era) where
138+
parseJSON v = mkMemoizedEra @era <$> parseJSON v
139+
140+
plutusDataToJson :: PV1.Data -> Aeson.Value
141+
plutusDataToJson = \case
142+
PV1.Constr n fields ->
143+
object ["constructor" .= n, "fields" .= map plutusDataToJson fields]
144+
PV1.Map kvs ->
145+
object
146+
[ "map"
147+
.= [ object ["k" .= plutusDataToJson k, "v" .= plutusDataToJson v]
148+
| (k, v) <- kvs
149+
]
150+
]
151+
PV1.List elems ->
152+
object ["list" .= map plutusDataToJson elems]
153+
PV1.I n ->
154+
object ["int" .= n]
155+
PV1.B bs ->
156+
object ["bytes" .= Text.decodeUtf8 (BS16.encode bs)]
157+
158+
plutusDataFromJson :: Aeson.Value -> Parser PV1.Data
159+
plutusDataFromJson = withObject "Data" $ \o ->
160+
asum
161+
[ do
162+
!n <- o .: "constructor"
163+
!fields <- o .: "fields" >>= mapM plutusDataFromJson
164+
pure $ PV1.Constr n fields
165+
, do
166+
!kvs <-
167+
o .: "map"
168+
>>= mapM
169+
( withObject "MapEntry" $ \kv -> do
170+
!k <- kv .: "k" >>= plutusDataFromJson
171+
!v <- kv .: "v" >>= plutusDataFromJson
172+
pure (k, v)
173+
)
174+
pure $ PV1.Map kvs
175+
, PV1.List <$!> (o .: "list" >>= mapM plutusDataFromJson)
176+
, PV1.I <$!> o .: "int"
177+
, PV1.B <$!> (o .: "bytes" >>= parsePlutusByteStringData)
178+
]
179+
where
180+
parsePlutusByteStringData t = case BS16.decode (encodeUtf8 t) of
181+
Left e -> fail $ "bytes: invalid hex: " <> e
182+
Right bs -> pure bs
183+
120184
pattern Data :: forall era. Era era => PV1.Data -> Data era
121185
pattern Data p <- (getMemoRawType -> PlutusData p)
122186
where

0 commit comments

Comments
 (0)