Fix handling of reward redeemers on commit transaction (#1690)

## Why

fix #1643

Our commit transaction was accounting only for the spending redeemers
and discarded the minting, rewarding etc.

## What

Keep the existing redeemers intact and only adjust the spending
redeemers accounting for the new initial input to spend.

---

<!-- Consider each and tick it off one way or the other -->
* [x] CHANGELOG updated or not needed
* [x] Documentation updated or not needed
* [x] Haddocks updated or not needed
* [x] No new TODOs introduced or explained herafter

CHANGELOG.md

@@ -21,13 +21,16 @@ changes.
       - Remove Commit client input since it is unused
       - Revisit types related to observations/posting transactions and make sure the fields are named appropriatelly
 
+
 - Tested with `cardano-node 9.2.0` and `cardano-cli 9.4.1.0`.
 
 - **BREAKING** Rewrite of the commit script in aiken:
   - This makes `abort` and `collectCom` transactions more efficient and results
     in a new maximum number of head participants being `8`.
   - Changes script hashes in `hydra-plutus`
 
+- Fix the bug where commit endpoint drops withdraw redeemers [#1643](https://github.com/cardano-scaling/hydra/issues/1643)
+
 ## [0.19.0] - 2024-09-13
 
 - Tested with `cardano-node 9.1.1` and `cardano-cli 9.2.1.0`

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

@@ -61,6 +61,7 @@ library
     Hydra.Cardano.Api.ScriptData
     Hydra.Cardano.Api.ScriptDatum
     Hydra.Cardano.Api.ScriptHash
+    Hydra.Cardano.Api.StakeAddress
     Hydra.Cardano.Api.Tx
     Hydra.Cardano.Api.TxBody
     Hydra.Cardano.Api.TxId

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

@@ -141,6 +141,7 @@ import Hydra.Cardano.Api.ReferenceScript as Extras
 import Hydra.Cardano.Api.ScriptData as Extras
 import Hydra.Cardano.Api.ScriptDatum as Extras
 import Hydra.Cardano.Api.ScriptHash as Extras
+import Hydra.Cardano.Api.StakeAddress as Extras
 import Hydra.Cardano.Api.Tx as Extras hiding (Tx)
 import Hydra.Cardano.Api.TxBody as Extras
 import Hydra.Cardano.Api.TxId as Extras

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

@@ -0,0 +1,15 @@
+module Hydra.Cardano.Api.StakeAddress where
+
+import Hydra.Cardano.Api.Prelude
+
+-- | Construct a stake address from a Plutus script.
+mkScriptStakeAddress ::
+  forall lang.
+  IsPlutusScriptLanguage lang =>
+  NetworkId ->
+  PlutusScript lang ->
+  StakeAddress
+mkScriptStakeAddress networkId script =
+  makeStakeAddress networkId $ StakeCredentialByScript $ hashScript $ PlutusScript version script
+ where
+  version = plutusScriptVersion @lang

hydra-node/test/Hydra/Chain/Direct/TxSpec.hs

@@ -9,7 +9,7 @@ import Cardano.Api.UTxO qualified as UTxO
 import Cardano.Ledger.Alonzo.Core (EraTxAuxData (hashTxAuxData))
 import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..))
 import Cardano.Ledger.Api (
-  ConwayPlutusPurpose (ConwaySpending),
+  ConwayPlutusPurpose (ConwayRewarding, ConwaySpending),
   Metadatum,
   auxDataHashTxBodyL,
   auxDataTxL,
@@ -83,6 +83,7 @@ import Test.QuickCheck (
   cover,
   forAll,
   forAllBlind,
+  oneof,
   property,
   vectorOf,
   (.&&.),
@@ -186,6 +187,9 @@ spec =
                       & counterexample "Validity range mismatch"
                   , (blueprintBody ^. inputsTxBodyL) `propIsSubsetOf` (commitTxBody ^. inputsTxBodyL)
                       & counterexample "Blueprint inputs missing"
+                  , length (toLedgerTx blueprintTx ^. witsTxL . rdmrsTxWitsL & unRedeemers) + 1
+                      === length (toLedgerTx createdTx ^. witsTxL . rdmrsTxWitsL & unRedeemers)
+                      & counterexample "Blueprint witnesses missing"
                   , property
                       ((`all` (blueprintBody ^. outputsTxBodyL)) (`notElem` (commitTxBody ^. outputsTxBodyL)))
                       & counterexample "Blueprint outputs not discarded"
@@ -233,6 +237,7 @@ genBlueprintTxWithUTxO =
       >>= addValidityRange
       >>= addRandomMetadata
       >>= addCollateralInput
+      >>= sometimesAddRewardRedeemer
  where
   spendingPubKeyOutput (utxo, txbody) = do
     utxoToSpend <- genUTxOAdaOnlyOfSize =<< choose (0, 3)
@@ -287,6 +292,31 @@ genBlueprintTxWithUTxO =
       , txbody{txInsCollateral = TxInsCollateral $ toList (UTxO.inputSet utxoToSpend)}
       )
 
+  sometimesAddRewardRedeemer (utxo, txbody) =
+    oneof
+      [ pure (utxo, txbody)
+      , do
+          lovelace <- arbitrary
+          let scriptWitness = mkScriptWitness alwaysSucceedingScript NoScriptDatumForStake redeemer
+              alwaysSucceedingScript = PlutusScriptSerialised $ Plutus.alwaysSucceedingNAryFunction 2
+              redeemer = toScriptData (123 :: Integer)
+              stakeAddress = mkScriptStakeAddress testNetworkId alwaysSucceedingScript
+          pure
+            ( utxo
+            , txbody
+                & setTxWithdrawals
+                  ( TxWithdrawals
+                      shelleyBasedEra
+                      [
+                        ( stakeAddress
+                        , lovelace
+                        , BuildTxWith $ ScriptWitness ScriptWitnessForStakeAddr scriptWitness
+                        )
+                      ]
+                  )
+            )
+      ]
+
 genMetadata :: Gen TxMetadataInEra
 genMetadata = do
   genMetadata' @LedgerEra >>= \(ShelleyTxAuxData m) ->
@@ -307,7 +337,18 @@ prop_interestingBlueprintTx = do
       & cover 1 (spendsFromPubKey (utxo, tx)) "blueprint spends pub key UTxO"
       & cover 1 (spendsFromPubKey (utxo, tx) && spendsFromScript (utxo, tx)) "blueprint spends from script AND pub key"
       & cover 1 (hasReferenceInputs tx) "blueprint has reference input"
+      & cover 1 (hasRewardRedeemer tx) "blueprint has reward redeemer"
  where
+  hasRewardRedeemer tx =
+    toLedgerTx tx ^. witsTxL . rdmrsTxWitsL
+      & unRedeemers @LedgerEra
+      & Map.keysSet
+      & any
+        ( \case
+            ConwayRewarding _ -> True
+            _ -> False
+        )
+
   hasReferenceInputs tx =
     not . null $ toLedgerTx tx ^. bodyTxL . referenceInputsTxBodyL
 

hydra-tx/src/Hydra/Tx/Commit.hs

@@ -76,21 +76,22 @@ commitTx networkId scriptRegistry headId party commitBlueprintTx (initialInput,
      in tx
           & bodyTxL . inputsTxBodyL .~ newInputs
           & bodyTxL . referenceInputsTxBodyL <>~ Set.singleton (toLedgerTxIn initialScriptRef)
-          & witsTxL . rdmrsTxWitsL .~ mkRedeemers newRedeemers newInputs
+          & witsTxL . rdmrsTxWitsL
+            .~ Redeemers (fromList $ nonSpendingRedeemers tx)
+              <> Redeemers (fromList $ 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 ->
-                    (ConwaySpending (AsIx ix), (d, ExUnits 0 0)) : newRedeemerData
-        )
-        []
-        inputs
+    foldl'
+      ( \newRedeemerData txin ->
+          let ix = fromIntegral $ Set.findIndex txin inputs
+           in case Map.lookup txin resolved of
+                Nothing -> newRedeemerData
+                Just d ->
+                  (ConwaySpending (AsIx ix), (d, ExUnits 0 0)) : newRedeemerData
+      )
+      []
+      inputs
 
   -- Create a TxIn -> Data map of all spending redeemers
   resolveSpendingRedeemers tx =
@@ -103,6 +104,19 @@ commitTx networkId scriptRegistry headId party commitBlueprintTx (initialInput,
       )
       (unRedeemers $ tx ^. witsTxL . rdmrsTxWitsL)
 
+  nonSpendingRedeemers tx =
+    Map.foldMapWithKey
+      ( \p (d, ex) ->
+          case redeemerPointerInverse (tx ^. bodyTxL) p of
+            SJust (ConwayMinting (AsIxItem i _)) -> [(ConwayMinting (AsIx i), (d, ex))]
+            SJust (ConwayRewarding (AsIxItem i _)) -> [(ConwayRewarding (AsIx i), (d, ex))]
+            SJust (ConwayCertifying (AsIxItem i _)) -> [(ConwayCertifying (AsIx i), (d, ex))]
+            SJust (ConwayProposing (AsIxItem i _)) -> [(ConwayProposing (AsIx i), (d, ex))]
+            SJust (ConwayVoting (AsIxItem i _)) -> [(ConwayVoting (AsIx i), (d, ex))]
+            SJust (ConwaySpending (AsIxItem _ _)) -> []
+            SNothing -> []
+      )
+      (unRedeemers $ tx ^. witsTxL . rdmrsTxWitsL)
   initialScriptRef =
     fst (initialReference scriptRegistry)