From 2ecf90c3c30339eeb29d186088456a74c1722c62 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 | 128 +++++++++++++++++- .../cardano-api-test/Test/Cardano/Api/Json.hs | 28 ++++ 2 files changed, 155 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 281a68ea50..05aaa7da5d 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 (..) @@ -108,6 +109,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 @@ -132,6 +134,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 @@ -142,9 +145,11 @@ 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 import Data.List qualified as List import Data.Map.Ordered.Strict (OMap) @@ -489,6 +494,127 @@ 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 "txOutBaseParseJson: value is unsupported for this 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 $ "addrFromJson: invalid address: " <> show txt + 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 "babbageOnwardsTxOutParseJson: inlineDatumRaw present without inlineDatumhash" + Just h -> pure h + rawBytes <- case Base16.decode (Text.encodeUtf8 rawHex) of + Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to hex-decode inlineDatumRaw: " <> show err + Right bs -> pure bs + binaryData <- case L.makeBinaryData (SBS.toShort rawBytes) of + Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to CBOR-decode inlineDatumRaw: " <> err + Right bd -> pure bd + when (L.hashBinaryData binaryData /= expectedHash) $ + fail $ + "babbageOnwardsTxOutParseJson: inline datum hash mismatch: " + <> "expected " + <> show expectedHash + <> ", got " + <> show (L.hashBinaryData binaryData) + 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 $ Ledger.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 03260f3be5914dab36406f813a75d8da674bea08 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 20 Apr 2026 09:48:15 -0400 Subject: [PATCH 2/4] Add changelog fragment for FromJSON TxOut --- .../20260420_cardano_api_fromjson_experimental_txout.yml | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 .changes/20260420_cardano_api_fromjson_experimental_txout.yml diff --git a/.changes/20260420_cardano_api_fromjson_experimental_txout.yml b/.changes/20260420_cardano_api_fromjson_experimental_txout.yml new file mode 100644 index 0000000000..a89215aff1 --- /dev/null +++ b/.changes/20260420_cardano_api_fromjson_experimental_txout.yml @@ -0,0 +1,6 @@ +project: cardano-api +pr: 1179 +kind: + - feature +description: | + Add FromJSON instances for the new experimental TxOut type, matching the JSON format produced by the corresponding ToJSON instances. Inline datums are parsed from inlineDatumRaw with hash validation against inlineDatumhash. Reference scripts are parsed via the existing FromJSON ScriptInAnyLang instance and converted to ledger scripts. Supplemental datums are deliberately unsupported since the ledger TxOut does not carry them. From 6651c3e18a2d3c7a139a9f2ada4460005750a1df 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 05aaa7da5d..58a36e4a0b 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 @@ -147,7 +147,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 @@ -405,42 +405,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 abf58f2f7e1c9f2e0f19b3473f970a27bb335c53 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Fri, 26 Jun 2026 18:27:32 -0400 Subject: [PATCH 4/4] Address review feedback on experimental TxOut JSON instances Replace cast-based value dispatch with ShelleyBasedEra era dispatch, removing all uses of Data.Typeable.cast. Use failEitherWith for hex/CBOR decode errors, maybe for NoDatum/DatumHash, forM + maybeToStrictMaybe for reference script, and mconcat for the hash mismatch error message. Add multi-asset guard for pre-Mary eras. Move scriptInAnyLangToLedgerScript next to its reverse. Fix test Haddock and add inline note for Dijkstra skip. --- .../Tx/Internal/BodyContent/New.hs | 217 +++++++++--------- .../cardano-api-test/Test/Cardano/Api/Json.hs | 5 +- 2 files changed, 114 insertions(+), 108 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 58a36e4a0b..dc36e6bdf0 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 @@ -74,6 +74,7 @@ module Cardano.Api.Experimental.Tx.Internal.BodyContent.New where import Cardano.Api.Address +import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) import Cardano.Api.Error import Cardano.Api.Experimental.AnyScriptWitness import Cardano.Api.Experimental.Certificate qualified as Exp @@ -102,7 +103,7 @@ import Cardano.Api.Governance.Internal.Action.VotingProcedure import Cardano.Api.Key.Internal import Cardano.Api.Ledger.Internal.Reexport (StrictMaybe (..)) import Cardano.Api.Ledger.Internal.Reexport qualified as L -import Cardano.Api.Monad.Error (liftMaybe) +import Cardano.Api.Monad.Error (failEitherWith, liftMaybe) import Cardano.Api.Plutus.Internal.Script ( PlutusScript (..) , PlutusScriptVersion (..) @@ -127,8 +128,7 @@ import Cardano.Api.Value.Internal ( PolicyAssets , PolicyId , Value - , fromMaryValue - , lovelaceToValue + , fromLedgerValue , policyAssetsToValue , toMaryValue ) @@ -163,7 +163,6 @@ import Data.Sequence.Strict qualified as Seq import Data.Set (Set) import Data.Set qualified as Set import Data.Text.Encoding qualified as Text -import Data.Typeable (cast) import GHC.Exts (IsList (..)) import Lens.Micro @@ -374,16 +373,11 @@ eraSpecificLedgerTxBody era ledgerbody bc = data TxOut era where TxOut :: L.EraTxOut era => L.TxOut era -> TxOut era --- | Pre-Alonzo eras have no datums or reference scripts, so the JSON --- output is just address and value. -instance ToJSON (TxOut L.ShelleyEra) where - toJSON (TxOut o) = txOutBaseJson o +instance ToJSON (TxOut L.ShelleyEra) where toJSON = txOutToJson ShelleyBasedEraShelley -instance ToJSON (TxOut L.AllegraEra) where - toJSON (TxOut o) = txOutBaseJson o +instance ToJSON (TxOut L.AllegraEra) where toJSON = txOutToJson ShelleyBasedEraAllegra -instance ToJSON (TxOut L.MaryEra) where - toJSON (TxOut o) = txOutBaseJson o +instance ToJSON (TxOut L.MaryEra) where toJSON = txOutToJson ShelleyBasedEraMary -- | Note: Unlike the legacy API's @TxOut@, this instance does not render -- supplemental datums. At the ledger level, a supplemental datum is not @@ -392,20 +386,25 @@ instance ToJSON (TxOut L.MaryEra) where -- datum into @TxOut@ for convenience, but since this type wraps the -- ledger's @TxOut@ directly, supplemental datums are indistinguishable -- from hash-only datums here. -instance ToJSON (TxOut L.AlonzoEra) where toJSON = alonzoOnwardsTxOutToJson +instance ToJSON (TxOut L.AlonzoEra) where toJSON = txOutToJson ShelleyBasedEraAlonzo -instance ToJSON (TxOut L.BabbageEra) where toJSON = alonzoOnwardsTxOutToJson +instance ToJSON (TxOut L.BabbageEra) where toJSON = txOutToJson ShelleyBasedEraBabbage -instance ToJSON (TxOut L.ConwayEra) where toJSON = alonzoOnwardsTxOutToJson +instance ToJSON (TxOut L.ConwayEra) where toJSON = txOutToJson ShelleyBasedEraConway -alonzoOnwardsTxOutToJson - :: (L.AnyEraTxOut era, L.AlonzoEraScript era) => TxOut era -> Aeson.Value -alonzoOnwardsTxOutToJson (TxOut o) = +txOutToJson :: ShelleyBasedEra era -> TxOut (ShelleyLedgerEra era) -> Aeson.Value +txOutToJson sbe (TxOut o) = Aeson.object $ - [ "address" .= addrToJson (o ^. L.addrTxOutL) - , "value" .= valueToJson (o ^. L.valueTxOutL) - ] - <> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG) + txOutBaseJsonFields sbe o <> alonzoOnwardsFields + where + alonzoOnwardsFields = case sbe of + ShelleyBasedEraShelley -> [] + ShelleyBasedEraAllegra -> [] + ShelleyBasedEraMary -> [] + ShelleyBasedEraAlonzo -> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG) + ShelleyBasedEraBabbage -> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG) + ShelleyBasedEraConway -> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG) + ShelleyBasedEraDijkstra -> 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@; @@ -445,12 +444,12 @@ datumAndRefScriptFields mDatum mRefScript = 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 -txOutBaseJson o = - Aeson.object - [ "address" .= addrToJson (o ^. L.addrTxOutL) - , "value" .= valueToJson (o ^. L.valueTxOutL) - ] +txOutBaseJsonFields + :: L.EraTxOut (ShelleyLedgerEra era) => ShelleyBasedEra era -> L.TxOut (ShelleyLedgerEra era) -> [Pair] +txOutBaseJsonFields sbe o = + [ "address" .= addrToJson (o ^. L.addrTxOutL) + , "value" .= fromLedgerValue sbe (o ^. L.valueTxOutL) + ] -- | Convert a ledger 'L.Addr' to JSON using the same format as the legacy API -- (bech32 for Shelley addresses, base58 for Byron addresses). @@ -458,13 +457,6 @@ addrToJson :: L.Addr -> Aeson.Value addrToJson (L.Addr nw pc scr) = toJSON (ShelleyAddress nw pc scr) addrToJson (L.AddrBootstrap (L.BootstrapAddress addr)) = toJSON (ByronAddress addr) --- | Convert a ledger value to JSON using the cardano-api 'Value' format. --- Uses 'Typeable' to detect 'MaryValue' (multi-asset) vs 'Coin' (ada-only). -valueToJson :: L.Val v => v -> Aeson.Value -valueToJson v = case cast v of - Just (mv :: L.MaryValue) -> toJSON (fromMaryValue mv) - Nothing -> toJSON (lovelaceToValue (L.coin v)) - -- | Convert a ledger 'Script' to a cardano-api 'ScriptInAnyLang' without -- per-era pattern matching, using 'AlonzoEraScript' methods. ledgerScriptToScriptInAnyLang @@ -492,49 +484,82 @@ ledgerScriptToScriptInAnyLang script = OldScript.PlutusScript PlutusScriptV4 (PlutusScriptSerialised sbs) Nothing -> error "ledgerScriptToScriptInAnyLang: script is neither native nor Plutus" +-- | 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 $ Ledger.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) + 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 + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraShelley) instance FromJSON (TxOut L.AllegraEra) where - parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraAllegra) instance FromJSON (TxOut L.MaryEra) where - parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraMary) --- | 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. + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraAlonzo) + instance FromJSON (TxOut L.BabbageEra) where - parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraBabbage) instance FromJSON (TxOut L.ConwayEra) where - parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraConway) --- | Parse the base fields (address and value) shared by all eras. -txOutBaseParseJson :: L.EraTxOut era => Aeson.Object -> Parser (L.TxOut era) -txOutBaseParseJson o = do +txOutParseJson + :: ShelleyBasedEra era -> Aeson.Object -> Parser (TxOut (ShelleyLedgerEra era)) +txOutParseJson sbe 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 "txOutBaseParseJson: value is unsupported for this era" - pure $ L.mkBasicTxOut addr val + case sbe of + ShelleyBasedEraShelley -> do + let L.MaryValue _ ma = mv + unless (ma == mempty) $ + fail "txOutParseJson: ada-only era output cannot carry a multi-asset value" + pure . TxOut $ L.mkBasicTxOut addr (L.coin mv) + ShelleyBasedEraAllegra -> do + let L.MaryValue _ ma = mv + unless (ma == mempty) $ + fail "txOutParseJson: ada-only era output cannot carry a multi-asset value" + pure . TxOut $ L.mkBasicTxOut addr (L.coin mv) + ShelleyBasedEraMary -> pure . TxOut $ L.mkBasicTxOut addr mv + ShelleyBasedEraAlonzo -> do + let base = L.mkBasicTxOut addr mv + mDatumHash <- o .:? "datumhash" + pure . TxOut $ case mDatumHash of + Nothing -> base + Just dh -> base & L.dataHashTxOutL .~ SJust dh + ShelleyBasedEraBabbage -> + babbageOnwardsTxOutParseJson (L.mkBasicTxOut addr mv :: L.TxOut L.BabbageEra) o + ShelleyBasedEraConway -> + babbageOnwardsTxOutParseJson (L.mkBasicTxOut addr mv :: L.TxOut L.ConwayEra) o + ShelleyBasedEraDijkstra -> error "TODO Dijkstra: txOutParseJson: era not supported" -- | Parse a ledger 'L.Addr' from JSON. Reverse of 'addrToJson'. addrFromJson :: Aeson.Value -> Parser L.Addr @@ -551,9 +576,8 @@ babbageOnwardsTxOutParseJson . ( L.BabbageEraTxOut era , L.NativeScript era ~ Timelock era ) - => Aeson.Object -> Parser (TxOut era) -babbageOnwardsTxOutParseJson o = do - baseTxOut <- txOutBaseParseJson o + => L.TxOut era -> Aeson.Object -> Parser (TxOut era) +babbageOnwardsTxOutParseJson baseTxOut o = do -- Parse datum fields mDatumHash <- o .:? "datumhash" mInlineDatumRaw <- o .:? "inlineDatumRaw" @@ -563,60 +587,41 @@ babbageOnwardsTxOutParseJson o = do -- Determine datum datum <- case mInlineDatumRaw of Just rawHex -> do - expectedHash <- case mInlineDatumHash of - Nothing -> fail "babbageOnwardsTxOutParseJson: inlineDatumRaw present without inlineDatumhash" - Just h -> pure h - rawBytes <- case Base16.decode (Text.encodeUtf8 rawHex) of - Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to hex-decode inlineDatumRaw: " <> show err - Right bs -> pure bs - binaryData <- case L.makeBinaryData (SBS.toShort rawBytes) of - Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to CBOR-decode inlineDatumRaw: " <> err - Right bd -> pure bd + expectedHash <- + maybe + (fail "babbageOnwardsTxOutParseJson: inlineDatumRaw present without inlineDatumhash") + pure + mInlineDatumHash + rawBytes <- + failEitherWith + (("babbageOnwardsTxOutParseJson: failed to hex-decode inlineDatumRaw: " <>) . show) + $ Base16.decode (Text.encodeUtf8 rawHex) + binaryData <- + failEitherWith + ("babbageOnwardsTxOutParseJson: failed to CBOR-decode inlineDatumRaw: " <>) + $ L.makeBinaryData (SBS.toShort rawBytes) when (L.hashBinaryData binaryData /= expectedHash) $ fail $ - "babbageOnwardsTxOutParseJson: inline datum hash mismatch: " - <> "expected " - <> show expectedHash - <> ", got " - <> show (L.hashBinaryData binaryData) + mconcat + [ "babbageOnwardsTxOutParseJson: inline datum hash mismatch: " + , "expected " + , show expectedHash + , ", got " + , show (L.hashBinaryData binaryData) + ] pure $ L.Datum binaryData - Nothing -> case mDatumHash of - Just dh -> pure $ L.DatumHash dh - Nothing -> pure L.NoDatum + Nothing -> do + when (isJust mInlineDatumHash) $ + fail "babbageOnwardsTxOutParseJson: inlineDatumhash present without inlineDatumRaw" + pure $ maybe L.NoDatum L.DatumHash mDatumHash -- Determine reference script - refScript <- case mRefScript of - Nothing -> pure SNothing - Just script -> SJust <$> scriptInAnyLangToLedgerScript script + refScript <- fmap L.maybeToStrictMaybe $ forM mRefScript scriptInAnyLangToLedgerScript -- 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 $ Ledger.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 f8f367b72d..b8b9667345 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 @@ -94,7 +94,8 @@ go sbe = do toJSON oldTxOut === toJSON newTxOut -- | Verify that the new experimental 'TxOut' round-trips through JSON --- (encode then decode) for all Shelley-based eras. +-- (encode then decode) for all Shelley-based eras except Dijkstra, for which +-- 'shelleyBasedEraConstraints' is not yet implemented. prop_new_txout_json_roundtrip :: Property prop_new_txout_json_roundtrip = H.property $ do AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound .. maxBound] @@ -105,7 +106,7 @@ prop_new_txout_json_roundtrip = H.property $ do ShelleyBasedEraAlonzo -> goRoundtrip sbe ShelleyBasedEraBabbage -> goRoundtrip sbe ShelleyBasedEraConway -> goRoundtrip sbe - ShelleyBasedEraDijkstra -> pure () + ShelleyBasedEraDijkstra -> pure () -- shelleyBasedEraConstraints not yet implemented goRoundtrip :: ( L.EraTxOut (ShelleyLedgerEra era)