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

@@ -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
 

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

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.