From 795b0d37fb3dc450ef225cad80ddfa36e0b59630 Mon Sep 17 00:00:00 2001
From: Sebastian Nagel <sebastian.nagel@ncoding.at>
Date: Wed, 13 Mar 2024 10:36:33 +0100
Subject: [PATCH] Check value in Head is correctly decreased in decrementTx

This ensures that the value is in a head is correctly decreased by the
amount that was decommitted. We had to also fix the healthy case as it
was not having the whole value in the head output in the first place.
---
 hydra-node/src/Hydra/Chain/Direct/Tx.hs                | 10 ++++++++--
 .../test/Hydra/Chain/Direct/Contract/Decrement.hs      |  4 ++--
 hydra-plutus/src/Hydra/Contract/Head.hs                |  6 +++---
 3 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/hydra-node/src/Hydra/Chain/Direct/Tx.hs b/hydra-node/src/Hydra/Chain/Direct/Tx.hs
index ee6260c835d..e83bd16765f 100644
--- a/hydra-node/src/Hydra/Chain/Direct/Tx.hs
+++ b/hydra-node/src/Hydra/Chain/Direct/Tx.hs
@@ -370,7 +370,7 @@ decrementTx scriptRegistry vk headId headParameters (headInput, headOutput) snap
       & addInputs [(headInput, headWitness)]
       & addReferenceInputs [headScriptRef]
       -- NOTE: at this point 'utxoToDecommit' is populated
-      & addOutputs (headOutput' : map toTxContext (maybe [] toList utxoToDecommit))
+      & addOutputs (headOutput' : map toTxContext decommitOutputs)
       & addExtraRequiredSigners [verificationKeyHash vk]
  where
   headRedeemer =
@@ -385,7 +385,13 @@ decrementTx scriptRegistry vk headId headParameters (headInput, headOutput) snap
   HeadParameters{parties, contestationPeriod} = headParameters
 
   headOutput' =
-    modifyTxOutDatum (const headDatumAfter) headOutput
+    headOutput
+      & modifyTxOutDatum (const headDatumAfter)
+      & modifyTxOutValue (\v -> v <> negateValue decomittedValue)
+
+  decomittedValue = foldMap txOutValue decommitOutputs
+
+  decommitOutputs = maybe [] toList utxoToDecommit
 
   headScript = fromPlutusScript @PlutusScriptV2 Head.validatorScript
 
diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs
index 2c16af5725c..0fb01f74fff 100644
--- a/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs
+++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Decrement.hs
@@ -72,7 +72,7 @@ healthyDecrementTx =
   headOutput =
     mkHeadOutput testNetworkId testPolicyId (toUTxOContext $ mkTxOutDatumInline healthyDatum)
       & addParticipationTokens healthyParticipants
-      & modifyTxOutValue (<> lovelaceToValue 3_000_000)
+      & modifyTxOutValue (<> foldMap txOutValue healthyUTxO)
 
 somePartyCardanoVerificationKey :: VerificationKey PaymentKey
 somePartyCardanoVerificationKey =
@@ -185,7 +185,7 @@ genDecrementMutation (tx, utxo) =
     , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) DropDecommitOutput <$> do
         ix <- choose (1, length (txOuts' tx) - 1)
         pure $ RemoveOutput (fromIntegral ix)
-    , -- TODO: fix error code and maybe dry with CollectCom
+    , -- TODO: maybe dry with CollectCom
       SomeMutation (Just $ toErrorCode HeadValueIsNotPreserved) ExtractSomeValue <$> do
         -- Remove a random asset and quantity from headOutput
         removedValue <- do
diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs
index 192601adeb1..f2b167a7587 100644
--- a/hydra-plutus/src/Hydra/Contract/Head.hs
+++ b/hydra-plutus/src/Hydra/Contract/Head.hs
@@ -242,7 +242,7 @@ checkDecrement ctx@ScriptContext{scriptContextTxInfo = txInfo} prevParties prevS
     && checkSnapshot
     && checkSnapshotSignature
     && mustBeSignedByParticipant ctx prevHeadId
-    && mustPreserveValue
+    && mustDecreaseValue
  where
   mustNotChangeParameters =
     traceIfFalse $(errorCode ChangedParameters) $
@@ -257,9 +257,9 @@ checkDecrement ctx@ScriptContext{scriptContextTxInfo = txInfo} prevParties prevS
   checkSnapshotSignature =
     verifySnapshotSignature nextParties nextHeadId nextSnapshotNumber nextUtxoHash decommitUtxoHash signature
 
-  mustPreserveValue =
+  mustDecreaseValue =
     traceIfFalse $(errorCode HeadValueIsNotPreserved) $
-      headInValue === headOutValue
+      headInValue === headOutValue <> foldMap txOutValue decommitOutputs
 
   -- NOTE: we always assume Head output is the first one so we pick all other
   -- outputs of a decommit tx to calculate the expected hash.