From 29420a46199c53b25f137c63b606c154520729ea Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Thu, 18 Sep 2025 21:00:09 +0200 Subject: [PATCH 1/3] Add `SerialiseAsCBOR` instance for `TxOut` --- .../src/Cardano/Api/Tx/Internal/Output.hs | 26 +++++++++++++++++-- .../cardano-api-test/Test/Cardano/Api/CBOR.hs | 16 ++++++++++++ 2 files changed, 40 insertions(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs index f09fbd76dc..3a9778921e 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,6 +14,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Tx.Internal.Output ( -- * Transaction outputs @@ -63,7 +66,7 @@ import Cardano.Api.Era.Internal.Eon.Convert import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra import Cardano.Api.Error (Error (..), displayError) -import Cardano.Api.Hash +import Cardano.Api.HasTypeProxy qualified as HTP import Cardano.Api.Ledger.Internal.Reexport qualified as Ledger import Cardano.Api.Monad.Error import Cardano.Api.Parser.Text qualified as P @@ -82,11 +85,11 @@ import Cardano.Ledger.Alonzo.Core qualified as L import Cardano.Ledger.Api qualified as L import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import Cardano.Ledger.Coin qualified as L -import Cardano.Ledger.Core () import Cardano.Ledger.Core qualified as Core import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Plutus.Data qualified as Plutus +import Codec.CBOR.Encoding (Encoding) import Data.Aeson (object, withObject, (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Aeson @@ -100,6 +103,7 @@ import Data.Sequence.Strict qualified as Seq import Data.Text (Text) import Data.Text.Encoding qualified as Text import Data.Type.Equality +import Data.Typeable (Typeable) import Data.Word import GHC.Exts (IsList (..)) import GHC.Stack @@ -121,6 +125,24 @@ data TxOut ctx era (TxOutValue era) (TxOutDatum ctx era) (ReferenceScript era) + deriving SerialiseAsCBOR + +instance (Typeable ctx, IsShelleyBasedEra era) => HTP.HasTypeProxy (TxOut ctx era) where + data AsType (TxOut ctx era) = AsTxOut (AsType era) + proxyToAsType :: HTP.Proxy (TxOut ctx era) -> AsType (TxOut ctx era) + proxyToAsType _ = AsTxOut (HTP.asType @era) + +instance (Typeable ctx, IsShelleyBasedEra era) => ToCBOR (TxOut ctx era) where + toCBOR :: TxOut ctx era -> Encoding + toCBOR txOut = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + Ledger.toEraCBOR @(ShelleyLedgerEra era) (toShelleyTxOutAny shelleyBasedEra txOut) + +instance (Typeable ctx, IsShelleyBasedEra era) => FromCBOR (TxOut ctx era) where + fromCBOR :: Ledger.Decoder s (TxOut ctx era) + fromCBOR = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + pure (fromShelleyTxOut shelleyBasedEra) <*> L.fromEraCBOR @(ShelleyLedgerEra era) deriving instance Eq (TxOut ctx era) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs index f0e6db23d7..36b9e1e696 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs @@ -109,6 +109,21 @@ prop_roundtrip_tx_CBOR = H.property $ do x <- H.forAll $ genTx era shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x +prop_roundtrip_tx_out_CBOR :: Property +prop_roundtrip_tx_out_CBOR = H.property $ do + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] + x <- H.forAll $ genTx era + txOut <- H.forAll $ Gen.element $ txOuts $ getTxBodyContent $ getTxBody x + let fixedTxOut = hashDatum txOut + shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) fixedTxOut + where + hashDatum :: TxOut CtxTx era -> TxOut CtxTx era + hashDatum txOut@(TxOut aie val datum rs) = + case datum of + (TxOutSupplementalDatum aeo d) -> + TxOut aie val (TxOutDatumHash aeo (hashScriptDataBytes d)) rs + _ -> txOut + prop_roundtrip_witness_CBOR :: Property prop_roundtrip_witness_CBOR = H.property $ do AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] @@ -520,6 +535,7 @@ tests = , testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR , testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl , testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR + , testProperty "roundtrip tx out CBOR" prop_roundtrip_tx_out_CBOR , testProperty "roundtrip GovernancePoll CBOR" prop_roundtrip_GovernancePoll_CBOR From ee2b5a00f9835c03fb10d9f663806a63d2ccc3fd Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 21 Oct 2025 23:29:26 +0200 Subject: [PATCH 2/3] Remove `ToCBOR` and `SerialiseAsCBOR` instances --- cardano-api/src/Cardano/Api/Tx/Internal/Output.hs | 9 --------- .../cardano-api-test/Test/Cardano/Api/CBOR.hs | 15 +++++++++++++-- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs index 3a9778921e..9ae92fbcef 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE EmptyCase #-} @@ -89,7 +88,6 @@ import Cardano.Ledger.Core qualified as Core import Cardano.Ledger.Core qualified as Ledger import Cardano.Ledger.Plutus.Data qualified as Plutus -import Codec.CBOR.Encoding (Encoding) import Data.Aeson (object, withObject, (.:), (.:?), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Aeson @@ -125,19 +123,12 @@ data TxOut ctx era (TxOutValue era) (TxOutDatum ctx era) (ReferenceScript era) - deriving SerialiseAsCBOR instance (Typeable ctx, IsShelleyBasedEra era) => HTP.HasTypeProxy (TxOut ctx era) where data AsType (TxOut ctx era) = AsTxOut (AsType era) proxyToAsType :: HTP.Proxy (TxOut ctx era) -> AsType (TxOut ctx era) proxyToAsType _ = AsTxOut (HTP.asType @era) -instance (Typeable ctx, IsShelleyBasedEra era) => ToCBOR (TxOut ctx era) where - toCBOR :: TxOut ctx era -> Encoding - toCBOR txOut = - shelleyBasedEraConstraints (shelleyBasedEra @era) $ - Ledger.toEraCBOR @(ShelleyLedgerEra era) (toShelleyTxOutAny shelleyBasedEra txOut) - instance (Typeable ctx, IsShelleyBasedEra era) => FromCBOR (TxOut ctx era) where fromCBOR :: Ledger.Decoder s (TxOut ctx era) fromCBOR = diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs index 36b9e1e696..27fa2ce74c 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- TODO remove when serialiseTxLedgerCddl is removed {-# OPTIONS_GHC -Wno-deprecations #-} @@ -11,6 +12,7 @@ module Test.Cardano.Api.CBOR where import Cardano.Api +import Cardano.Api.Ledger qualified as Ledger import Cardano.Binary qualified as CBOR @@ -115,7 +117,8 @@ prop_roundtrip_tx_out_CBOR = H.property $ do x <- H.forAll $ genTx era txOut <- H.forAll $ Gen.element $ txOuts $ getTxBodyContent $ getTxBody x let fixedTxOut = hashDatum txOut - shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) fixedTxOut + shelleyBasedEraConstraints era $ + H.tripping fixedTxOut lossyEncodingForTesting CBOR.decodeFull' where hashDatum :: TxOut CtxTx era -> TxOut CtxTx era hashDatum txOut@(TxOut aie val datum rs) = @@ -124,6 +127,14 @@ prop_roundtrip_tx_out_CBOR = H.property $ do TxOut aie val (TxOutDatumHash aeo (hashScriptDataBytes d)) rs _ -> txOut + lossyEncodingForTesting :: IsShelleyBasedEra era => TxOut CtxTx era -> ByteString + lossyEncodingForTesting txOut = LBS.toStrict $ CBOR.serialize $ toCBOR' txOut + where + toCBOR' :: forall ctx era. IsShelleyBasedEra era => TxOut ctx era -> CBOR.Encoding + toCBOR' txOut' = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + Ledger.toEraCBOR @(ShelleyLedgerEra era) (toShelleyTxOutAny shelleyBasedEra txOut') + prop_roundtrip_witness_CBOR :: Property prop_roundtrip_witness_CBOR = H.property $ do AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] From 453d6b9158fad0327711453a2a82aa50735de158 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Thu, 23 Oct 2025 00:26:57 +0200 Subject: [PATCH 3/3] Add comments to document why we don't have `ToCBOR` instance Co-authored-by: Mateusz Galazyn <228866+carbolymer@users.noreply.github.com> --- cardano-api/src/Cardano/Api/Tx/Internal/Output.hs | 4 ++++ .../test/cardano-api-test/Test/Cardano/Api/CBOR.hs | 9 +++++++++ 2 files changed, 13 insertions(+) diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs index 9ae92fbcef..f9931cbfd5 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs @@ -129,6 +129,10 @@ instance (Typeable ctx, IsShelleyBasedEra era) => HTP.HasTypeProxy (TxOut ctx er proxyToAsType :: HTP.Proxy (TxOut ctx era) -> AsType (TxOut ctx era) proxyToAsType _ = AsTxOut (HTP.asType @era) +-- | We do not provide a 'ToCBOR' instance for 'TxOut' because 'TxOut's can contain +-- supplemental datums and the ledger's CBOR representation does not support this. +-- For this reason, if we were to serialise a 'TxOut' with a supplemental datum, +-- we would lose information and the roundtrip property would not hold. instance (Typeable ctx, IsShelleyBasedEra era) => FromCBOR (TxOut ctx era) where fromCBOR :: Ledger.Decoder s (TxOut ctx era) fromCBOR = diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs index 27fa2ce74c..a713ef26c2 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs @@ -111,6 +111,15 @@ prop_roundtrip_tx_CBOR = H.property $ do x <- H.forAll $ genTx era shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x +-- | The CBOR representation for 'TxOut' does not store supplemental datums. +-- This means we cannot provide a lossless serialisation instance for which +-- a roundtrip property would hold. +-- +-- Therefore, we only provide a deserialisation instance. The serialisation +-- implementation is included for testing purposes only. +-- +-- For the roundtrip test, we hash any supplemental datum before serialisation +-- to ensure the property holds. prop_roundtrip_tx_out_CBOR :: Property prop_roundtrip_tx_out_CBOR = H.property $ do AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound]