Skip to content

Commit abf58f2

Browse files
Jimbo4350Jimbo4350
committed
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.
1 parent 6651c3e commit abf58f2

2 files changed

Lines changed: 114 additions & 108 deletions

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: 111 additions & 106 deletions
Original file line numberDiff line numberDiff line change
@@ -74,6 +74,7 @@ module Cardano.Api.Experimental.Tx.Internal.BodyContent.New
7474
where
7575

7676
import Cardano.Api.Address
77+
import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra)
7778
import Cardano.Api.Error
7879
import Cardano.Api.Experimental.AnyScriptWitness
7980
import Cardano.Api.Experimental.Certificate qualified as Exp
@@ -102,7 +103,7 @@ import Cardano.Api.Governance.Internal.Action.VotingProcedure
102103
import Cardano.Api.Key.Internal
103104
import Cardano.Api.Ledger.Internal.Reexport (StrictMaybe (..))
104105
import Cardano.Api.Ledger.Internal.Reexport qualified as L
105-
import Cardano.Api.Monad.Error (liftMaybe)
106+
import Cardano.Api.Monad.Error (failEitherWith, liftMaybe)
106107
import Cardano.Api.Plutus.Internal.Script
107108
( PlutusScript (..)
108109
, PlutusScriptVersion (..)
@@ -127,8 +128,7 @@ import Cardano.Api.Value.Internal
127128
( PolicyAssets
128129
, PolicyId
129130
, Value
130-
, fromMaryValue
131-
, lovelaceToValue
131+
, fromLedgerValue
132132
, policyAssetsToValue
133133
, toMaryValue
134134
)
@@ -163,7 +163,6 @@ import Data.Sequence.Strict qualified as Seq
163163
import Data.Set (Set)
164164
import Data.Set qualified as Set
165165
import Data.Text.Encoding qualified as Text
166-
import Data.Typeable (cast)
167166
import GHC.Exts (IsList (..))
168167
import Lens.Micro
169168

@@ -374,16 +373,11 @@ eraSpecificLedgerTxBody era ledgerbody bc =
374373
data TxOut era where
375374
TxOut :: L.EraTxOut era => L.TxOut era -> TxOut era
376375

377-
-- | Pre-Alonzo eras have no datums or reference scripts, so the JSON
378-
-- output is just address and value.
379-
instance ToJSON (TxOut L.ShelleyEra) where
380-
toJSON (TxOut o) = txOutBaseJson o
376+
instance ToJSON (TxOut L.ShelleyEra) where toJSON = txOutToJson ShelleyBasedEraShelley
381377

382-
instance ToJSON (TxOut L.AllegraEra) where
383-
toJSON (TxOut o) = txOutBaseJson o
378+
instance ToJSON (TxOut L.AllegraEra) where toJSON = txOutToJson ShelleyBasedEraAllegra
384379

385-
instance ToJSON (TxOut L.MaryEra) where
386-
toJSON (TxOut o) = txOutBaseJson o
380+
instance ToJSON (TxOut L.MaryEra) where toJSON = txOutToJson ShelleyBasedEraMary
387381

388382
-- | Note: Unlike the legacy API's @TxOut@, this instance does not render
389383
-- supplemental datums. At the ledger level, a supplemental datum is not
@@ -392,20 +386,25 @@ instance ToJSON (TxOut L.MaryEra) where
392386
-- datum into @TxOut@ for convenience, but since this type wraps the
393387
-- ledger's @TxOut@ directly, supplemental datums are indistinguishable
394388
-- from hash-only datums here.
395-
instance ToJSON (TxOut L.AlonzoEra) where toJSON = alonzoOnwardsTxOutToJson
389+
instance ToJSON (TxOut L.AlonzoEra) where toJSON = txOutToJson ShelleyBasedEraAlonzo
396390

397-
instance ToJSON (TxOut L.BabbageEra) where toJSON = alonzoOnwardsTxOutToJson
391+
instance ToJSON (TxOut L.BabbageEra) where toJSON = txOutToJson ShelleyBasedEraBabbage
398392

399-
instance ToJSON (TxOut L.ConwayEra) where toJSON = alonzoOnwardsTxOutToJson
393+
instance ToJSON (TxOut L.ConwayEra) where toJSON = txOutToJson ShelleyBasedEraConway
400394

401-
alonzoOnwardsTxOutToJson
402-
:: (L.AnyEraTxOut era, L.AlonzoEraScript era) => TxOut era -> Aeson.Value
403-
alonzoOnwardsTxOutToJson (TxOut o) =
395+
txOutToJson :: ShelleyBasedEra era -> TxOut (ShelleyLedgerEra era) -> Aeson.Value
396+
txOutToJson sbe (TxOut o) =
404397
Aeson.object $
405-
[ "address" .= addrToJson (o ^. L.addrTxOutL)
406-
, "value" .= valueToJson (o ^. L.valueTxOutL)
407-
]
408-
<> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG)
398+
txOutBaseJsonFields sbe o <> alonzoOnwardsFields
399+
where
400+
alonzoOnwardsFields = case sbe of
401+
ShelleyBasedEraShelley -> []
402+
ShelleyBasedEraAllegra -> []
403+
ShelleyBasedEraMary -> []
404+
ShelleyBasedEraAlonzo -> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG)
405+
ShelleyBasedEraBabbage -> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG)
406+
ShelleyBasedEraConway -> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG)
407+
ShelleyBasedEraDijkstra -> datumAndRefScriptFields (o ^. L.datumTxOutG) (o ^. L.referenceScriptTxOutG)
409408

410409
-- | Emit the datum, inline-datum, and reference-script JSON fields appropriate
411410
-- for the era. Pre-Alonzo emits nothing; Alonzo emits @datumhash@ and @datum@;
@@ -445,26 +444,19 @@ datumAndRefScriptFields mDatum mRefScript =
445444
Just (Just script) -> ["referenceScript" .= ledgerScriptToScriptInAnyLang script]
446445

447446
-- | Render just the base fields (address and value) shared by all eras.
448-
txOutBaseJson :: L.EraTxOut era => L.TxOut era -> Aeson.Value
449-
txOutBaseJson o =
450-
Aeson.object
451-
[ "address" .= addrToJson (o ^. L.addrTxOutL)
452-
, "value" .= valueToJson (o ^. L.valueTxOutL)
453-
]
447+
txOutBaseJsonFields
448+
:: L.EraTxOut (ShelleyLedgerEra era) => ShelleyBasedEra era -> L.TxOut (ShelleyLedgerEra era) -> [Pair]
449+
txOutBaseJsonFields sbe o =
450+
[ "address" .= addrToJson (o ^. L.addrTxOutL)
451+
, "value" .= fromLedgerValue sbe (o ^. L.valueTxOutL)
452+
]
454453

455454
-- | Convert a ledger 'L.Addr' to JSON using the same format as the legacy API
456455
-- (bech32 for Shelley addresses, base58 for Byron addresses).
457456
addrToJson :: L.Addr -> Aeson.Value
458457
addrToJson (L.Addr nw pc scr) = toJSON (ShelleyAddress nw pc scr)
459458
addrToJson (L.AddrBootstrap (L.BootstrapAddress addr)) = toJSON (ByronAddress addr)
460459

461-
-- | Convert a ledger value to JSON using the cardano-api 'Value' format.
462-
-- Uses 'Typeable' to detect 'MaryValue' (multi-asset) vs 'Coin' (ada-only).
463-
valueToJson :: L.Val v => v -> Aeson.Value
464-
valueToJson v = case cast v of
465-
Just (mv :: L.MaryValue) -> toJSON (fromMaryValue mv)
466-
Nothing -> toJSON (lovelaceToValue (L.coin v))
467-
468460
-- | Convert a ledger 'Script' to a cardano-api 'ScriptInAnyLang' without
469461
-- per-era pattern matching, using 'AlonzoEraScript' methods.
470462
ledgerScriptToScriptInAnyLang
@@ -492,49 +484,82 @@ ledgerScriptToScriptInAnyLang script =
492484
OldScript.PlutusScript PlutusScriptV4 (PlutusScriptSerialised sbs)
493485
Nothing -> error "ledgerScriptToScriptInAnyLang: script is neither native nor Plutus"
494486

487+
-- | Convert a 'ScriptInAnyLang' to a ledger 'L.Script'. Reverse of 'ledgerScriptToScriptInAnyLang'.
488+
scriptInAnyLangToLedgerScript
489+
:: forall era
490+
. ( L.AlonzoEraScript era
491+
, L.NativeScript era ~ Timelock era
492+
)
493+
=> ScriptInAnyLang -> Parser (L.Script era)
494+
scriptInAnyLangToLedgerScript (ScriptInAnyLang lang script) =
495+
case (lang, script) of
496+
(SimpleScriptLanguage, OldScript.SimpleScript ss) ->
497+
pure $ Ledger.fromNativeScript (toAllegraTimelock ss)
498+
(PlutusScriptLanguage PlutusScriptV1, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
499+
L.fromPlutusScript
500+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV1)
501+
(PlutusScriptLanguage PlutusScriptV2, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
502+
L.fromPlutusScript
503+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV2)
504+
(PlutusScriptLanguage PlutusScriptV3, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
505+
L.fromPlutusScript
506+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV3)
507+
(PlutusScriptLanguage PlutusScriptV4, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
508+
L.fromPlutusScript
509+
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV4)
510+
495511
deriving instance (Show (TxOut era))
496512

497513
deriving instance (Eq (TxOut era))
498514

499515
-- | Pre-Alonzo eras have no datums or reference scripts, so parsing
500-
-- only needs address and value.
501516
instance FromJSON (TxOut L.ShelleyEra) where
502-
parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson
517+
parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraShelley)
503518

504519
instance FromJSON (TxOut L.AllegraEra) where
505-
parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson
520+
parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraAllegra)
506521

507522
instance FromJSON (TxOut L.MaryEra) where
508-
parseJSON = Aeson.withObject "TxOut" $ fmap TxOut . txOutBaseParseJson
523+
parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraMary)
509524

510-
-- | Alonzo supports datum hashes but not inline datums or reference scripts.
511525
instance FromJSON (TxOut L.AlonzoEra) where
512-
parseJSON = Aeson.withObject "TxOut" $ \o -> do
513-
baseTxOut <- txOutBaseParseJson o
514-
mDatumHash <- o .:? "datumhash"
515-
pure . TxOut $ case mDatumHash of
516-
Nothing -> baseTxOut
517-
Just dh -> baseTxOut & L.dataHashTxOutL .~ SJust dh
518-
519-
-- | Babbage and later eras support inline datums and reference scripts.
526+
parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraAlonzo)
527+
520528
instance FromJSON (TxOut L.BabbageEra) where
521-
parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson
529+
parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraBabbage)
522530

523531
instance FromJSON (TxOut L.ConwayEra) where
524-
parseJSON = Aeson.withObject "TxOut" babbageOnwardsTxOutParseJson
532+
parseJSON = Aeson.withObject "TxOut" (txOutParseJson ShelleyBasedEraConway)
525533

526-
-- | Parse the base fields (address and value) shared by all eras.
527-
txOutBaseParseJson :: L.EraTxOut era => Aeson.Object -> Parser (L.TxOut era)
528-
txOutBaseParseJson o = do
534+
txOutParseJson
535+
:: ShelleyBasedEra era -> Aeson.Object -> Parser (TxOut (ShelleyLedgerEra era))
536+
txOutParseJson sbe o = do
529537
addr <- addrFromJson =<< o .: "address"
530538
apiVal <- parseJSON =<< o .: "value"
531539
let mv = toMaryValue apiVal
532-
val <- case cast mv of
533-
Just v -> pure v
534-
Nothing -> case cast (L.coin mv) of
535-
Just v -> pure v
536-
Nothing -> fail "txOutBaseParseJson: value is unsupported for this era"
537-
pure $ L.mkBasicTxOut addr val
540+
case sbe of
541+
ShelleyBasedEraShelley -> do
542+
let L.MaryValue _ ma = mv
543+
unless (ma == mempty) $
544+
fail "txOutParseJson: ada-only era output cannot carry a multi-asset value"
545+
pure . TxOut $ L.mkBasicTxOut addr (L.coin mv)
546+
ShelleyBasedEraAllegra -> do
547+
let L.MaryValue _ ma = mv
548+
unless (ma == mempty) $
549+
fail "txOutParseJson: ada-only era output cannot carry a multi-asset value"
550+
pure . TxOut $ L.mkBasicTxOut addr (L.coin mv)
551+
ShelleyBasedEraMary -> pure . TxOut $ L.mkBasicTxOut addr mv
552+
ShelleyBasedEraAlonzo -> do
553+
let base = L.mkBasicTxOut addr mv
554+
mDatumHash <- o .:? "datumhash"
555+
pure . TxOut $ case mDatumHash of
556+
Nothing -> base
557+
Just dh -> base & L.dataHashTxOutL .~ SJust dh
558+
ShelleyBasedEraBabbage ->
559+
babbageOnwardsTxOutParseJson (L.mkBasicTxOut addr mv :: L.TxOut L.BabbageEra) o
560+
ShelleyBasedEraConway ->
561+
babbageOnwardsTxOutParseJson (L.mkBasicTxOut addr mv :: L.TxOut L.ConwayEra) o
562+
ShelleyBasedEraDijkstra -> error "TODO Dijkstra: txOutParseJson: era not supported"
538563

539564
-- | Parse a ledger 'L.Addr' from JSON. Reverse of 'addrToJson'.
540565
addrFromJson :: Aeson.Value -> Parser L.Addr
@@ -551,9 +576,8 @@ babbageOnwardsTxOutParseJson
551576
. ( L.BabbageEraTxOut era
552577
, L.NativeScript era ~ Timelock era
553578
)
554-
=> Aeson.Object -> Parser (TxOut era)
555-
babbageOnwardsTxOutParseJson o = do
556-
baseTxOut <- txOutBaseParseJson o
579+
=> L.TxOut era -> Aeson.Object -> Parser (TxOut era)
580+
babbageOnwardsTxOutParseJson baseTxOut o = do
557581
-- Parse datum fields
558582
mDatumHash <- o .:? "datumhash"
559583
mInlineDatumRaw <- o .:? "inlineDatumRaw"
@@ -563,60 +587,41 @@ babbageOnwardsTxOutParseJson o = do
563587
-- Determine datum
564588
datum <- case mInlineDatumRaw of
565589
Just rawHex -> do
566-
expectedHash <- case mInlineDatumHash of
567-
Nothing -> fail "babbageOnwardsTxOutParseJson: inlineDatumRaw present without inlineDatumhash"
568-
Just h -> pure h
569-
rawBytes <- case Base16.decode (Text.encodeUtf8 rawHex) of
570-
Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to hex-decode inlineDatumRaw: " <> show err
571-
Right bs -> pure bs
572-
binaryData <- case L.makeBinaryData (SBS.toShort rawBytes) of
573-
Left err -> fail $ "babbageOnwardsTxOutParseJson: failed to CBOR-decode inlineDatumRaw: " <> err
574-
Right bd -> pure bd
590+
expectedHash <-
591+
maybe
592+
(fail "babbageOnwardsTxOutParseJson: inlineDatumRaw present without inlineDatumhash")
593+
pure
594+
mInlineDatumHash
595+
rawBytes <-
596+
failEitherWith
597+
(("babbageOnwardsTxOutParseJson: failed to hex-decode inlineDatumRaw: " <>) . show)
598+
$ Base16.decode (Text.encodeUtf8 rawHex)
599+
binaryData <-
600+
failEitherWith
601+
("babbageOnwardsTxOutParseJson: failed to CBOR-decode inlineDatumRaw: " <>)
602+
$ L.makeBinaryData (SBS.toShort rawBytes)
575603
when (L.hashBinaryData binaryData /= expectedHash) $
576604
fail $
577-
"babbageOnwardsTxOutParseJson: inline datum hash mismatch: "
578-
<> "expected "
579-
<> show expectedHash
580-
<> ", got "
581-
<> show (L.hashBinaryData binaryData)
605+
mconcat
606+
[ "babbageOnwardsTxOutParseJson: inline datum hash mismatch: "
607+
, "expected "
608+
, show expectedHash
609+
, ", got "
610+
, show (L.hashBinaryData binaryData)
611+
]
582612
pure $ L.Datum binaryData
583-
Nothing -> case mDatumHash of
584-
Just dh -> pure $ L.DatumHash dh
585-
Nothing -> pure L.NoDatum
613+
Nothing -> do
614+
when (isJust mInlineDatumHash) $
615+
fail "babbageOnwardsTxOutParseJson: inlineDatumhash present without inlineDatumRaw"
616+
pure $ maybe L.NoDatum L.DatumHash mDatumHash
586617
-- Determine reference script
587-
refScript <- case mRefScript of
588-
Nothing -> pure SNothing
589-
Just script -> SJust <$> scriptInAnyLangToLedgerScript script
618+
refScript <- fmap L.maybeToStrictMaybe $ forM mRefScript scriptInAnyLangToLedgerScript
590619
-- Construct TxOut
591620
pure . TxOut $
592621
baseTxOut
593622
& L.datumTxOutL .~ datum
594623
& L.referenceScriptTxOutL .~ refScript
595624

596-
-- | Convert a 'ScriptInAnyLang' to a ledger 'L.Script'. Reverse of 'ledgerScriptToScriptInAnyLang'.
597-
scriptInAnyLangToLedgerScript
598-
:: forall era
599-
. ( L.AlonzoEraScript era
600-
, L.NativeScript era ~ Timelock era
601-
)
602-
=> ScriptInAnyLang -> Parser (L.Script era)
603-
scriptInAnyLangToLedgerScript (ScriptInAnyLang lang script) =
604-
case (lang, script) of
605-
(SimpleScriptLanguage, OldScript.SimpleScript ss) ->
606-
pure $ Ledger.fromNativeScript (toAllegraTimelock ss)
607-
(PlutusScriptLanguage PlutusScriptV1, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
608-
L.fromPlutusScript
609-
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV1)
610-
(PlutusScriptLanguage PlutusScriptV2, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
611-
L.fromPlutusScript
612-
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV2)
613-
(PlutusScriptLanguage PlutusScriptV3, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
614-
L.fromPlutusScript
615-
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV3)
616-
(PlutusScriptLanguage PlutusScriptV4, OldScript.PlutusScript _ (PlutusScriptSerialised sbs)) ->
617-
L.fromPlutusScript
618-
<$> L.mkPlutusScript (Plutus.Plutus (PlutusBinary sbs) :: Plutus.Plutus 'Plutus.PlutusV4)
619-
620625
data Datum ctx era where
621626
TxOutDatumHash
622627
:: L.DataHash

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

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -94,7 +94,8 @@ go sbe = do
9494
toJSON oldTxOut === toJSON newTxOut
9595

9696
-- | Verify that the new experimental 'TxOut' round-trips through JSON
97-
-- (encode then decode) for all Shelley-based eras.
97+
-- (encode then decode) for all Shelley-based eras except Dijkstra, for which
98+
-- 'shelleyBasedEraConstraints' is not yet implemented.
9899
prop_new_txout_json_roundtrip :: Property
99100
prop_new_txout_json_roundtrip = H.property $ do
100101
AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound .. maxBound]
@@ -105,7 +106,7 @@ prop_new_txout_json_roundtrip = H.property $ do
105106
ShelleyBasedEraAlonzo -> goRoundtrip sbe
106107
ShelleyBasedEraBabbage -> goRoundtrip sbe
107108
ShelleyBasedEraConway -> goRoundtrip sbe
108-
ShelleyBasedEraDijkstra -> pure ()
109+
ShelleyBasedEraDijkstra -> pure () -- shelleyBasedEraConstraints not yet implemented
109110

110111
goRoundtrip
111112
:: ( L.EraTxOut (ShelleyLedgerEra era)

0 commit comments

Comments
 (0)