Implement an explicit convertConwayTx

Instead of bailing all-or-nothing on incompatible transactions, this
variant now explicitly drops incompatible parts and can be used for a
more compatible way of operating on a Conway network.

hydra-cardano-api/hydra-cardano-api.cabal

@@ -92,6 +92,7 @@ library
     , cardano-ledger-babbage  >=1.6    && <1.7
     , cardano-ledger-binary   >=1.3    && <1.4
     , cardano-ledger-byron    >=1.0.0  && <1.1
+    , cardano-ledger-conway   >=1.12   && <1.13
     , cardano-ledger-core     >=1.10   && <1.11
     , cardano-ledger-mary     >=1.5    && <1.6
     , cardano-ledger-shelley  >=1.9    && <1.10

hydra-cardano-api/src/Hydra/Cardano/Api/Tx.hs

@@ -10,47 +10,156 @@ import Hydra.Cardano.Api.KeyWitness (
 import Hydra.Cardano.Api.TxScriptValidity (toLedgerScriptValidity)
 
 import Cardano.Api.UTxO qualified as UTxO
+import Cardano.Ledger.Allegra.Scripts (translateTimelock)
+import Cardano.Ledger.Alonzo qualified as Ledger
+import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
+import Cardano.Ledger.Alonzo.TxAuxData (translateAlonzoTxAuxData)
 import Cardano.Ledger.Alonzo.TxWits qualified as Ledger
-import Cardano.Ledger.Api qualified as Ledger
-import Cardano.Ledger.Api.Tx (
+import Cardano.Ledger.Api (
+  AlonzoPlutusPurpose (..),
+  AsIndex (..),
+  ConwayPlutusPurpose (..),
   EraTx (mkBasicTx),
+  addrTxOutL,
   addrTxWitsL,
+  auxDataHashTxBodyL,
   auxDataTxL,
+  bodyTxL,
   bootAddrTxWitsL,
+  collateralInputsTxBodyL,
+  collateralReturnTxBodyL,
+  dataTxOutL,
   datsTxWitsL,
+  feeTxBodyL,
   hashScriptTxWitsL,
+  inputsTxBodyL,
   isValidTxL,
+  mintTxBodyL,
+  mkBasicTxBody,
+  mkBasicTxOut,
   mkBasicTxWits,
+  networkIdTxBodyL,
+  outputsTxBodyL,
   rdmrsTxWitsL,
+  referenceInputsTxBodyL,
+  referenceScriptTxOutL,
+  reqSignerHashesTxBodyL,
+  scriptIntegrityHashTxBodyL,
+  scriptTxWitsL,
+  totalCollateralTxBodyL,
+  valueTxOutL,
+  vldtTxBodyL,
+  withdrawalsTxBodyL,
   witsTxL,
  )
+import Cardano.Ledger.Api qualified as Ledger
+import Cardano.Ledger.Babbage qualified as Ledger
 import Cardano.Ledger.Babbage.Tx qualified as Ledger
+import Cardano.Ledger.Babbage.TxWits (upgradeTxDats)
 import Cardano.Ledger.BaseTypes (maybeToStrictMaybe, strictMaybeToMaybe)
 import Cardano.Ledger.Coin (Coin (..))
-import Control.Lens ((&), (.~))
+import Cardano.Ledger.Conway.Scripts (PlutusScript (..))
+import Cardano.Ledger.Conway.Scripts qualified as Conway
+import Cardano.Ledger.Conway.TxBody qualified as Ledger
+import Cardano.Ledger.Plutus.Data (upgradeData)
+import Control.Lens ((&), (.~), (^.))
 import Data.Bifunctor (bimap)
 import Data.Functor ((<&>))
 import Data.Map qualified as Map
+import Data.Maybe (mapMaybe)
 import Hydra.Cardano.Api.TxIn (mkTxIn)
 
 -- * Extras
 
--- | Convert a transaction of between cardano eras by re-encoding transactions
--- and relying on the fact that ledger transactions are usually backward
--- compatible. Expect this to succeed, for example, for a Babbage transaction
--- that was included Conway block, which is then to be converted back to Babbage
--- by this function.
-convertTx ::
-  forall eraFrom eraTo.
-  (IsShelleyBasedEra eraFrom, IsShelleyBasedEra eraTo) =>
-  Tx eraFrom ->
-  Maybe (Tx eraTo)
-convertTx tx =
-  case deserialiseFromCBOR (proxyToAsType (Proxy @(Tx eraTo))) bytes of
-    Left _err -> Nothing
-    Right tx' -> Just tx'
+-- | Explicit downgrade from Conway to Babbage era.
+--
+-- NOTE: This is not a complete mapping and does silently drop things like
+-- protocol updates, certificates and voting procedures.
+convertConwayTx :: Tx ConwayEra -> Tx BabbageEra
+convertConwayTx =
+  fromLedgerTx . convert . toLedgerTx
  where
-  bytes = serialiseToCBOR tx
+  convert :: Ledger.Tx (Ledger.ConwayEra StandardCrypto) -> Ledger.Tx (Ledger.BabbageEra StandardCrypto)
+  convert tx =
+    mkBasicTx (translateBody $ tx ^. bodyTxL)
+      & witsTxL .~ translateWits (tx ^. witsTxL)
+      & isValidTxL .~ tx ^. isValidTxL
+      & auxDataTxL .~ (translateAlonzoTxAuxData <$> tx ^. auxDataTxL)
+
+  translateBody ::
+    Ledger.ConwayTxBody (Ledger.ConwayEra StandardCrypto) ->
+    Ledger.BabbageTxBody (Ledger.BabbageEra StandardCrypto)
+  translateBody body =
+    mkBasicTxBody
+      & inputsTxBodyL .~ body ^. inputsTxBodyL
+      & outputsTxBodyL .~ (translateTxOut <$> body ^. outputsTxBodyL)
+      & feeTxBodyL .~ body ^. feeTxBodyL
+      & withdrawalsTxBodyL .~ body ^. withdrawalsTxBodyL
+      & auxDataHashTxBodyL .~ body ^. auxDataHashTxBodyL
+      -- NOTE: not considering 'updateTxBodyL' as upstream also does not upgrade it
+      -- NOTE: not considering 'certsTxBodyL' as we are not interested in it
+      & vldtTxBodyL .~ body ^. vldtTxBodyL
+      & mintTxBodyL .~ body ^. mintTxBodyL
+      & collateralInputsTxBodyL .~ body ^. collateralInputsTxBodyL
+      & reqSignerHashesTxBodyL .~ body ^. reqSignerHashesTxBodyL
+      & scriptIntegrityHashTxBodyL .~ body ^. scriptIntegrityHashTxBodyL
+      & networkIdTxBodyL .~ body ^. networkIdTxBodyL
+      & referenceInputsTxBodyL .~ body ^. referenceInputsTxBodyL
+      & totalCollateralTxBodyL .~ body ^. totalCollateralTxBodyL
+      & collateralReturnTxBodyL .~ (translateTxOut <$> body ^. collateralReturnTxBodyL)
+
+  translateTxOut ::
+    Ledger.BabbageTxOut (Ledger.ConwayEra StandardCrypto) ->
+    Ledger.BabbageTxOut (Ledger.BabbageEra StandardCrypto)
+  translateTxOut out =
+    mkBasicTxOut (out ^. addrTxOutL) (out ^. valueTxOutL)
+      & dataTxOutL .~ (upgradeData <$> out ^. dataTxOutL)
+      & referenceScriptTxOutL .~ (out ^. referenceScriptTxOutL >>= maybeToStrictMaybe . translateScript)
+
+  translateWits ::
+    Ledger.AlonzoTxWits (Ledger.ConwayEra StandardCrypto) ->
+    Ledger.AlonzoTxWits (Ledger.BabbageEra StandardCrypto)
+  translateWits wits =
+    mkBasicTxWits
+      & addrTxWitsL .~ wits ^. addrTxWitsL
+      & bootAddrTxWitsL .~ wits ^. bootAddrTxWitsL
+      & scriptTxWitsL .~ Map.mapMaybe translateScript (wits ^. scriptTxWitsL)
+      & datsTxWitsL .~ upgradeTxDats (wits ^. datsTxWitsL)
+      & rdmrsTxWitsL .~ translateRdmrs (wits ^. rdmrsTxWitsL)
+
+  translateScript ::
+    Ledger.AlonzoScript (Ledger.ConwayEra StandardCrypto) ->
+    Maybe (Ledger.AlonzoScript (Ledger.BabbageEra StandardCrypto))
+  translateScript = \case
+    Ledger.TimelockScript ts -> Just . Ledger.TimelockScript $ translateTimelock ts
+    Ledger.PlutusScript ps -> case ps of
+      ConwayPlutusV1 p1 -> Just . Ledger.PlutusScript $ BabbagePlutusV1 p1
+      ConwayPlutusV2 p2 -> Just . Ledger.PlutusScript $ BabbagePlutusV2 p2
+      ConwayPlutusV3{} -> Nothing
+
+  translateRdmrs ::
+    Ledger.Redeemers (Ledger.ConwayEra StandardCrypto) ->
+    Ledger.Redeemers (Ledger.BabbageEra StandardCrypto)
+  translateRdmrs (Ledger.Redeemers redeemerMap) =
+    Ledger.Redeemers
+      . Map.fromList
+      $ mapMaybe
+        ( \(purpose, (dat, units)) -> do
+            p' <- translatePlutusPurpose purpose
+            pure (p', (upgradeData dat, units))
+        )
+      $ Map.toList redeemerMap
+
+  translatePlutusPurpose ::
+    Conway.ConwayPlutusPurpose Ledger.AsIndex (Ledger.ConwayEra StandardCrypto) ->
+    Maybe (Ledger.AlonzoPlutusPurpose Ledger.AsIndex (Ledger.BabbageEra StandardCrypto))
+  translatePlutusPurpose = \case
+    ConwaySpending (AsIndex ix) -> Just $ AlonzoSpending (AsIndex ix)
+    ConwayMinting (AsIndex ix) -> Just $ AlonzoMinting (AsIndex ix)
+    ConwayCertifying (AsIndex ix) -> Just $ AlonzoCertifying (AsIndex ix)
+    ConwayRewarding (AsIndex ix) -> Just $ AlonzoRewarding (AsIndex ix)
+    ConwayVoting{} -> Nothing
+    ConwayProposing{} -> Nothing
 
 -- | Sign transaction using the provided secret key
 -- It only works for tx not containing scripts.

hydra-chain-observer/src/Hydra/ChainObserver.hs

@@ -22,7 +22,7 @@ import Hydra.Cardano.Api (
   Tx,
   UTxO,
   connectToLocalNode,
-  convertTx,
+  convertConwayTx,
   getChainPoint,
   getTxBody,
   getTxId,
@@ -180,7 +180,7 @@ chainSyncClient tracer networkId startingPoint observerHandler =
           traceWith tracer RollForward{point, receivedTxIds}
 
           let txs = case blockInMode of
-                BlockInMode ConwayEra (Block _ conwayTxs) -> mapMaybe convertTx conwayTxs
+                BlockInMode ConwayEra (Block _ conwayTxs) -> map convertConwayTx conwayTxs
                 BlockInMode BabbageEra (Block _ babbageTxs) -> babbageTxs
                 _ -> []
 

hydra-node/src/Hydra/Chain/Direct.hs

@@ -41,7 +41,7 @@ import Hydra.Cardano.Api (
   TxValidationErrorInCardanoMode,
   chainTipToChainPoint,
   connectToLocalNode,
-  convertTx,
+  convertConwayTx,
   getTxBody,
   getTxId,
   toLedgerUTxO,
@@ -311,7 +311,7 @@ chainSyncClient handler wallet startingPoint =
       { recvMsgRollForward = \blockInMode _tip -> ChainSyncClient $ do
           case blockInMode of
             BlockInMode ConwayEra (Block header conwayTxs) -> do
-              let txs = mapMaybe convertTx conwayTxs
+              let txs = map convertConwayTx conwayTxs
               -- Update the tiny wallet
               update wallet header txs
               -- Observe Hydra transactions