PR review changes

input-output-hk · Apr 17, 2024 · 4581693 · 4581693
1 parent 1a1db19
commit 4581693
Show file tree

Hide file tree

Showing 3 changed files with 55 additions and 49 deletions.
diff --git a/hydra-cluster/test/Test/DirectChainSpec.hs b/hydra-cluster/test/Test/DirectChainSpec.hs
@@ -524,10 +524,10 @@ externalCommit ::
   HeadId ->
   UTxO' (TxOut CtxUTxO) ->
   IO ()
-externalCommit node hydraClient externalSk headId utxoToCommit' = do
-  let utxoToCommit = utxoToTxOutWithWitness utxoToCommit'
-      blueprintTx = mkBlueprintTx utxoToCommit
-      utxo = utxoFromTxOutWithWitness utxoToCommit
+externalCommit node hydraClient externalSk headId utxoToCommit = do
+  let utxoToCommit' = utxoToTxOutWithWitness utxoToCommit
+      blueprintTx = mkBlueprintTx utxoToCommit'
+      utxo = utxoFromTxOutWithWitness utxoToCommit'
   commitTx <- draftCommitTx headId utxo blueprintTx
   let signedTx = signTx externalSk commitTx
   submitTx node signedTx

diff --git a/hydra-node/src/Hydra/Chain/Direct/Handlers.hs b/hydra-node/src/Hydra/Chain/Direct/Handlers.hs
@@ -193,14 +193,14 @@ finalizeTx TinyWallet{sign, coverFee} ctx utxo userUTxO partialTx = do
       throwIO (NoFuelUTXOFound :: PostTxError Tx)
     Left ErrNotEnoughFunds{} ->
       throwIO (NotEnoughFuel :: PostTxError Tx)
-    Left ErrScriptExecutionFailed{scriptFailure = (redeemerPtr, scriptFailure)} -> do
-      let postTxError =
-            ScriptFailedInWallet
+    Left ErrScriptExecutionFailed{scriptFailure = (redeemerPtr, scriptFailure)} ->
+      throwIO
+            (ScriptFailedInWallet
               { redeemerPtr = show redeemerPtr
               , failureReason = show scriptFailure
               } ::
               PostTxError Tx
-      throwIO postTxError
+            )
     Left e ->
       throwIO
         ( InternalWalletError

diff --git a/hydra-node/src/Hydra/Chain/Direct/Tx.hs b/hydra-node/src/Hydra/Chain/Direct/Tx.hs
@@ -18,6 +18,7 @@ import Cardano.Ledger.Alonzo.TxAuxData (hashAlonzoTxAuxData)
 import Cardano.Ledger.Api (
   AlonzoPlutusPurpose (..),
   AsIndex (..),
+  Data,
   Redeemers (..),
   auxDataHashTxBodyL,
   auxDataTxL,
@@ -266,26 +267,57 @@ commitTx networkId scriptRegistry headId party utxoToCommit blueprintTx (initial
     blueprintRedeemer = unRedeemers $ toLedgerTx blueprintTx ^. witsTxL . rdmrsTxWitsL
     reAssociatedTxIns = reAssociateOldInputs currentInputs commitInputs blueprintRedeemer
     wits =
-      existingWits
-        & rdmrsTxWitsL .~ rebuildRedeemers reAssociatedTxIns (initialInput, initialRedeemer)
+      witsTxL
+        .~ ( existingWits
+              & rdmrsTxWitsL .~ rebuildRedeemers reAssociatedTxIns (initialInput, initialRedeemer)
+           )
    in
-    fromLedgerTx $ ledgerBlueprintTx & witsTxL .~ wits
+    fromLedgerTx $ ledgerBlueprintTx & wits
  where
+  -- Re-Associate the redeemer indices present in some tx with the same inputs but different
+  -- indices in the current tx.
+  --
+  -- We need this in order to be able to find the the _old_ tx redeemer and re-add
+  -- it to the tx witnesses using the appropriate index of the _new_ tx input
+  -- because of the 'TxIn' re-ordering.
+  reAssociateOldInputs ::
+    Set (Ledger.TxIn StandardCrypto) ->
+    Set TxIn ->
+    Map (AlonzoPlutusPurpose AsIndex era) a ->
+    [(Ledger.TxIn StandardCrypto, Int, Maybe a)]
+  reAssociateOldInputs newInputs oldInputs oldTxRedeemers =
+    ( \txin ->
+        let currentIndex = Set.findIndex txin newInputs
+         in case fromLedgerTxIn txin `Set.lookupIndex` oldInputs of
+              Nothing -> (txin, currentIndex, Nothing)
+              -- if we found the 'TxIn' in the old inputs, we need to get the
+              -- redeemer value from the old tx and re-associate it with the new
+              Just ix ->
+                ( txin
+                , currentIndex
+                , Map.lookup (AlonzoSpending (AsIndex $ fromIntegral ix)) oldTxRedeemers
+                )
+    )
+      <$> toList newInputs
+
+  rebuildRedeemers :: [(Ledger.TxIn StandardCrypto, Int, Maybe (Data LedgerEra, ExUnits))] -> (TxIn, HashableScriptData) -> Redeemers LedgerEra
   rebuildRedeemers associatedTxIns (initialInput', initialRedeemer') =
     Redeemers $ insertRedeemers Map.empty (toList associatedTxIns)
    where
-    insertRedeemers r [] = r
-    insertRedeemers r ((txin, i, mBlueprintRedeemer) : rest) =
-      let key = AlonzoSpending (AsIndex $ fromIntegral i)
-       in case mBlueprintRedeemer of
-            Nothing ->
-              -- make sure to add the initial redeemer to the commit tx
-              -- if the input is matched
-              if txin == toLedgerTxIn initialInput'
-                then insertRedeemers (Map.insert key (toLedgerData @LedgerEra initialRedeemer', ExUnits 0 0) r) (fromList rest)
-                else insertRedeemers r (fromList rest)
-            Just blueprintRedeemer ->
-              insertRedeemers (Map.insert key blueprintRedeemer r) (fromList rest)
+    insertRedeemers r associatedRedeemers =
+      case associatedRedeemers of
+        [] -> r
+        ((txin, i, mBlueprintRedeemer) : rest) ->
+          let key = AlonzoSpending (AsIndex $ fromIntegral i)
+           in case mBlueprintRedeemer of
+                Nothing ->
+                  -- make sure to add the initial redeemer to the commit tx
+                  -- if the input is matched
+                  if txin == toLedgerTxIn initialInput'
+                    then insertRedeemers (Map.insert key (toLedgerData @LedgerEra initialRedeemer', ExUnits 0 0) r) (fromList rest)
+                    else insertRedeemers r (fromList rest)
+                Just blueprintRedeemer ->
+                  insertRedeemers (Map.insert key blueprintRedeemer r) (fromList rest)
 
   initialScript =
     fromPlutusScript @PlutusScriptV2 Initial.validatorScript
@@ -319,32 +351,6 @@ commitTx networkId scriptRegistry headId party utxoToCommit blueprintTx (initial
 
   txAuxMetadata = mkAlonzoTxAuxData @[] @LedgerEra (toShelleyMetadata metadataMap) [toLedgerScript initialScript]
 
--- Re-Associate the redeemer indices present in some tx with the same inputs but different
--- indices in the current tx.
---
--- We need this in order to be able to find the the _old_ tx redeemer and re-add
--- it to the tx witnesses using the appropriate index of the _new_ tx input
--- because of the 'TxIn' re-ordering.
-reAssociateOldInputs ::
-  Set (Ledger.TxIn StandardCrypto) ->
-  Set TxIn ->
-  Map (AlonzoPlutusPurpose AsIndex era) a ->
-  [(Ledger.TxIn StandardCrypto, Int, Maybe a)]
-reAssociateOldInputs newInputs oldInputs oldTxRedeemers =
-  ( \txin ->
-      let currentIndex = Set.findIndex txin newInputs
-       in case fromLedgerTxIn txin `Set.lookupIndex` oldInputs of
-            Nothing -> (txin, currentIndex, Nothing)
-            -- if we found the 'TxIn' in the old inputs, we need to get the
-            -- redeemer value from the old tx and re-associate it with the new
-            Just ix ->
-              ( txin
-              , currentIndex
-              , Map.lookup (AlonzoSpending (AsIndex $ fromIntegral ix)) oldTxRedeemers
-              )
-  )
-    <$> toList newInputs
-
 mkCommitDatum :: Party -> UTxO -> CurrencySymbol -> Plutus.Datum
 mkCommitDatum party utxo headId =
   Commit.datum (partyToChain party, commits, headId)