diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs index f09fbd76dc..f9931cbfd5 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs +++ b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,6 +13,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Cardano.Api.Tx.Internal.Output ( -- * Transaction outputs @@ -63,7 +65,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,7 +84,6 @@ 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 @@ -100,6 +101,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 @@ -122,6 +124,21 @@ data TxOut ctx era (TxOutDatum ctx era) (ReferenceScript era) +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) + +-- | 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 = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + pure (fromShelleyTxOut shelleyBasedEra) <*> L.fromEraCBOR @(ShelleyLedgerEra era) + deriving instance Eq (TxOut ctx era) deriving instance Show (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..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 @@ -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 @@ -109,6 +111,39 @@ 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] + x <- H.forAll $ genTx era + txOut <- H.forAll $ Gen.element $ txOuts $ getTxBodyContent $ getTxBody x + let fixedTxOut = hashDatum txOut + shelleyBasedEraConstraints era $ + H.tripping fixedTxOut lossyEncodingForTesting CBOR.decodeFull' + 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 + + 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] @@ -520,6 +555,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