Shuffle things around and add value preservation test for contest tx

hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs

@@ -27,6 +27,7 @@ import Hydra.Chain.Direct.Fixture (testNetworkId)
 import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.TimeHandle (PointInTime)
 import Hydra.Chain.Direct.Tx (ClosingSnapshot (..), OpenThreadOutput (..), UTxOHash (UTxOHash), closeTx, mkHeadId, mkHeadOutput)
+import Hydra.Chain.Direct.Util (addChangeOutput)
 import Hydra.ContestationPeriod (fromChain)
 import qualified Hydra.Contract.HeadState as Head
 import Hydra.Contract.HeadTokens (headPolicyId)
@@ -57,13 +58,14 @@ healthyCloseTx =
   (tx, lookupUTxO)
  where
   tx =
-    closeTx
-      somePartyCardanoVerificationKey
-      closingSnapshot
-      healthyCloseLowerBoundSlot
-      healthyCloseUpperBoundPointInTime
-      openThreadOutput
-      (mkHeadId Fixture.testPolicyId)
+    addChangeOutput $
+      closeTx
+        somePartyCardanoVerificationKey
+        closingSnapshot
+        healthyCloseLowerBoundSlot
+        healthyCloseUpperBoundPointInTime
+        openThreadOutput
+        (mkHeadId Fixture.testPolicyId)
 
   lookupUTxO = UTxO.singleton (healthyOpenHeadTxIn, healthyOpenHeadTxOut)
 
@@ -91,13 +93,14 @@ healthyCloseInitialTx =
   (tx, lookupUTxO)
  where
   tx =
-    closeTx
-      somePartyCardanoVerificationKey
-      closingSnapshot
-      healthyCloseLowerBoundSlot
-      healthyCloseUpperBoundPointInTime
-      openThreadOutput
-      (mkHeadId Fixture.testPolicyId)
+    addChangeOutput $
+      closeTx
+        somePartyCardanoVerificationKey
+        closingSnapshot
+        healthyCloseLowerBoundSlot
+        healthyCloseUpperBoundPointInTime
+        openThreadOutput
+        (mkHeadId Fixture.testPolicyId)
 
   lookupUTxO = UTxO.singleton (healthyOpenHeadTxIn, healthyOpenHeadTxOut)
 

hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs

@@ -30,7 +30,7 @@ import Hydra.Crypto (HydraKey, MultiSignature, aggregate, sign, toPlutusSignatur
 import Hydra.Data.ContestationPeriod (posixFromUTCTime)
 import qualified Hydra.Data.Party as OnChain
 import Hydra.Ledger (hashUTxO)
-import Hydra.Ledger.Cardano (genOneUTxOFor, genVerificationKey)
+import Hydra.Ledger.Cardano (genOneUTxOFor, genValue, genVerificationKey)
 import Hydra.Ledger.Cardano.Evaluate (slotNoToUTCTime)
 import Hydra.Party (Party, deriveParty, partyToChain)
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
@@ -171,6 +171,8 @@ data ContestMutation
     MutateHeadId
   | -- | Minting or burning of the tokens should not be possible in v_head apart from 'checkAbort' or 'checkFanout'
     MutateTokenMintingOrBurning
+  | -- | See spec: 5.5. rule 6 -> value is preserved
+    MutateValueInOutput
   deriving (Generic, Show, Enum, Bounded)
 
 genContestMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -227,6 +229,9 @@ genContestMutation
               ]
       , SomeMutation (Just "minting or burning is forbidden") MutateTokenMintingOrBurning
           <$> (changeMintedTokens tx =<< genMintedOrBurnedValue)
+      , SomeMutation (Just "head value is not preserved") MutateValueInOutput <$> do
+          newValue <- genValue
+          pure $ ChangeOutput 0 (headTxOut{txOutValue = newValue})
       ]
    where
     headTxOut = fromJust $ txOuts' tx !!? 0

hydra-plutus/src/Hydra/Contract/Head.hs

@@ -21,7 +21,7 @@ import PlutusTx.Prelude
 import Hydra.Contract.Commit (Commit (..))
 import qualified Hydra.Contract.Commit as Commit
 import Hydra.Contract.HeadState (Input (..), Signature, SnapshotNumber, State (..))
-import Hydra.Contract.Util (hasST, mustNotMintOrBurn)
+import Hydra.Contract.Util (hasST, headOutputValue, mustNotMintOrBurn, mustPreserveValue)
 import Hydra.Data.ContestationPeriod (ContestationPeriod, addContestationPeriod, milliseconds)
 import Hydra.Data.Party (Party (vkey))
 import Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator)
@@ -275,16 +275,9 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId =
     && mustBeSignedByParticipant ctx headPolicyId
     && hasST headPolicyId outValue
     && mustNotChangeParameters
-    && mustPreserveValue
+    && mustPreserveValue outValue headOutValue
  where
-  mustPreserveValue =
-    traceIfFalse "head value is not preserved" $
-      outValue == headOutputValue
-  headOutputValue =
-    case txInfoOutputs txInfo of
-      [headOutput, _] -> txOutValue headOutput
-      _ -> traceError "does not have exactly two outputs"
-
+  headOutValue = headOutputValue $ txInfoOutputs txInfo
   hasBoundedValidity =
     traceIfFalse "hasBoundedValidity check failed" $
       tMax - tMin <= cp
@@ -366,7 +359,9 @@ checkContest ctx contestationDeadline parties closedSnapshotNumber sig headId =
     && mustBeSignedByParticipant ctx headId
     && mustBeWithinContestationPeriod
     && hasST headId outValue
+    && mustPreserveValue outValue headOutValue
  where
+  headOutValue = headOutputValue $ txInfoOutputs txInfo
   outValue =
     maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
 

hydra-plutus/src/Hydra/Contract/Util.hs

@@ -8,6 +8,7 @@ import Plutus.V2.Ledger.Api (
   CurrencySymbol,
   TokenName (..),
   TxInfo (TxInfo, txInfoMint),
+  TxOut (txOutValue),
   Value (getValue),
  )
 import qualified PlutusTx.AssocMap as Map
@@ -46,3 +47,14 @@ mustNotMintOrBurn TxInfo{txInfoMint} =
   traceIfFalse "minting or burning is forbidden" $
     isZero txInfoMint
 {-# INLINEABLE mustNotMintOrBurn #-}
+
+mustPreserveValue :: Value -> Value -> Bool
+mustPreserveValue outValue headOutValue =
+  traceIfFalse "head value is not preserved" $
+    outValue == headOutValue
+{-# INLINEABLE mustPreserveValue #-}
+
+headOutputValue :: [TxOut] -> Value
+headOutputValue (headOutput : _outputs) = txOutValue headOutput
+headOutputValue _ = traceError "does not have at least head output"
+{-# INLINEABLE headOutputValue #-}