Merge pull request #1409 from input-output-hk/validate-tx-metadata

Combine blueprint and commit tx metadata

CHANGELOG.md

@@ -10,11 +10,10 @@ changes.
 
 ## [0.17.0] - UNRELEASED
 
-- **BREAKING** `hydra-node` `/commit` enpoint now also accepts a _blueprint/draft_
-  transaction together with the `UTxO` which is spent in this transaction. `hydra-node` can
-  still be used like before if the provided `UTxO` is at public key address. In order to spend
-  from a script `UTxO`, and also unlock more involved use-cases, users need to provide additional
-  unsigned transaction that correctly specifies required data (like redeemers, validity ranges etc.)
+- **BREAKING** Change `hydra-node` API `/commit` endpoint for committing from scripts:o
+  - Instead of the custom `witness` extension of `UTxO`, the endpoint now accepts a _blueprint_ transaction together with the `UTxO` which is spent in this transaction.
+  - Usage is still the same for commiting "normal" `UTxO` owned by public key addresses.
+  - Spending from a script `UTxO` now needs the `blueprintTx` request type, which also unlocks more involved use-cases, where the commit transaction should also satisfy script spending constraints (like additional signers, validity ranges etc.)
 
 - Update navigation and re-organized documentation website https://hydra.family
   - Updated logos

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

@@ -102,8 +102,10 @@ import Cardano.Api.Shelley as X (
   fromAlonzoCostModels,
   fromAlonzoPrices,
   fromPlutusData,
+  fromShelleyMetadata,
   toAlonzoPrices,
   toPlutusData,
+  toShelleyMetadata,
   toShelleyNetwork,
  )
 import Cardano.Api.UTxO (

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

@@ -2,13 +2,6 @@ module Hydra.Cardano.Api.Tx where
 
 import Hydra.Cardano.Api.Prelude
 
-import Hydra.Cardano.Api.KeyWitness (
-  fromLedgerTxWitness,
-  toLedgerBootstrapWitness,
-  toLedgerKeyWitness,
- )
-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
@@ -31,7 +24,6 @@ import Cardano.Ledger.Api (
   dataTxOutL,
   datsTxWitsL,
   feeTxBodyL,
-  hashScriptTxWitsL,
   inputsTxBodyL,
   isValidTxL,
   mintTxBodyL,
@@ -54,9 +46,8 @@ import Cardano.Ledger.Api (
  )
 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.BaseTypes (maybeToStrictMaybe)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Scripts (PlutusScript (..))
 import Cardano.Ledger.Conway.Scripts qualified as Conway
@@ -206,53 +197,14 @@ txFee' (getTxBody -> TxBody body) =
 
 -- | Convert a cardano-api 'Tx' into a matching cardano-ledger 'Tx'.
 toLedgerTx ::
-  forall era.
-  ( Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto
-  , Ledger.AlonzoEraTx (ShelleyLedgerEra era)
-  ) =>
   Tx era ->
   Ledger.Tx (ShelleyLedgerEra era)
-toLedgerTx = \case
-  Tx (ShelleyTxBody _era body scripts scriptsData auxData validity) vkWits ->
-    let (datums, redeemers) =
-          case scriptsData of
-            TxBodyScriptData _ ds rs -> (ds, rs)
-            TxBodyNoScriptData -> (mempty, Ledger.Redeemers mempty)
-        wits =
-          mkBasicTxWits
-            & addrTxWitsL .~ toLedgerKeyWitness vkWits
-            & bootAddrTxWitsL .~ toLedgerBootstrapWitness vkWits
-            & hashScriptTxWitsL .~ scripts
-            & datsTxWitsL .~ datums
-            & rdmrsTxWitsL .~ redeemers
-     in mkBasicTx body
-          & isValidTxL .~ toLedgerScriptValidity validity
-          & auxDataTxL .~ maybeToStrictMaybe auxData
-          & witsTxL .~ wits
+toLedgerTx (ShelleyTx _era tx) = tx
 
 -- | Convert a cardano-ledger's 'Tx' in the Babbage era into a cardano-api 'Tx'.
-fromLedgerTx :: Ledger.Tx (ShelleyLedgerEra Era) -> Tx Era
-fromLedgerTx ledgerTx =
-  Tx
-    (ShelleyTxBody shelleyBasedEra body scripts scriptsData (strictMaybeToMaybe auxData) validity)
-    (fromLedgerTxWitness wits)
- where
-  -- XXX: The suggested way (by the ledger team) forward is to use lenses to
-  -- introspect ledger transactions.
-  Ledger.AlonzoTx body wits isValid auxData = ledgerTx
-
-  scripts =
-    Map.elems $ Ledger.txscripts' wits
-
-  scriptsData :: TxBodyScriptData Era
-  scriptsData =
-    TxBodyScriptData
-      alonzoEraOnwards
-      (Ledger.txdats' wits)
-      (Ledger.txrdmrs' wits)
-
-  validity = case isValid of
-    Ledger.IsValid True ->
-      TxScriptValidity alonzoEraOnwards ScriptValid
-    Ledger.IsValid False ->
-      TxScriptValidity alonzoEraOnwards ScriptInvalid
+fromLedgerTx ::
+  IsShelleyBasedEra era =>
+  Ledger.Tx (ShelleyLedgerEra era) ->
+  Tx era
+fromLedgerTx =
+  ShelleyTx shelleyBasedEra

hydra-node/hydra-node.cabal

@@ -341,7 +341,7 @@ test-suite tests
     , cardano-ledger-babbage:{cardano-ledger-babbage, testlib}
     , cardano-ledger-core
     , cardano-ledger-mary
-    , cardano-ledger-shelley
+    , cardano-ledger-shelley:{cardano-ledger-shelley, testlib}
     , cardano-slotting
     , cardano-strict-containers
     , cborg

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

@@ -14,24 +14,26 @@ import Hydra.Prelude
 
 import Cardano.Api.UTxO qualified as UTxO
 import Cardano.Ledger.Alonzo.Scripts (ExUnits (..))
-import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..), hashAlonzoTxAuxData)
+import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
 import Cardano.Ledger.Api (
   AlonzoPlutusPurpose (..),
   AsIndex (..),
+  AsItem (..),
+  EraTxAuxData (hashTxAuxData),
   Redeemers (..),
   auxDataHashTxBodyL,
   auxDataTxL,
   bodyTxL,
   inputsTxBodyL,
   mintTxBodyL,
-  mkAlonzoTxAuxData,
   outputsTxBodyL,
   rdmrsTxWitsL,
   referenceInputsTxBodyL,
   reqSignerHashesTxBodyL,
   unRedeemers,
   witsTxL,
  )
+import Cardano.Ledger.Babbage.Core (redeemerPointerInverse)
 import Cardano.Ledger.BaseTypes (StrictMaybe (..))
 import Control.Lens ((.~), (<>~), (^.))
 import Data.Aeson qualified as Aeson
@@ -41,7 +43,6 @@ import Data.Map qualified as Map
 import Data.Sequence.Strict qualified as StrictSeq
 import Data.Set qualified as Set
 import Hydra.Cardano.Api.Network (networkIdToNetwork)
-import Hydra.Cardano.Api.Prelude (toShelleyMetadata)
 import Hydra.Chain (CommitBlueprintTx (..), HeadParameters (..))
 import Hydra.Chain.Direct.ScriptRegistry (ScriptRegistry (..))
 import Hydra.Chain.Direct.TimeHandle (PointInTime)
@@ -247,74 +248,73 @@ commitTx ::
   (TxIn, TxOut CtxUTxO, Hash PaymentKey) ->
   Tx
 commitTx networkId scriptRegistry headId party commitBlueprintTx (initialInput, out, vkh) =
-  let
-    ledgerBlueprintTx =
-      toLedgerTx blueprintTx
-        & bodyTxL . inputsTxBodyL <>~ Set.singleton (toLedgerTxIn initialInput)
-        & bodyTxL . referenceInputsTxBodyL <>~ Set.fromList [toLedgerTxIn initialScriptRef]
-        & bodyTxL . outputsTxBodyL .~ StrictSeq.singleton (toLedgerTxOut commitOutput)
-        & bodyTxL . reqSignerHashesTxBodyL <>~ Set.singleton (toLedgerKeyHash vkh)
-        & bodyTxL . auxDataHashTxBodyL .~ SJust (hashAlonzoTxAuxData txAuxMetadata)
-        & bodyTxL . mintTxBodyL .~ mempty
-        & auxDataTxL .~ addMetadata txAuxMetadata
-    existingWits = toLedgerTx blueprintTx ^. witsTxL
-    allInputs = ledgerBlueprintTx ^. bodyTxL . inputsTxBodyL
-    blueprintRedeemers = unRedeemers $ toLedgerTx blueprintTx ^. witsTxL . rdmrsTxWitsL
-    resolved = resolveRedeemers blueprintRedeemers committedTxIns
-    wits =
-      witsTxL
-        .~ ( existingWits
-              & rdmrsTxWitsL .~ Redeemers (Map.fromList $ reassociate resolved allInputs)
-           )
-   in
-    fromLedgerTx $ ledgerBlueprintTx & wits
+  -- NOTE: We use the cardano-ledger-api functions here such that we can use the
+  -- blueprint transaction as a starting point (cardano-api does not allow
+  -- convenient transaction modifications).
+  fromLedgerTx $
+    toLedgerTx blueprintTx
+      & spendFromInitial
+      & bodyTxL . outputsTxBodyL .~ StrictSeq.singleton (toLedgerTxOut commitOutput)
+      & bodyTxL . reqSignerHashesTxBodyL <>~ Set.singleton (toLedgerKeyHash vkh)
+      & bodyTxL . mintTxBodyL .~ mempty
+      & addMetadata (mkHydraHeadV1TxName "CommitTx")
  where
-  addMetadata newMetadata@(AlonzoTxAuxData metadata' _ _) =
-    case toLedgerTx blueprintTx ^. auxDataTxL of
-      SNothing -> SJust newMetadata
-      SJust (AlonzoTxAuxData metadata timeLocks languageMap) ->
-        SJust $
-          AlonzoTxAuxData
-            (Map.union metadata metadata')
-            timeLocks
-            languageMap
-
-  -- re-associates final commit tx inputs with the redeemer data from blueprint tx
-  reassociate resolved allInputs =
-    foldl'
-      ( \newRedeemerData txin ->
-          let key = mkSpendingKey $ Set.findIndex txin allInputs
-           in case find (\(txin', _) -> txin == txin') resolved of
-                Nothing -> newRedeemerData
-                Just (_, d) ->
-                  (key, d) : newRedeemerData
-      )
-      []
-      allInputs
-
-  -- Creates a list of 'TxIn' paired with redeemer data and also adds the initial txIn and it's redeemer.
-  resolveRedeemers existingRedeemerMap blueprintInputs =
-    (toLedgerTxIn initialInput, (toLedgerData @LedgerEra initialRedeemer, ExUnits 0 0))
-      : foldl'
-        ( \pairs txin ->
-            let key = mkSpendingKey $ Set.findIndex txin blueprintInputs
-             in case Map.lookup key existingRedeemerMap of
-                  Nothing -> pairs
-                  Just d -> (txin, d) : pairs
+  addMetadata (TxMetadata newMetadata) tx =
+    let
+      newMetadataMap = toShelleyMetadata newMetadata
+      newAuxData =
+        case toLedgerTx blueprintTx ^. auxDataTxL of
+          SNothing -> AlonzoTxAuxData newMetadataMap mempty mempty
+          SJust (AlonzoTxAuxData metadata timeLocks languageMap) ->
+            AlonzoTxAuxData (Map.union metadata newMetadataMap) timeLocks languageMap
+     in
+      tx
+        & auxDataTxL .~ SJust newAuxData
+        & bodyTxL . auxDataHashTxBodyL .~ SJust (hashTxAuxData newAuxData)
+
+  spendFromInitial tx =
+    let newRedeemers =
+          resolveSpendingRedeemers tx
+            & Map.insert (toLedgerTxIn initialInput) (toLedgerData @LedgerEra initialRedeemer)
+        newInputs = tx ^. bodyTxL . inputsTxBodyL <> Set.singleton (toLedgerTxIn initialInput)
+     in tx
+          & bodyTxL . inputsTxBodyL .~ newInputs
+          & bodyTxL . referenceInputsTxBodyL <>~ Set.singleton (toLedgerTxIn initialScriptRef)
+          & witsTxL . rdmrsTxWitsL .~ mkRedeemers newRedeemers newInputs
+
+  -- Make redeemers (with zeroed units) from a TxIn -> Data map and a set of transaction inputs
+  mkRedeemers resolved inputs =
+    Redeemers . Map.fromList $
+      foldl'
+        ( \newRedeemerData txin ->
+            let ix = fromIntegral $ Set.findIndex txin inputs
+             in case Map.lookup txin resolved of
+                  Nothing -> newRedeemerData
+                  Just d ->
+                    (AlonzoSpending (AsIndex ix), (d, ExUnits 0 0)) : newRedeemerData
         )
         []
-        committedTxIns
-
-  mkSpendingKey i = AlonzoSpending (AsIndex $ fromIntegral i)
+        inputs
+
+  -- Create a TxIn -> Data map of all spending redeemers
+  resolveSpendingRedeemers tx =
+    Map.foldMapWithKey
+      ( \p (d, _ex) ->
+          -- XXX: Should soon be available through cardano-ledger-api again
+          case redeemerPointerInverse (tx ^. bodyTxL) p of
+            SJust (AlonzoSpending (AsItem txIn)) -> Map.singleton txIn d
+            _ -> mempty
+      )
+      (unRedeemers $ tx ^. witsTxL . rdmrsTxWitsL)
 
   initialScriptRef =
     fst (initialReference scriptRegistry)
 
   initialRedeemer =
     toScriptData . Initial.redeemer $
-      Initial.ViaCommit (toPlutusTxOutRef . fromLedgerTxIn <$> Set.toList committedTxIns)
+      Initial.ViaCommit (toPlutusTxOutRef <$> committedTxIns)
 
-  committedTxIns = toLedgerTx blueprintTx ^. bodyTxL . inputsTxBodyL
+  committedTxIns = txIns' blueprintTx
 
   commitOutput =
     TxOut commitAddress commitValue commitDatum ReferenceScriptNone
@@ -326,17 +326,14 @@ commitTx networkId scriptRegistry headId party commitBlueprintTx (initialInput,
     mkScriptAddress @PlutusScriptV2 networkId commitScript
 
   utxoToCommit =
-    UTxO.fromPairs $ mapMaybe (\txin -> (txin,) <$> UTxO.resolve txin lookupUTxO) (txIns' blueprintTx)
+    UTxO.fromPairs $ mapMaybe (\txin -> (txin,) <$> UTxO.resolve txin lookupUTxO) committedTxIns
 
   commitValue =
     txOutValue out <> foldMap txOutValue utxoToCommit
 
   commitDatum =
     mkTxOutDatumInline $ mkCommitDatum party utxoToCommit (headIdToCurrencySymbol headId)
 
-  TxMetadata metadataMap = mkHydraHeadV1TxName "CommitTx"
-
-  txAuxMetadata = mkAlonzoTxAuxData @[] @LedgerEra (toShelleyMetadata metadataMap) []
   CommitBlueprintTx{lookupUTxO, blueprintTx} = commitBlueprintTx
 
 mkCommitDatum :: Party -> UTxO -> CurrencySymbol -> Plutus.Datum