Merge pull request #702 from input-output-hk/ensemble/check-that-valu…

…e-is-preserved

Check that value is preserved in v_head

CHANGELOG.md

@@ -30,6 +30,7 @@ changes.
   + Check no tokens are minted/burnt in v-head for close, contest, commit and collectCom tx.
   + The v_head output must now be the first output of the transaction so that we can make the validator code simpler.
   + Introduce check in head validator to allow contest only once per party.
+  + Check that value is preserved in v_head
 
 - **BREAKING** Change the way tx validity and contestation deadline is constructed for close transactions:
   + There is a new hydra-node flag `--contestation-period` expressed in seconds

hydra-node/exe/tx-cost/TxCost.hs

@@ -129,8 +129,8 @@ computeCollectComCost =
 
 computeCloseCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit, Lovelace)]
 computeCloseCost = do
-  interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10, 30]
-  limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [100, 99 .. 31]
+  interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10]
+  limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [50, 49 .. 11]
   pure $ interesting <> limit
  where
   compute numParties = do
@@ -144,8 +144,8 @@ computeCloseCost = do
 
 computeContestCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit, Lovelace)]
 computeContestCost = do
-  interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10, 30]
-  limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [100, 99 .. 31]
+  interesting <- catMaybes <$> mapM compute [1, 2, 3, 5, 10]
+  limit <- maybeToList . getFirst <$> foldMapM (fmap First . compute) [50, 49 .. 11]
   pure $ interesting <> limit
  where
   compute numParties = do

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

@@ -36,7 +36,7 @@ import Hydra.Data.ContestationPeriod (posixFromUTCTime)
 import qualified Hydra.Data.ContestationPeriod as OnChain
 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 (genValidityBoundsFromContestationPeriod)
 import Hydra.Party (Party, deriveParty, partyToChain)
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
@@ -223,6 +223,8 @@ data CloseMutation
     MutateTokenMintingOrBurning
   | -- | Change the resulting contesters to non-empty to see if they are checked
     MutateContesters
+  | -- | See spec: 5.5. rule 6 -> value is preserved
+    MutateValueInOutput
   deriving (Generic, Show, Enum, Bounded)
 
 genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -284,6 +286,9 @@ genCloseMutation (tx, _utxo) =
     , SomeMutation (Just "contesters non-empty") MutateContesters . ChangeOutput 0 <$> do
         mutatedContesters <- listOf1 $ PubKeyHash . toBuiltin <$> genHash
         pure $ headTxOut & changeHeadOutputDatum (replaceContesters mutatedContesters)
+    , SomeMutation (Just "head value is not preserved") MutateValueInOutput <$> do
+        newValue <- genValue
+        pure $ ChangeOutput 0 (headTxOut{txOutValue = newValue})
     ]
  where
   genOversizedTransactionValidity = do

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-node/test/Hydra/Chain/Direct/StateSpec.hs

@@ -398,7 +398,7 @@ forAllFanout action =
        in action utxo tx
             & label ("Fanout size: " <> prettyLength (countAssets $ txOuts' tx))
  where
-  maxSupported = 30
+  maxSupported = 38
 
   countAssets = getSum . foldMap (Sum . valueSize . txOutValue)
 

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

@@ -182,7 +182,7 @@ checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPer
     && mustNotChangeParameters
     && everyoneHasCommitted
     && mustBeSignedByParticipant ctx headId
-    && hasST headId outValue
+    && hasST headId val
  where
   mustCollectUtxoHash =
     traceIfFalse "incorrect utxo hash" $
@@ -208,7 +208,7 @@ checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPer
       _ -> traceError "wrong state in output datum"
   headAddress = mkHeadAddress ctx
 
-  outValue =
+  val =
     maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
 
   everyoneHasCommitted =
@@ -261,6 +261,8 @@ commitDatum txInfo input = do
 --   * State token (ST) is present in the output
 --
 --   * Contesters must be initialize as empty
+--
+--   * Value in v_head is preserved
 checkClose ::
   ScriptContext ->
   [Party] ->
@@ -275,17 +277,27 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId =
     && checkDeadline
     && checkSnapshot
     && mustBeSignedByParticipant ctx headPolicyId
-    && hasST headPolicyId outValue
     && mustInitializeContesters
+    && hasST headPolicyId val
+    && mustPreserveValue
     && mustNotChangeParameters
  where
+  mustPreserveValue =
+    traceIfFalse "head value is not preserved" $
+      -- XXX: Equality on value is very memory intensive as it's defined on
+      -- associative lists and Map equality is implemented. Instead we should be
+      -- more strict and require EXACTLY the same value and compare using a
+      -- simple fold or even compare the serialised bytes.
+      val == val'
+
+  val' = txOutValue . head $ txInfoOutputs txInfo
+
+  val = maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
+
   hasBoundedValidity =
     traceIfFalse "hasBoundedValidity check failed" $
       tMax - tMin <= cp
 
-  outValue =
-    maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
-
   (closedSnapshotNumber, closedUtxoHash, parties', closedContestationDeadline, headId', contesters') =
     -- XXX: fromBuiltinData is super big (and also expensive?)
     case fromBuiltinData @DatumType $ getDatum (headOutputDatum ctx) of
@@ -351,6 +363,8 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId =
 --   * Add signer to list of contesters.
 --
 --   * No other parameters have changed.
+--
+--   * Value in v_head is preserved
 checkContest ::
   ScriptContext ->
   POSIXTime ->
@@ -370,12 +384,22 @@ checkContest ctx contestationDeadline parties closedSnapshotNumber sig contester
     && mustBeSignedByParticipant ctx headId
     && checkSignedParticipantContestOnlyOnce
     && mustBeWithinContestationPeriod
-    && hasST headId outValue
     && mustUpdateContesters
+    && hasST headId val
     && mustNotChangeParameters
+    && mustPreserveValue
  where
-  outValue =
-    maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
+  mustPreserveValue =
+    traceIfFalse "head value is not preserved" $
+      -- XXX: Equality on value is very memory intensive as it's defined on
+      -- associative lists and Map equality is implemented. Instead we should be
+      -- more strict and require EXACTLY the same value and compare using a
+      -- simple fold or even compare the serialised bytes.
+      val == val'
+
+  val' = txOutValue . head $ txInfoOutputs txInfo
+
+  val = maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
 
   mustBeNewer =
     traceIfFalse "too old snapshot" $

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

@@ -46,3 +46,4 @@ mustNotMintOrBurn TxInfo{txInfoMint} =
   traceIfFalse "minting or burning is forbidden" $
     isZero txInfoMint
 {-# INLINEABLE mustNotMintOrBurn #-}
+