From 20d35c6ead8fe031bc9375f3d8710a99f01a6c8c Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Thu, 9 Apr 2026 11:56:20 -0400 Subject: [PATCH 1/4] Add FromJSON instance for new experimental TxOut Add per-era FromJSON instances for the experimental TxOut type, mirroring the ToJSON structure. Pre-Alonzo eras parse address and value only; Alonzo adds datum hash support; Babbage+ adds inline datum (parsed from inlineDatumRaw with hash validation) and reference script support. Supplemental datums are deliberately unsupported as the ledger TxOut does not carry them. --- .../Tx/Internal/BodyContent/New.hs | 122 +++++++++++++++++- .../cardano-api-test/Test/Cardano/Api/Json.hs | 28 ++++ 2 files changed, 149 insertions(+), 1 deletion(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs index ccdb6005b5..a4b2f9676a 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Experimental.Tx.Internal.BodyContent.New ( TxCertificates (..) @@ -114,6 +115,7 @@ import Cardano.Api.Plutus.Internal.Script , ScriptInAnyLang (..) , ScriptLanguage (..) , fromAllegraTimelock + , toAllegraTimelock ) import Cardano.Api.Plutus.Internal.Script qualified as OldScript import Cardano.Api.Plutus.Internal.ScriptData qualified as Api @@ -140,6 +142,7 @@ import Cardano.Api.Value.Internal ) import Cardano.Binary qualified as CBOR +import Cardano.Ledger.Allegra.Scripts (Timelock) import Cardano.Ledger.Alonzo.Scripts qualified as L import Cardano.Ledger.Alonzo.Tx qualified as L import Cardano.Ledger.Alonzo.TxBody qualified as L @@ -151,8 +154,9 @@ import Cardano.Ledger.Plutus.Language (PlutusBinary (..), plutusLanguage) import Cardano.Ledger.Plutus.Language qualified as Plutus import Control.Monad -import Data.Aeson (ToJSON (..), (.=)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson +import Data.Aeson.Types (Parser) import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Short qualified as SBS import Data.Functor @@ -499,6 +503,122 @@ deriving instance (Show (TxOut era)) deriving instance (Eq (TxOut era)) +-- | Pre-Alonzo eras have no datums or reference scripts, so parsing +-- only needs address and value. +instance FromJSON (TxOut L.ShelleyEra) where + parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson + +instance FromJSON (TxOut L.AllegraEra) where + parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson + +instance FromJSON (TxOut L.MaryEra) where + parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson + +-- | Alonzo supports datum hashes but not inline datums or reference scripts. +instance FromJSON (TxOut L.AlonzoEra) where + parseJSON = Aeson.withObject "TxOut" $ \o -> do + baseTxOut <- txOutBaseParseJson o + mDatumHash <- o .:? "datumhash" + pure . TxOut $ case mDatumHash of + Nothing -> baseTxOut + Just dh -> baseTxOut & L.dataHashTxOutL .~ SJust dh + +-- | Babbage and later eras support inline datums and reference scripts. +instance FromJSON (TxOut L.BabbageEra) where + parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson + +instance FromJSON (TxOut L.ConwayEra) where + parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson + +-- | Parse the base fields (address and value) shared by all eras. +txOutBaseParseJson :: L.EraTxOut era => Aeson.Object -> Parser (L.TxOut era) +txOutBaseParseJson o = do + addr <- addrFromJson =<< o .: "address" + apiVal <- parseJSON =<< o .: "value" + let mv = toMaryValue apiVal + val <- case cast mv of + Just v -> pure v + Nothing -> case cast (L.coin mv) of + Just v -> pure v + Nothing -> fail "Unsupported value type for era" + pure $ L.mkBasicTxOut addr val + +-- | Parse a ledger 'L.Addr' from JSON. Reverse of 'addrToJson'. +addrFromJson :: Aeson.Value -> Parser L.Addr +addrFromJson = Aeson.withText "Address" $ \txt -> + case deserialiseAddress AsAddressAny txt of + Nothing -> fail "Invalid address" + Just addrAny -> pure $ case addrAny of + AddressByron (ByronAddress addr) -> L.AddrBootstrap (L.BootstrapAddress addr) + AddressShelley (ShelleyAddress nw pc scr) -> L.Addr nw pc scr + +-- | Parse a Babbage+ TxOut with datum and reference script support. +babbageOnwardsTxOutParseJson + :: forall era + . ( L.BabbageEraTxOut era + , L.NativeScript era ~ Timelock era + ) + => Aeson.Object -> Parser (TxOut era) +babbageOnwardsTxOutParseJson o = do + baseTxOut <- txOutBaseParseJson o + -- Parse datum fields + mDatumHash <- o .:? "datumhash" + mInlineDatumRaw <- o .:? "inlineDatumRaw" + mInlineDatumHash <- o .:? "inlineDatumhash" + -- Parse reference script + mRefScript <- o .:? "referenceScript" + -- Determine datum + datum <- case mInlineDatumRaw of + Just rawHex -> do + expectedHash <- case mInlineDatumHash of + Nothing -> fail "inlineDatumRaw present without inlineDatumhash" + Just h -> pure h + rawBytes <- case Base16.decode (Text.encodeUtf8 rawHex) of + Left err -> fail $ "Error decoding inlineDatumRaw hex: " <> show err + Right bs -> pure bs + binaryData <- case L.makeBinaryData (SBS.toShort rawBytes) of + Left err -> fail $ "Error decoding inlineDatumRaw CBOR: " <> err + Right bd -> pure bd + when (L.hashBinaryData binaryData /= expectedHash) $ + fail "Inline datum hash does not match inlineDatumRaw" + pure $ L.Datum binaryData + Nothing -> case mDatumHash of + Just dh -> pure $ L.DatumHash dh + Nothing -> pure L.NoDatum + -- Determine reference script + refScript <- case mRefScript of + Nothing -> pure SNothing + Just script -> SJust <$> scriptInAnyLangToLedgerScript script + -- Construct TxOut + pure . TxOut $ + baseTxOut + & L.datumTxOutL .~ datum + & L.referenceScriptTxOutL .~ refScript + +-- | Convert a 'ScriptInAnyLang' to a ledger 'L.Script'. Reverse of 'ledgerScriptToScriptInAnyLang'. +scriptInAnyLangToLedgerScript + :: forall era + . ( L.AlonzoEraScript era + , L.NativeScript era ~ Timelock era + ) + => ScriptInAnyLang -> Parser (L.Script era) +scriptInAnyLangToLedgerScript (ScriptInAnyLang lang script) = + case (lang, script) of + (SimpleScriptLanguage, OldScript.SimpleScript ss) -> + pure $ L.fromNativeScript (toAllegraTimelock ss) + (PlutusScriptLanguage PlutusScriptV1, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) -> + L.fromPlutusScript + <$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV1) + (PlutusScriptLanguage PlutusScriptV2, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) -> + L.fromPlutusScript + <$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV2) + (PlutusScriptLanguage PlutusScriptV3, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) -> + L.fromPlutusScript + <$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV3) + (PlutusScriptLanguage PlutusScriptV4, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) -> + L.fromPlutusScript + <$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV4) + data Datum ctx era where TxOutDatumHash :: L.DataHash diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index 6593fd9d9f..f8f367b72d 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs @@ -93,6 +93,33 @@ go sbe = do newTxOut = Exp.TxOut ledgerTxOut toJSON oldTxOut === toJSON newTxOut +-- | Verify that the new experimental 'TxOut' round-trips through JSON +-- (encode then decode) for all Shelley-based eras. +prop_new_txout_json_roundtrip :: Property +prop_new_txout_json_roundtrip = H.property $ do + AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound .. maxBound] + case sbe of + ShelleyBasedEraShelley -> goRoundtrip sbe + ShelleyBasedEraAllegra -> goRoundtrip sbe + ShelleyBasedEraMary -> goRoundtrip sbe + ShelleyBasedEraAlonzo -> goRoundtrip sbe + ShelleyBasedEraBabbage -> goRoundtrip sbe + ShelleyBasedEraConway -> goRoundtrip sbe + ShelleyBasedEraDijkstra -> pure () + +goRoundtrip + :: ( L.EraTxOut (ShelleyLedgerEra era) + , ToJSON (Exp.TxOut (ShelleyLedgerEra era)) + , FromJSON (Exp.TxOut (ShelleyLedgerEra era)) + ) + => ShelleyBasedEra era + -> H.PropertyT IO () +goRoundtrip sbe = do + oldTxOut <- forAll $ genTxOutUTxOContext sbe + let ledgerTxOut = toShelleyTxOut sbe oldTxOut + newTxOut = Exp.TxOut ledgerTxOut + tripping newTxOut encode eitherDecode + tests :: TestTree tests = testGroup @@ -106,4 +133,5 @@ tests = , testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json , testProperty "json roundtrip praos nonce" prop_roundtrip_praos_nonce_JSON , testProperty "new TxOut ToJSON matches legacy" prop_new_txout_json_matches_legacy + , testProperty "new TxOut JSON roundtrip" prop_new_txout_json_roundtrip ] From a90ce7555af7ad4b02e23af6bb27faf233b0bb96 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 13 Apr 2026 14:51:29 -0400 Subject: [PATCH 2/4] Extract maryValueToEraValue helper and document cast usage Extract the cast-based value conversion from txOutBaseParseJson into a standalone documented helper. The ledger's Value type family resolves to Coin for Shelley/Allegra and MaryValue for Mary onwards, requiring a runtime type check via Data.Typeable.cast to bridge the gap. --- .../Tx/Internal/BodyContent/New.hs | 26 ++++++++++++++----- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs index a4b2f9676a..6ba166796b 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs @@ -168,6 +168,7 @@ import Data.Map.Strict qualified as Map import Data.Maybe import Data.OSet.Strict (OSet) import Data.OSet.Strict qualified as OSet +import Data.Proxy (Proxy (..)) import Data.Sequence.Strict qualified as Seq import Data.Set (Set) import Data.Set qualified as Set @@ -531,18 +532,29 @@ instance FromJSON (TxOut L.ConwayEra) where parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson -- | Parse the base fields (address and value) shared by all eras. -txOutBaseParseJson :: L.EraTxOut era => Aeson.Object -> Parser (L.TxOut era) +txOutBaseParseJson :: forall era. L.EraTxOut era => Aeson.Object -> Parser (L.TxOut era) txOutBaseParseJson o = do addr <- addrFromJson =<< o .: "address" apiVal <- parseJSON =<< o .: "value" - let mv = toMaryValue apiVal - val <- case cast mv of - Just v -> pure v - Nothing -> case cast (L.coin mv) of - Just v -> pure v - Nothing -> fail "Unsupported value type for era" + val <- maryValueToEraValue (Proxy @era) $ toMaryValue apiVal pure $ L.mkBasicTxOut addr val +-- | Convert a 'MaryValue' to the era-specific @'L.Value' era@ using runtime type +-- checks via 'Data.Typeable.cast'. +-- +-- The ledger's @Value@ type family resolves to different concrete types per era: +-- 'Coin' for Shelley\/Allegra and 'MaryValue' for Mary onwards. Since 'MaryValue' +-- subsumes 'Coin' (it separates lovelace from multi-asset), we can always produce +-- the correct era type: first try casting the 'MaryValue' directly (succeeds in +-- Mary+), then fall back to extracting the 'Coin' component (succeeds in +-- Shelley\/Allegra). +maryValueToEraValue :: L.EraTxOut era => Proxy era -> L.MaryValue -> Parser (L.Value era) +maryValueToEraValue _proxy mv = case cast mv of + Just v -> pure v + Nothing -> case cast (L.coin mv) of + Just v -> pure v + Nothing -> fail "Unsupported value type for era" + -- | Parse a ledger 'L.Addr' from JSON. Reverse of 'addrToJson'. addrFromJson :: Aeson.Value -> Parser L.Addr addrFromJson = Aeson.withText "Address" $ \txt -> From 417f92eb68148fb1b7d9250372214da41c32c846 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 17 Apr 2026 15:51:05 -0400 Subject: [PATCH 3/4] Collapse datum and reference script field helpers into one function Replace the three separate where-bound helpers (datumFields, inlineDatumFields, refScriptFields) with a single top-level datumAndRefScriptFields function. Simplifies alonzoOnwardsTxOutToJson and documents the per-era field layout in one place. --- .../Tx/Internal/BodyContent/New.hs | 70 ++++++++++--------- 1 file changed, 36 insertions(+), 34 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs index 6ba166796b..0681a1c971 100644 --- a/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs +++ b/cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs @@ -156,7 +156,7 @@ import Cardano.Ledger.Plutus.Language qualified as Plutus import Control.Monad import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson -import Data.Aeson.Types (Parser) +import Data.Aeson.Types (Pair, Parser) import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Short qualified as SBS import Data.Functor @@ -415,42 +415,44 @@ alonzoOnwardsTxOutToJson (TxOut o) = [ "address" .= addrToJson (o ^. L.addrTxOutL) , "value" .= valueToJson (o ^. L.valueTxOutL) ] - <> datumFields mDatum - <> inlineDatumFields isBabbagePlus mDatum - <> refScriptFields mRefScript + <> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG) + +-- | Emit the datum, inline-datum, and reference-script JSON fields appropriate +-- for the era. Pre-Alonzo emits nothing; Alonzo emits @datumhash@ and @datum@; +-- Babbage+ additionally emits @inlineDatum@, @inlineDatumRaw@, @inlineDatumhash@ +-- and @referenceScript@. +datumAndRefScriptFields + :: L.AlonzoEraScript era + => Maybe (L.Datum era) + -> Maybe (Maybe (L.Script era)) + -> [Pair] +datumAndRefScriptFields mDatum mRefScript = + datumFields <> inlineDatumFields <> refScriptFields where - mDatum = o ^. L.datumTxOutG - mRefScript = o ^. L.referenceScriptTxOutG isBabbagePlus = isJust mRefScript - datumFields Nothing = [] - datumFields (Just L.NoDatum) = - ["datumhash" .= Aeson.Null, "datum" .= Aeson.Null] - datumFields (Just (L.DatumHash dh)) = - ["datumhash" .= dh, "datum" .= Aeson.Null] - datumFields (Just (L.Datum _)) = - ["datum" .= Aeson.Null] - - inlineDatumFields _ (Just (L.Datum bd)) = - let hsd = Api.fromAlonzoData (L.binaryDataToData bd) - in [ "inlineDatumhash" .= L.hashBinaryData bd - , "inlineDatum" .= Api.scriptDataToJsonDetailedSchema hsd - , "inlineDatumRaw" - .= ( Aeson.String - . Text.decodeUtf8 - . Base16.encode - . serialiseToCBOR - $ hsd - ) - ] - inlineDatumFields True _ = - ["inlineDatum" .= Aeson.Null, "inlineDatumRaw" .= Aeson.Null] - inlineDatumFields _ _ = [] - - refScriptFields Nothing = [] - refScriptFields (Just Nothing) = ["referenceScript" .= Aeson.Null] - refScriptFields (Just (Just script)) = - ["referenceScript" .= ledgerScriptToScriptInAnyLang script] + datumFields = case mDatum of + Nothing -> [] + Just L.NoDatum -> ["datumhash" .= Aeson.Null, "datum" .= Aeson.Null] + Just (L.DatumHash dh) -> ["datumhash" .= dh, "datum" .= Aeson.Null] + Just (L.Datum _) -> ["datum" .= Aeson.Null] + + inlineDatumFields = case mDatum of + Just (L.Datum bd) -> + let hsd = Api.fromAlonzoData (L.binaryDataToData bd) + in [ "inlineDatumhash" .= L.hashBinaryData bd + , "inlineDatum" .= Api.scriptDataToJsonDetailedSchema hsd + , "inlineDatumRaw" + .= (Aeson.String . Text.decodeUtf8 . Base16.encode . serialiseToCBOR $ hsd) + ] + _ + | isBabbagePlus -> ["inlineDatum" .= Aeson.Null, "inlineDatumRaw" .= Aeson.Null] + | otherwise -> [] + + refScriptFields = case mRefScript of + Nothing -> [] + Just Nothing -> ["referenceScript" .= Aeson.Null] + Just (Just script) -> ["referenceScript" .= ledgerScriptToScriptInAnyLang script] -- | Render just the base fields (address and value) shared by all eras. txOutBaseJson :: L.EraTxOut era => L.TxOut era -> Aeson.Value From 9734a72c12bb008a84a06d463a9e17524d9cc6de Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 27 Apr 2026 16:07:31 -0400 Subject: [PATCH 4/4] Add changelog fragment for experimental TxOut JSON instances --- .../20260417_cardano_api_experimental_txout_json.yml | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 .changes/20260417_cardano_api_experimental_txout_json.yml diff --git a/.changes/20260417_cardano_api_experimental_txout_json.yml b/.changes/20260417_cardano_api_experimental_txout_json.yml new file mode 100644 index 0000000000..e7fa7223e8 --- /dev/null +++ b/.changes/20260417_cardano_api_experimental_txout_json.yml @@ -0,0 +1,9 @@ +project: cardano-api +pr: 1179 +kind: + - feature +description: | + Add per-era ToJSON and FromJSON instances for the experimental TxOut + type. Pre-Alonzo eras serialise address and value; Alonzo adds datum + hash; Babbage+ adds inline datum (with hex-encoded CBOR) and reference + script support.