Conway fee calculation (#1553)

Makes the internal wallet use the right computation depending on the current era. We support `Babbage` and `Conway` in that part of the application now by making things a bit more polymorphic on the `era`. Co-authored by @noonio and @ffakenz --- * [x] CHANGELOG updated * [x] Documentation update not needed * [x] Haddocks updated * [x] No new TODOs introduced or explained herafter
cardano-scaling · Aug 8, 2024 · 4800525 · 4800525
2 parents 70843d8 + dfe42b1
commit 4800525
Show file tree

Hide file tree

Showing 14 changed files with 572 additions and 333 deletions.
diff --git a/.gitignore b/.gitignore
@@ -35,7 +35,7 @@ hspec-results.md
 /docs/static/haddock/
 
 # demo
-devnet
+/devnet
 .env
 logs
 acks

diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -10,10 +10,10 @@ changes.
 
 ## [0.18.0] - Unreleased
 
-- **DO NOT RELEASE** as the tested `cardano-node` version is not intended to be used on `mainnet` yet.
-
 - Tested with `cardano-node 9.1.0` and `cardano-cli 9.2.1.0`.
 
+- Fixed fee calculation of the internal wallet when the network switches to `Conway`. This allows heads to be opened in `Babbage` and closed/finalized in `Conway`.
+
 - **BREAKING** Changes to the `hydra-node` API `/commit` endpoint [#1463](https://github.com/cardano-scaling/hydra/pull/1463):
   - Removed the check that prevented committing UTxOs from an internal `hydra-node` wallet.
   - `SpendingNodeUtxoForbidden` error was removed.

diff --git a/hydra-cardano-api/src/Hydra/Cardano/Api/Tx.hs b/hydra-cardano-api/src/Hydra/Cardano/Api/Tx.hs
@@ -11,6 +11,8 @@ import Cardano.Ledger.Alonzo.TxWits qualified as Ledger
 import Cardano.Ledger.Api (
   AlonzoPlutusPurpose (..),
   AsIx (..),
+  Babbage,
+  Conway,
   ConwayPlutusPurpose (..),
   EraTx (mkBasicTx),
   addrTxOutL,
@@ -24,6 +26,7 @@ import Cardano.Ledger.Api (
   dataTxOutL,
   datsTxWitsL,
   feeTxBodyL,
+  getLanguageView,
   inputsTxBodyL,
   isValidTxL,
   mintTxBodyL,
@@ -46,13 +49,15 @@ import Cardano.Ledger.Api (
  )
 import Cardano.Ledger.Api qualified as Ledger
 import Cardano.Ledger.Babbage qualified as Ledger
+import Cardano.Ledger.Babbage.Tx (hashScriptIntegrity)
 import Cardano.Ledger.Babbage.TxWits (upgradeTxDats)
 import Cardano.Ledger.BaseTypes (maybeToStrictMaybe)
 import Cardano.Ledger.Coin (Coin (..))
 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 Cardano.Ledger.Plutus.Language qualified as Ledger
 import Control.Lens ((&), (.~), (^.))
 import Data.Bifunctor (bimap)
 import Data.Functor ((<&>))
@@ -63,24 +68,95 @@ import Hydra.Cardano.Api.TxIn (mkTxIn, toLedgerTxIn)
 
 -- * Extras
 
+-- | Sign transaction using the provided secret key
+-- It only works for tx not containing scripts.
+-- You can't sign a script utxo with this.
+signTx ::
+  IsShelleyBasedEra era =>
+  SigningKey PaymentKey ->
+  Tx era ->
+  Tx era
+signTx signingKey (Tx body wits) =
+  makeSignedTransaction (witness : wits) body
+ where
+  witness = makeShelleyKeyWitness shelleyBasedEra body (WitnessPaymentKey signingKey)
+
+-- | Create a transaction spending all given `UTxO`.
+txSpendingUTxO :: UTxO -> Tx Era
+txSpendingUTxO utxo =
+  fromLedgerTx $
+    mkBasicTx
+      ( mkBasicTxBody
+          & inputsTxBodyL .~ (toLedgerTxIn `Set.map` inputs)
+      )
+ where
+  inputs = UTxO.inputSet utxo
+
+-- | Get the UTxO that are produced by some transaction.
+-- XXX: Defined here to avoid cyclic module dependency
+utxoProducedByTx :: Tx Era -> UTxO
+utxoProducedByTx tx =
+  UTxO.fromPairs $
+    zip [0 ..] (txOuts body)
+      <&> bimap (mkTxIn tx) toCtxUTxOTxOut
+ where
+  TxBody body = getTxBody tx
+
+-- | Get explicit fees allocated to a transaction.
+txFee' :: Tx era -> Coin
+txFee' (getTxBody -> TxBody body) =
+  case txFee body of
+    TxFeeExplicit _ y -> y
+
+-- * Type Conversions
+
+-- | Convert a cardano-api 'Tx' into a matching cardano-ledger 'Tx'.
+toLedgerTx ::
+  Tx era ->
+  Ledger.Tx (ShelleyLedgerEra era)
+toLedgerTx (ShelleyTx _era tx) = tx
+
+-- | Convert a cardano-ledger's 'Tx' in the Babbage era into a cardano-api 'Tx'.
+fromLedgerTx ::
+  IsShelleyBasedEra era =>
+  Ledger.Tx (ShelleyLedgerEra era) ->
+  Tx era
+fromLedgerTx =
+  ShelleyTx shelleyBasedEra
+
+-- | Compute the integrity hash of a transaction using a list of plutus languages.
+recomputeIntegrityHash ::
+  (Ledger.AlonzoEraPParams ppera, Ledger.AlonzoEraTxWits txera, Ledger.AlonzoEraTxBody txera, EraTx txera) =>
+  Ledger.PParams ppera ->
+  [Ledger.Language] ->
+  Ledger.Tx txera ->
+  Ledger.Tx txera
+recomputeIntegrityHash pp languages tx = do
+  tx & bodyTxL . scriptIntegrityHashTxBodyL .~ integrityHash
+ where
+  integrityHash =
+    hashScriptIntegrity
+      (Set.fromList $ getLanguageView pp <$> languages)
+      (tx ^. witsTxL . rdmrsTxWitsL)
+      (tx ^. witsTxL . datsTxWitsL)
+
 -- | Explicit downgrade from Conway to Babbage era.
 --
--- NOTE: This is not a complete mapping and does silently drop things like
+-- XXX: This will invalidate the script integrity hash as datums and redeemers
+-- are serialized differently.
+--
+-- XXX: 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
+convertConwayTx :: Ledger.Tx Conway -> Ledger.Tx Babbage
+convertConwayTx tx =
+  mkBasicTx (translateBody $ tx ^. bodyTxL)
+    & witsTxL .~ translateWits (tx ^. witsTxL)
+    & isValidTxL .~ tx ^. isValidTxL
+    & auxDataTxL .~ (translateAlonzoTxAuxData <$> tx ^. auxDataTxL)
  where
-  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)
+    Ledger.ConwayTxBody Ledger.Conway ->
+    Ledger.BabbageTxBody Ledger.Babbage
   translateBody body =
     mkBasicTxBody
       & inputsTxBodyL .~ body ^. inputsTxBodyL
@@ -101,16 +177,16 @@ convertConwayTx =
       & collateralReturnTxBodyL .~ (translateTxOut <$> body ^. collateralReturnTxBodyL)
 
   translateTxOut ::
-    Ledger.BabbageTxOut (Ledger.ConwayEra StandardCrypto) ->
-    Ledger.BabbageTxOut (Ledger.BabbageEra StandardCrypto)
+    Ledger.BabbageTxOut Ledger.Conway ->
+    Ledger.BabbageTxOut Ledger.Babbage
   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)
+    Ledger.AlonzoTxWits Ledger.Conway ->
+    Ledger.AlonzoTxWits Ledger.Babbage
   translateWits wits =
     mkBasicTxWits
       & addrTxWitsL .~ wits ^. addrTxWitsL
@@ -120,8 +196,8 @@ convertConwayTx =
       & rdmrsTxWitsL .~ translateRdmrs (wits ^. rdmrsTxWitsL)
 
   translateScript ::
-    Ledger.AlonzoScript (Ledger.ConwayEra StandardCrypto) ->
-    Maybe (Ledger.AlonzoScript (Ledger.BabbageEra StandardCrypto))
+    Ledger.AlonzoScript Ledger.Conway ->
+    Maybe (Ledger.AlonzoScript Ledger.Babbage)
   translateScript = \case
     Ledger.TimelockScript ts -> Just . Ledger.TimelockScript $ translateTimelock ts
     Ledger.PlutusScript ps -> case ps of
@@ -130,8 +206,8 @@ convertConwayTx =
       ConwayPlutusV3{} -> Nothing
 
   translateRdmrs ::
-    Ledger.Redeemers (Ledger.ConwayEra StandardCrypto) ->
-    Ledger.Redeemers (Ledger.BabbageEra StandardCrypto)
+    Ledger.Redeemers Ledger.Conway ->
+    Ledger.Redeemers Ledger.Babbage
   translateRdmrs (Ledger.Redeemers redeemerMap) =
     Ledger.Redeemers
       . Map.fromList
@@ -143,68 +219,12 @@ convertConwayTx =
       $ Map.toList redeemerMap
 
   translatePlutusPurpose ::
-    Conway.ConwayPlutusPurpose Ledger.AsIx (Ledger.ConwayEra StandardCrypto) ->
-    Maybe (Ledger.AlonzoPlutusPurpose Ledger.AsIx (Ledger.BabbageEra StandardCrypto))
+    Conway.ConwayPlutusPurpose Ledger.AsIx Ledger.Conway ->
+    Maybe (Ledger.AlonzoPlutusPurpose Ledger.AsIx Ledger.Babbage)
   translatePlutusPurpose = \case
     ConwaySpending (AsIx ix) -> Just $ AlonzoSpending (AsIx ix)
     ConwayMinting (AsIx ix) -> Just $ AlonzoMinting (AsIx ix)
     ConwayCertifying (AsIx ix) -> Just $ AlonzoCertifying (AsIx ix)
     ConwayRewarding (AsIx ix) -> Just $ AlonzoRewarding (AsIx ix)
     ConwayVoting{} -> Nothing
     ConwayProposing{} -> Nothing
-
--- | Sign transaction using the provided secret key
--- It only works for tx not containing scripts.
--- You can't sign a script utxo with this.
-signTx ::
-  IsShelleyBasedEra era =>
-  SigningKey PaymentKey ->
-  Tx era ->
-  Tx era
-signTx signingKey (Tx body wits) =
-  makeSignedTransaction (witness : wits) body
- where
-  witness = makeShelleyKeyWitness shelleyBasedEra body (WitnessPaymentKey signingKey)
-
--- | Create a transaction spending all given `UTxO`.
-txSpendingUTxO :: UTxO -> Tx Era
-txSpendingUTxO utxo =
-  fromLedgerTx $
-    mkBasicTx
-      ( mkBasicTxBody
-          & inputsTxBodyL .~ (toLedgerTxIn `Set.map` inputs)
-      )
- where
-  inputs = UTxO.inputSet utxo
-
--- | Get the UTxO that are produced by some transaction.
--- XXX: Defined here to avoid cyclic module dependency
-utxoProducedByTx :: Tx Era -> UTxO
-utxoProducedByTx tx =
-  UTxO.fromPairs $
-    zip [0 ..] (txOuts body)
-      <&> bimap (mkTxIn tx) toCtxUTxOTxOut
- where
-  TxBody body = getTxBody tx
-
--- | Get explicit fees allocated to a transaction.
-txFee' :: Tx era -> Coin
-txFee' (getTxBody -> TxBody body) =
-  case txFee body of
-    TxFeeExplicit _ y -> y
-
--- * Type Conversions
-
--- | Convert a cardano-api 'Tx' into a matching cardano-ledger 'Tx'.
-toLedgerTx ::
-  Tx era ->
-  Ledger.Tx (ShelleyLedgerEra era)
-toLedgerTx (ShelleyTx _era tx) = tx
-
--- | Convert a cardano-ledger's 'Tx' in the Babbage era into a cardano-api 'Tx'.
-fromLedgerTx ::
-  IsShelleyBasedEra era =>
-  Ledger.Tx (ShelleyLedgerEra era) ->
-  Tx era
-fromLedgerTx =
-  ShelleyTx shelleyBasedEra
diff --git a/hydra-cardano-api/src/Hydra/Cardano/Api/TxOut.hs b/hydra-cardano-api/src/Hydra/Cardano/Api/TxOut.hs
@@ -144,12 +144,12 @@ isScriptTxOut script txOut =
 -- * Type Conversions
 
 -- | Convert a cardano-ledger 'TxOut' into a cardano-api 'TxOut'
-fromLedgerTxOut :: Ledger.TxOut (ShelleyLedgerEra Era) -> TxOut ctx Era
+fromLedgerTxOut :: IsShelleyBasedEra era => Ledger.TxOut (ShelleyLedgerEra era) -> TxOut ctx era
 fromLedgerTxOut =
   fromShelleyTxOut shelleyBasedEra
 
 -- | Convert a cardano-api 'TxOut' into a cardano-ledger 'TxOut'
-toLedgerTxOut :: TxOut CtxUTxO Era -> Ledger.TxOut (ShelleyLedgerEra Era)
+toLedgerTxOut :: IsShelleyBasedEra era => TxOut CtxUTxO era -> Ledger.TxOut (ShelleyLedgerEra era)
 toLedgerTxOut =
   toShelleyTxOut shelleyBasedEra
 

diff --git a/hydra-chain-observer/src/Hydra/ChainObserver.hs b/hydra-chain-observer/src/Hydra/ChainObserver.hs
@@ -23,9 +23,11 @@ import Hydra.Cardano.Api (
   UTxO,
   connectToLocalNode,
   convertConwayTx,
+  fromLedgerTx,
   getChainPoint,
   getTxBody,
   getTxId,
+  toLedgerTx,
   pattern Block,
  )
 import Hydra.Cardano.Api.Prelude (TxId)
@@ -181,7 +183,7 @@ chainSyncClient tracer networkId startingPoint observerHandler =
           traceWith tracer RollForward{point, receivedTxIds}
 
           let txs = case blockInMode of
-                BlockInMode ConwayEra (Block _ conwayTxs) -> map convertConwayTx conwayTxs
+                BlockInMode ConwayEra (Block _ conwayTxs) -> map (fromLedgerTx . convertConwayTx . toLedgerTx) conwayTxs
                 BlockInMode BabbageEra (Block _ babbageTxs) -> babbageTxs
                 _ -> []