Merge pull request #960 from IntersectMBO/SerialiseAsCBOR-for-TxOut

Add `SerialiseAsCBOR` instance for `TxOut`

Author: palas

cardano-api/src/Cardano/Api/Tx/Internal/Output.hs

@@ -5,13 +5,15 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# 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)

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