Skip to content

Commit 03f9f6a

Browse files
Jimbo4350Jimbo4350
committed
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.
1 parent 5ef342e commit 03f9f6a

2 files changed

Lines changed: 155 additions & 1 deletion

File tree

  • cardano-api
    • src/Cardano/Api/Experimental/Tx/Internal/BodyContent
    • test/cardano-api-test/Test/Cardano/Api

‎cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs‎

Lines changed: 127 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@
99
{-# LANGUAGE TupleSections #-}
1010
{-# LANGUAGE TypeApplications #-}
1111
{-# LANGUAGE TypeFamilies #-}
12+
{-# LANGUAGE TypeOperators #-}
1213

1314
module Cardano.Api.Experimental.Tx.Internal.BodyContent.New
1415
( TxCertificates (..)
@@ -108,6 +109,7 @@ import Cardano.Api.Plutus.Internal.Script
108109
, ScriptInAnyLang (..)
109110
, ScriptLanguage (..)
110111
, fromAllegraTimelock
112+
, toAllegraTimelock
111113
)
112114
import Cardano.Api.Plutus.Internal.Script qualified as OldScript
113115
import Cardano.Api.Plutus.Internal.ScriptData qualified as Api
@@ -132,6 +134,7 @@ import Cardano.Api.Value.Internal
132134
)
133135

134136
import Cardano.Binary qualified as CBOR
137+
import Cardano.Ledger.Allegra.Scripts (Timelock)
135138
import Cardano.Ledger.Alonzo.Scripts qualified as L
136139
import Cardano.Ledger.Alonzo.Tx qualified as L
137140
import Cardano.Ledger.Alonzo.TxBody qualified as L
@@ -142,9 +145,11 @@ import Cardano.Ledger.Plutus.Language (PlutusBinary (..), plutusLanguage)
142145
import Cardano.Ledger.Plutus.Language qualified as Plutus
143146

144147
import Control.Monad
145-
import Data.Aeson (ToJSON (..), (.=))
148+
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
146149
import Data.Aeson qualified as Aeson
150+
import Data.Aeson.Types (Parser)
147151
import Data.ByteString.Base16 qualified as Base16
152+
import Data.ByteString.Short qualified as SBS
148153
import Data.Functor
149154
import Data.List qualified as List
150155
import Data.Map.Ordered.Strict (OMap)
@@ -489,6 +494,127 @@ deriving instance (Show (TxOut era))
489494

490495
deriving instance (Eq (TxOut era))
491496

497+
-- | Pre-Alonzo eras have no datums or reference scripts, so parsing
498+
-- only needs address and value.
499+
instance FromJSON (TxOut L.ShelleyEra) where
500+
parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson
501+
502+
instance FromJSON (TxOut L.AllegraEra) where
503+
parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson
504+
505+
instance FromJSON (TxOut L.MaryEra) where
506+
parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson
507+
508+
-- | Alonzo supports datum hashes but not inline datums or reference scripts.
509+
instance FromJSON (TxOut L.AlonzoEra) where
510+
parseJSON = Aeson.withObject "TxOut" $ \o -> do
511+
baseTxOut <- txOutBaseParseJson o
512+
mDatumHash <- o .:? "datumhash"
513+
pure . TxOut $ case mDatumHash of
514+
Nothing -> baseTxOut
515+
Just dh -> baseTxOut & L.dataHashTxOutL .~ SJust dh
516+
517+
-- | Babbage and later eras support inline datums and reference scripts.
518+
instance FromJSON (TxOut L.BabbageEra) where
519+
parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson
520+
521+
instance FromJSON (TxOut L.ConwayEra) where
522+
parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson
523+
524+
-- | Parse the base fields (address and value) shared by all eras.
525+
txOutBaseParseJson :: L.EraTxOut era => Aeson.Object -> Parser (L.TxOut era)
526+
txOutBaseParseJson o = do
527+
addr <- addrFromJson =<< o .: "address"
528+
apiVal <- parseJSON =<< o .: "value"
529+
let mv = toMaryValue apiVal
530+
val <- case cast mv of
531+
Just v -> pure v
532+
Nothing -> case cast (L.coin mv) of
533+
Just v -> pure v
534+
Nothing -> fail "txOutBaseParseJson: value is unsupported for this era"
535+
pure $ L.mkBasicTxOut addr val
536+
537+
-- | Parse a ledger 'L.Addr' from JSON. Reverse of 'addrToJson'.
538+
addrFromJson :: Aeson.Value -> Parser L.Addr
539+
addrFromJson = Aeson.withText "Address" $ \txt ->
540+
case deserialiseAddress AsAddressAny txt of
541+
Nothing -> fail $ "addrFromJson: invalid address: " <> show txt
542+
Just addrAny -> pure $ case addrAny of
543+
AddressByron (ByronAddress addr) -> L.AddrBootstrap (L.BootstrapAddress addr)
544+
AddressShelley (ShelleyAddress nw pc scr) -> L.Addr nw pc scr
545+
546+
-- | Parse a Babbage+ TxOut with datum and reference script support.
547+
babbageOnwardsTxOutParseJson
548+
:: forall era
549+
. ( L.BabbageEraTxOut era
550+
, L.NativeScript era ~ Timelock era
551+
)
552+
=> Aeson.Object -> Parser (TxOut era)
553+
babbageOnwardsTxOutParseJson o = do
554+
baseTxOut <- txOutBaseParseJson o
555+
-- Parse datum fields
556+
mDatumHash <- o .:? "datumhash"
557+
mInlineDatumRaw <- o .:? "inlineDatumRaw"
558+
mInlineDatumHash <- o .:? "inlineDatumhash"
559+
-- Parse reference script
560+
mRefScript <- o .:? "referenceScript"
561+
-- Determine datum
562+
datum <- case mInlineDatumRaw of
563+
Just rawHex -> do
564+
expectedHash <- case mInlineDatumHash of
565+
Nothing -> fail "babbageOnwardsTxOutParseJson: inlineDatumRaw present without inlineDatumhash"
566+
Just h -> pure h
567+
rawBytes <- case Base16.decode (Text.encodeUtf8 rawHex) of
568+
Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to hex-decode inlineDatumRaw: " <> show err
569+
Right bs -> pure bs
570+
binaryData <- case L.makeBinaryData (SBS.toShort rawBytes) of
571+
Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to CBOR-decode inlineDatumRaw: " <> err
572+
Right bd -> pure bd
573+
when (L.hashBinaryData binaryData /= expectedHash) $
574+
fail $
575+
"babbageOnwardsTxOutParseJson: inline datum hash mismatch: "
576+
<> "expected "
577+
<> show expectedHash
578+
<> ", got "
579+
<> show (L.hashBinaryData binaryData)
580+
pure $ L.Datum binaryData
581+
Nothing -> case mDatumHash of
582+
Just dh -> pure $ L.DatumHash dh
583+
Nothing -> pure L.NoDatum
584+
-- Determine reference script
585+
refScript <- case mRefScript of
586+
Nothing -> pure SNothing
587+
Just script -> SJust <$> scriptInAnyLangToLedgerScript script
588+
-- Construct TxOut
589+
pure . TxOut $
590+
baseTxOut
591+
& L.datumTxOutL .~ datum
592+
& L.referenceScriptTxOutL .~ refScript
593+
594+
-- | Convert a 'ScriptInAnyLang' to a ledger 'L.Script'. Reverse of 'ledgerScriptToScriptInAnyLang'.
595+
scriptInAnyLangToLedgerScript
596+
:: forall era
597+
. ( L.AlonzoEraScript era
598+
, L.NativeScript era ~ Timelock era
599+
)
600+
=> ScriptInAnyLang -> Parser (L.Script era)
601+
scriptInAnyLangToLedgerScript (ScriptInAnyLang lang script) =
602+
case (lang, script) of
603+
(SimpleScriptLanguage, OldScript.SimpleScript ss) ->
604+
pure $ Ledger.fromNativeScript (toAllegraTimelock ss)
605+
(PlutusScriptLanguage PlutusScriptV1, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
606+
L.fromPlutusScript
607+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV1)
608+
(PlutusScriptLanguage PlutusScriptV2, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
609+
L.fromPlutusScript
610+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV2)
611+
(PlutusScriptLanguage PlutusScriptV3, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
612+
L.fromPlutusScript
613+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV3)
614+
(PlutusScriptLanguage PlutusScriptV4, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
615+
L.fromPlutusScript
616+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV4)
617+
492618
data Datum ctx era where
493619
TxOutDatumHash
494620
:: L.DataHash

‎cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs‎

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -93,6 +93,33 @@ go sbe = do
9393
newTxOut = Exp.TxOut ledgerTxOut
9494
toJSON oldTxOut === toJSON newTxOut
9595

96+
-- | Verify that the new experimental 'TxOut' round-trips through JSON
97+
-- (encode then decode) for all Shelley-based eras.
98+
prop_new_txout_json_roundtrip :: Property
99+
prop_new_txout_json_roundtrip = H.property $ do
100+
AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound .. maxBound]
101+
case sbe of
102+
ShelleyBasedEraShelley -> goRoundtrip sbe
103+
ShelleyBasedEraAllegra -> goRoundtrip sbe
104+
ShelleyBasedEraMary -> goRoundtrip sbe
105+
ShelleyBasedEraAlonzo -> goRoundtrip sbe
106+
ShelleyBasedEraBabbage -> goRoundtrip sbe
107+
ShelleyBasedEraConway -> goRoundtrip sbe
108+
ShelleyBasedEraDijkstra -> pure ()
109+
110+
goRoundtrip
111+
:: ( L.EraTxOut (ShelleyLedgerEra era)
112+
, ToJSON (Exp.TxOut (ShelleyLedgerEra era))
113+
, FromJSON (Exp.TxOut (ShelleyLedgerEra era))
114+
)
115+
=> ShelleyBasedEra era
116+
-> H.PropertyT IO ()
117+
goRoundtrip sbe = do
118+
oldTxOut <- forAll $ genTxOutUTxOContext sbe
119+
let ledgerTxOut = toShelleyTxOut sbe oldTxOut
120+
newTxOut = Exp.TxOut ledgerTxOut
121+
tripping newTxOut encode eitherDecode
122+
96123
tests :: TestTree
97124
tests =
98125
testGroup
@@ -106,4 +133,5 @@ tests =
106133
, testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json
107134
, testProperty "json roundtrip praos nonce" prop_roundtrip_praos_nonce_JSON
108135
, testProperty "new TxOut ToJSON matches legacy" prop_new_txout_json_matches_legacy
136+
, testProperty "new TxOut JSON roundtrip" prop_new_txout_json_roundtrip
109137
]

0 commit comments

Comments
 (0)