From e45b5a9ef77b0bd32d532e5e6ddffb2752293634 Mon Sep 17 00:00:00 2001 From: Konstantinos Lambrou-Latreille Date: Tue, 19 May 2026 13:59:33 -0400 Subject: [PATCH] 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 --- eras/allegra/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Allegra/TxAuxData.hs | 27 ++++++++ eras/alonzo/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Alonzo/TxAuxData.hs | 33 +++++++++- eras/shelley/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Shelley/TxAuxData.hs | 7 ++ libs/cardano-ledger-core/CHANGELOG.md | 4 ++ .../src/Cardano/Ledger/Core.hs | 3 + .../src/Cardano/Ledger/Metadata.hs | 47 +++++++++++++ .../src/Cardano/Ledger/Plutus/Data.hs | 66 ++++++++++++++++++- .../src/Cardano/Ledger/Plutus/Language.hs | 16 ++++- .../testlib/Test/Cardano/Ledger/Era.hs | 2 + 12 files changed, 203 insertions(+), 5 deletions(-) diff --git a/eras/allegra/impl/CHANGELOG.md b/eras/allegra/impl/CHANGELOG.md index adcb44bfd0e..8ac824ed73f 100644 --- a/eras/allegra/impl/CHANGELOG.md +++ b/eras/allegra/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.10.0.0 +* Add `ToJSON` and `FromJSON` instances for `AllegraTxAuxData era` * Change `Signal` to `StAnnTx TopTx era` for: `AllegraUTXOW`, `AllegraUTXO` * Add `FromJSON` instance for `ValidityInterval` * Add `ApplyTick` instance for `AllegraEra` diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs index 3d637586a27..654c2041ca7 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs @@ -30,6 +30,7 @@ module Cardano.Ledger.Allegra.TxAuxData ( import Cardano.Ledger.Allegra.Era (AllegraEra) import Cardano.Ledger.Allegra.Scripts (AllegraEraScript) +import Cardano.Ledger.BaseTypes (KeyValuePairs (..), ToKeyValuePairs (..)) import Cardano.Ledger.Binary ( Annotator, DecCBOR (..), @@ -62,6 +63,9 @@ import Codec.CBOR.Decoding ( ), ) import Control.DeepSeq (NFData, deepseq) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Foldable as F import Data.Map.Strict (Map) import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq @@ -204,3 +208,26 @@ instance <*! Ann From <*! D (sequence <$> decCBOR) ) + +instance + (Era era, EncCBOR (NativeScript era), ToJSON (NativeScript era)) => + ToKeyValuePairs (AllegraTxAuxData era) + where + toKeyValuePairs (AllegraTxAuxData metadata nativeScripts) = + [ "metadata" .= metadata + , "nativeScripts" .= F.toList nativeScripts + ] + +deriving via + KeyValuePairs (AllegraTxAuxData era) + instance + (Era era, EncCBOR (NativeScript era), ToJSON (NativeScript era)) => ToJSON (AllegraTxAuxData era) + +instance + (Era era, EncCBOR (NativeScript era), FromJSON (NativeScript era)) => + FromJSON (AllegraTxAuxData era) + where + parseJSON = Aeson.withObject "AllegraTxAuxData" $ \o -> + AllegraTxAuxData + <$> o .: "metadata" + <*> (maybe mempty StrictSeq.fromList <$> o .:? "nativeScripts") diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 2a86e942343..6e756500dbe 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.16.0.0 +* Add `ToJSON` and `FromJSON` instances for `AlonzoTxAuxData era` * Replace `scriptsProvided` and `scriptsNeeded` in `mkScriptIntegrity` signature with `Set Language` * Add `plutusLanguagesUsedStAnnTx` to `AlonzoEraUTxO` and a helper to implement it `plutusLanguagesUsedAlonzoStAnnTx` * Add `plutusScriptsWithContextStAnnTx` to `AlonzoEraUTxO` and a helper to implement it `plutusScriptsWithContextAlonzoStAnnTx` diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs index f47cb58c241..3e24087bca9 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs @@ -88,6 +88,9 @@ import Cardano.Ledger.MemoBytes ( import Cardano.Ledger.Plutus.Language (Language (..), PlutusBinary (..), guardPlutus) import Cardano.Ledger.Shelley.TxAuxData (Metadatum) import Control.DeepSeq (NFData, deepseq) +import Control.Monad (forM) +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=)) +import Data.Foldable (toList) import Data.List (intercalate) import qualified Data.List.NonEmpty as NE import Data.Map (Map) @@ -186,7 +189,7 @@ getAlonzoTxAuxDataScripts AlonzoTxAuxData {atadNativeScripts = timelocks, atadPl -- 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 + toList plutusScripts | lang <- [PlutusV1 .. eraMaxLanguage @era] , Just plutusScripts <- [Map.lookup lang plutus] ] @@ -344,6 +347,34 @@ deriving via instance NoThunks (AlonzoTxAuxData era) +instance + ( AlonzoEraScript era + , ToJSON (NativeScript era) + ) => + ToJSON (AlonzoTxAuxData era) + where + toJSON AlonzoTxAuxData {atadMetadata, atadNativeScripts, atadPlutusScripts} = + object + [ "metadata" .= atadMetadata + , "nativeScripts" .= toList atadNativeScripts + , "plutusScripts" .= fmap toList atadPlutusScripts + ] + +instance + ( AlonzoEraScript era + , FromJSON (NativeScript era) + ) => + FromJSON (AlonzoTxAuxData era) + where + parseJSON = withObject "AlonzoTxAuxData" $ \o -> do + metadata <- o .: "metadata" + nativeScripts <- o .:? "nativeScripts" .!= mempty + plutusScriptsLangMap <- o .:? "plutusScripts" .!= mempty + plutusScripts <- + fmap concat $ forM (Map.toList plutusScriptsLangMap) $ \(lang, plutusScripts) -> + traverse (fmap PlutusScript . mkBinaryPlutusScript lang) plutusScripts + pure $ mkAlonzoTxAuxData metadata $ fmap NativeScript nativeScripts <> plutusScripts + -- | 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. diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index f93224cc219..a87578734a9 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.19.0.0 +* Add `ToJSON` and `FromJSON` instances for `ShelleyTxAuxData era` * Change `NoThunks` instance for `BlockTransitionError` to not check for thunks in its contents * Add `NFData` constraint to `BlockTransitionError` constructor. * Add `injectStakeCredentials`, `injectStakePools`, `resolveInjectionSource`, `injectInitialFundsAndStaking` to `Cardano.Ledger.Shelley.Transition` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs index ae59b905dc3..53de3444fd9 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxAuxData.hs @@ -43,6 +43,7 @@ import Cardano.Ledger.MemoBytes ( import Cardano.Ledger.Metadata (Metadatum (..)) import Cardano.Ledger.Shelley.Era (ShelleyEra) import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Map.Strict (Map) import Data.Word (Word64) import GHC.Generics (Generic) @@ -97,6 +98,12 @@ instance EraTxAuxData ShelleyEra where instance EqRaw (ShelleyTxAuxData era) +instance Era era => ToJSON (ShelleyTxAuxData era) where + toJSON (ShelleyTxAuxData m) = toJSON m + +instance Era era => FromJSON (ShelleyTxAuxData era) where + parseJSON v = ShelleyTxAuxData <$> parseJSON v + instance HashAnnotated (ShelleyTxAuxData era) EraIndependentTxAuxData where hashAnnotated = getMemoSafeHash diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 23d8871514c..3e765cc4e78 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -28,6 +28,9 @@ * Remove `ToCBOR` and `FromCBOR` instances for `Nonce` * Remove default implementation of `fromPlutusData` in `ToPlutusData` typeclass. * Add `modifyTxAuxData` in `Cardano.Ledger.Core`. +* Add `ToJSON`, `FromJSON` and `NFData` as `EraTxAuxData` superclass constraints +* Add `ToJSON` and `FromJSON` instances for `Metadatum` +* Add `ToJSON` and `FromJSON` instances for `Data era` and `PlutusBinary` * Rename `kindObject` (which returned `Value`) to `kindObjectValue` * Add `kindObject :: Text -> [Pair] -> Object` returning an `Aeson.Object` * 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 @@ * Modify `ToExpr` instance for `Mismatch` to display type-level `r` parameter using `Typeable` * Add `Arbitrary (NativeScript era)` and `ToExpr (NativeScript era)` constraints to `EraConstraints` * Add round-trip JSON property test for `NativeScript era` and `Script era` to the shared era spec +* Add round-trip JSON property test for `TxAuxData era` to the shared era spec ## 1.20.0.0 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index 6f88b06760e..4c5f163c435 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -465,6 +465,9 @@ class , EqRaw (TxAuxData era) , Show (TxAuxData era) , NoThunks (TxAuxData era) + , NFData (TxAuxData era) + , ToJSON (TxAuxData era) + , FromJSON (TxAuxData era) , ToCBOR (TxAuxData era) , EncCBOR (TxAuxData era) , DecCBOR (Annotator (TxAuxData era)) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Metadata.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Metadata.hs index 76678edb6da..9160eaae598 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Metadata.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Metadata.hs @@ -39,11 +39,19 @@ import Cardano.Ledger.Binary ( peekTokenType, ) import Cardano.Ledger.Orphans () +import Control.Applicative ((<|>)) import Control.DeepSeq (NFData (rnf)) import Control.Monad (when) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) +import qualified Data.Aeson as Aeson import Data.Array.Byte (ByteArray (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Short as SBS +import Data.MemPack.Buffer (byteArrayToShortByteString) import qualified Data.Primitive.ByteArray as Prim import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Text.Foreign as TF import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) @@ -73,6 +81,45 @@ instance EncCBOR Metadatum where instance DecCBOR Metadatum where decCBOR = decodeMetadatum +instance ToJSON Metadatum where + toJSON = \case + Map kvs -> + Aeson.object + [ "map" + .= [ Aeson.object + [ "k" .= toJSON k + , "v" .= toJSON v + ] + | (k, v) <- kvs + ] + ] + List xs -> Aeson.object ["list" .= xs] + I n -> Aeson.object ["int" .= n] + B ba -> + Aeson.object + [ "bytes" .= TE.decodeLatin1 (B16.encode $ SBS.fromShort $ byteArrayToShortByteString ba) + ] + S t -> Aeson.object ["string" .= t] + +instance FromJSON Metadatum where + parseJSON = + Aeson.withObject "Metadatum" $ \o -> + (Map <$> (o .: "map" >>= traverse parseMetadatumKeyValue)) + <|> (List <$> o .: "list") + <|> (I <$> o .: "int") + <|> ( o .: "bytes" >>= \s -> + case B16.decode (TE.encodeUtf8 s) of + Left e -> fail $ "Metadatum bytes: invalid hex: " <> e + Right bs -> pure $ B (Prim.byteArrayFromList (BS.unpack bs)) + ) + <|> (S <$> o .: "string") + where + parseMetadatumKeyValue = + Aeson.withObject "Metadatum Inner Map" $ \kvo -> do + !k <- kvo .: "k" >>= parseJSON + !v <- kvo .: "v" >>= parseJSON + pure (k, v) + ------------------------------------------------------------------------------- -- CBOR encoding and decoding diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs index 4d9d69b34c7..8d850a1d52e 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -64,11 +65,18 @@ import Cardano.Ledger.MemoBytes ( ) import Cardano.Ledger.MemoBytes.Internal (mkMemoBytesShort) import qualified Codec.Serialise as Cborg (Serialise (..)) +import Control.Applicative (asum) import Control.DeepSeq (NFData) -import Data.Aeson (ToJSON (..), Value (Null)) +import Control.Monad ((<$!>)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (Null), object, withObject, (.:), (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) +import qualified Data.ByteString.Base16 as BS16 import Data.ByteString.Short (ShortByteString, fromShort, toShort) import Data.Coerce (coerce) import Data.MemPack +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Encoding as Text (decodeUtf8) import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -92,6 +100,12 @@ instance Typeable era => DecCBOR (PlutusData era) where instance Typeable era => DecCBOR (Annotator (PlutusData era)) where decCBOR = pure <$> fromPlainDecoder Cborg.decode +instance ToJSON (PlutusData era) where + toJSON (PlutusData d) = plutusDataToJson d + +instance FromJSON (PlutusData era) where + parseJSON v = PlutusData <$> plutusDataFromJson v + newtype Data era = MkData (MemoBytes (PlutusData era)) deriving (Eq, Generic) deriving newtype (SafeToHash, ToCBOR, NFData, DecCBOR) @@ -117,6 +131,56 @@ instance HashAnnotated (Data era) EraIndependentData where instance Typeable era => NoThunks (Data era) +instance ToJSON (Data era) where + toJSON = toJSON . getMemoRawType + +instance Era era => FromJSON (Data era) where + parseJSON v = mkMemoizedEra @era <$> parseJSON v + +plutusDataToJson :: PV1.Data -> Aeson.Value +plutusDataToJson = \case + PV1.Constr n fields -> + object ["constructor" .= n, "fields" .= map plutusDataToJson fields] + PV1.Map kvs -> + object + [ "map" + .= [ object ["k" .= plutusDataToJson k, "v" .= plutusDataToJson v] + | (k, v) <- kvs + ] + ] + PV1.List elems -> + object ["list" .= map plutusDataToJson elems] + PV1.I n -> + object ["int" .= n] + PV1.B bs -> + object ["bytes" .= Text.decodeUtf8 (BS16.encode bs)] + +plutusDataFromJson :: Aeson.Value -> Parser PV1.Data +plutusDataFromJson = withObject "Data" $ \o -> + asum + [ do + !n <- o .: "constructor" + !fields <- o .: "fields" >>= mapM plutusDataFromJson + pure $ PV1.Constr n fields + , do + !kvs <- + o .: "map" + >>= mapM + ( withObject "MapEntry" $ \kv -> do + !k <- kv .: "k" >>= plutusDataFromJson + !v <- kv .: "v" >>= plutusDataFromJson + pure (k, v) + ) + pure $ PV1.Map kvs + , PV1.List <$!> (o .: "list" >>= mapM plutusDataFromJson) + , PV1.I <$!> o .: "int" + , PV1.B <$!> (o .: "bytes" >>= parsePlutusByteStringData) + ] + where + parsePlutusByteStringData t = case BS16.decode (encodeUtf8 t) of + Left e -> fail $ "bytes: invalid hex: " <> e + Right bs -> pure bs + pattern Data :: forall era. Era era => PV1.Data -> Data era pattern Data p <- (getMemoRawType -> PlutusData p) where diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs index faa047a2b5c..95665835c73 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs @@ -86,14 +86,15 @@ import Data.Aeson ( ) import Data.Aeson.Types (toJSONKeyText) import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 (encode) -import Data.ByteString.Short (ShortByteString, fromShort) +import qualified Data.ByteString.Base64 as BS64 +import Data.ByteString.Short (ShortByteString, fromShort, toShort) import Data.Either (isRight) import Data.Ix (Ix) import Data.Kind (Type) import Data.MemPack import Data.Proxy (Proxy (..)) import Data.Text (Text) +import qualified Data.Text.Encoding as T import Data.Typeable (Typeable, gcast) import Data.Word (Word8) import GHC.Generics (Generic) @@ -151,6 +152,15 @@ newtype Plutus (l :: Language) = Plutus deriving stock (Show, Generic) deriving newtype (Eq, Ord, SafeToHash, NoThunks, NFData, MemPack) +instance ToJSON PlutusBinary where + toJSON = String . T.decodeLatin1 . BS64.encode . originalBytes + +instance FromJSON PlutusBinary where + parseJSON = withText "PlutusBinary" $ \t -> + case BS64.decode (T.encodeUtf8 t) of + Left e -> fail $ "PlutusBinary: invalid hex: " <> e + Right bs -> pure . PlutusBinary $ toShort bs + plutusSLanguage :: PlutusLanguage l => proxy l -> SLanguage l plutusSLanguage _ = isLanguage @@ -207,7 +217,7 @@ instance DecCBOR (Annotator PlutusBinary) where decCBOR = pure <$> decCBOR instance Show PlutusBinary where - show = show . B64.encode . fromShort . unPlutusBinary + show = show . BS64.encode . fromShort . unPlutusBinary instance SafeToHash PlutusBinary where originalBytes (PlutusBinary binaryBlutus) = fromShort binaryBlutus diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs index cc587bd720d..6cea566fe8e 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Era.hs @@ -172,6 +172,8 @@ ledgerEraTestMain extraEraSpec = roundTripAesonProperty @(NativeScript era) prop (show $ typeRep $ Proxy @(Script era)) $ roundTripAesonProperty @(Script era) + prop (show $ typeRep $ Proxy @(TxAuxData era)) $ + roundTripAesonProperty @(TxAuxData era) describe "Era-specific spec" extraEraSpec -- | This is a helper function that uses `mkTestAccountState` to register an account.