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.

Author: Jimbo4350

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 (..)
@@ -112,6 +113,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
@@ -138,6 +140,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
@@ -149,8 +152,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
@@ -475,6 +479,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

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
     ]