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. 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..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 @@ -9,6 +9,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Cardano.Api.Experimental.Tx.Internal.BodyContent.New ( TxCertificates (..) @@ -73,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 @@ -101,13 +103,14 @@ 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 (..) , ScriptInAnyLang (..) , ScriptLanguage (..) , fromAllegraTimelock + , toAllegraTimelock ) import Cardano.Api.Plutus.Internal.Script qualified as OldScript import Cardano.Api.Plutus.Internal.ScriptData qualified as Api @@ -125,13 +128,13 @@ import Cardano.Api.Value.Internal ( PolicyAssets , PolicyId , Value - , fromMaryValue - , lovelaceToValue + , fromLedgerValue , policyAssetsToValue , toMaryValue ) 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 (Pair, 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) @@ -158,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 @@ -369,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 @@ -387,63 +386,70 @@ 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) - ] - <> datumFields mDatum - <> inlineDatumFields isBabbagePlus mDatum - <> refScriptFields mRefScript + 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@; +-- 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 -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). @@ -451,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 @@ -485,10 +484,144 @@ 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 +instance FromJSON (TxOut L.ShelleyEra) where + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraShelley) + +instance FromJSON (TxOut L.AllegraEra) where + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraAllegra) + +instance FromJSON (TxOut L.MaryEra) where + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraMary) + +instance FromJSON (TxOut L.AlonzoEra) where + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraAlonzo) + +instance FromJSON (TxOut L.BabbageEra) where + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraBabbage) + +instance FromJSON (TxOut L.ConwayEra) where + parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraConway) + +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 + 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 +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 + ) + => L.TxOut era -> Aeson.Object -> Parser (TxOut era) +babbageOnwardsTxOutParseJson baseTxOut o = do + -- 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 <- + 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 $ + mconcat + [ "babbageOnwardsTxOutParseJson: inline datum hash mismatch: " + , "expected " + , show expectedHash + , ", got " + , show (L.hashBinaryData binaryData) + ] + pure $ L.Datum binaryData + Nothing -> do + when (isJust mInlineDatumHash) $ + fail "babbageOnwardsTxOutParseJson: inlineDatumhash present without inlineDatumRaw" + pure $ maybe L.NoDatum L.DatumHash mDatumHash + -- Determine reference script + refScript <- fmap L.maybeToStrictMaybe $ forM mRefScript scriptInAnyLangToLedgerScript + -- Construct TxOut + pure . TxOut $ + baseTxOut + & L.datumTxOutL .~ datum + & L.referenceScriptTxOutL .~ refScript + 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..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 @@ -93,6 +93,34 @@ 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 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] + case sbe of + ShelleyBasedEraShelley -> goRoundtrip sbe + ShelleyBasedEraAllegra -> goRoundtrip sbe + ShelleyBasedEraMary -> goRoundtrip sbe + ShelleyBasedEraAlonzo -> goRoundtrip sbe + ShelleyBasedEraBabbage -> goRoundtrip sbe + ShelleyBasedEraConway -> goRoundtrip sbe + ShelleyBasedEraDijkstra -> pure () -- shelleyBasedEraConstraints not yet implemented + +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 +134,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 ]