Shuffle things around and add value preservation test for contest tx

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

@@ -28,6 +28,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)
@@ -58,13 +59,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)
 
@@ -92,13 +94,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

@@ -31,7 +31,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)
@@ -179,6 +179,8 @@ data ContestMutation
     MutateInputContesters
   | -- | Change the resulting contesters arbitrarily to see if they are checked
     MutateContesters
+  | -- | See spec: 5.5. rule 6 -> value is preserved
+    MutateValueInOutput
   deriving (Generic, Show, Enum, Bounded)
 
 genContestMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -251,6 +253,9 @@ genContestMutation
           hashes <- listOf genHash
           let mutatedContesters = Plutus.PubKeyHash . toBuiltin <$> hashes
           pure $ changeHeadOutputDatum (replaceContesters mutatedContesters) headTxOut
+      , 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)
@@ -278,16 +278,9 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId =
     && hasST headPolicyId outValue
     && mustInitializeContesters
     && 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
@@ -382,7 +375,9 @@ checkContest ctx contestationDeadline parties closedSnapshotNumber sig contester
     && hasST headId outValue
     && mustUpdateContesters
     && mustNotChangeParameters
+    && 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 #-}