From c1378bb1c3ba5f5500e0ac431402b22ec7b1a29b Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Fri, 3 Feb 2023 12:03:44 +0100 Subject: [PATCH 01/10] Add failing mutation and start a validator fix --- hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs | 7 ++++++- hydra-plutus/src/Hydra/Contract/Head.hs | 9 +++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs index e6fe66ddf91..824ae1c33e8 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs +++ b/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 diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 7c4a646679e..bd0f57ec1dc 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -278,7 +278,16 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId = && hasST headPolicyId outValue && mustInitializeContesters && mustNotChangeParameters + && mustPreserveValue 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" + hasBoundedValidity = traceIfFalse "hasBoundedValidity check failed" $ tMax - tMin <= cp From e2af01500a3f3e330c3b34c9ac977ae217be0e42 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Fri, 3 Feb 2023 15:27:06 +0100 Subject: [PATCH 02/10] Shuffle things around and add value preservation test for contest tx --- .../test/Hydra/Chain/Direct/Contract/Close.hs | 31 ++++++++++--------- .../Hydra/Chain/Direct/Contract/Contest.hs | 7 ++++- hydra-plutus/src/Hydra/Contract/Head.hs | 15 +++------ hydra-plutus/src/Hydra/Contract/Util.hs | 12 +++++++ 4 files changed, 40 insertions(+), 25 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs index 824ae1c33e8..3e5e1d417d7 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs +++ b/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) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs index b671a197b66..c864b61e9e6 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs +++ b/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 diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index bd0f57ec1dc..aa0ec8c453c 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/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 diff --git a/hydra-plutus/src/Hydra/Contract/Util.hs b/hydra-plutus/src/Hydra/Contract/Util.hs index 73c45989f22..1da25733321 100644 --- a/hydra-plutus/src/Hydra/Contract/Util.hs +++ b/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 #-} From b20a6d3c2753d35d210955c84894003a75b88604 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Fri, 3 Feb 2023 17:25:05 +0100 Subject: [PATCH 03/10] Update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index b013a9dd466..871873e39e1 100644 --- a/CHANGELOG.md +++ b/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 From d8f4fe0dcf15baa55b4ac31b3604b265ddd3d3d5 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Mon, 6 Feb 2023 13:06:54 +0100 Subject: [PATCH 04/10] Remove addChangeOutput --- .../test/Hydra/Chain/Direct/Contract/Close.hs | 31 +++++++++---------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs index 3e5e1d417d7..824ae1c33e8 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs @@ -28,7 +28,6 @@ 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) @@ -59,14 +58,13 @@ healthyCloseTx = (tx, lookupUTxO) where tx = - addChangeOutput $ - closeTx - somePartyCardanoVerificationKey - closingSnapshot - healthyCloseLowerBoundSlot - healthyCloseUpperBoundPointInTime - openThreadOutput - (mkHeadId Fixture.testPolicyId) + closeTx + somePartyCardanoVerificationKey + closingSnapshot + healthyCloseLowerBoundSlot + healthyCloseUpperBoundPointInTime + openThreadOutput + (mkHeadId Fixture.testPolicyId) lookupUTxO = UTxO.singleton (healthyOpenHeadTxIn, healthyOpenHeadTxOut) @@ -94,14 +92,13 @@ healthyCloseInitialTx = (tx, lookupUTxO) where tx = - addChangeOutput $ - closeTx - somePartyCardanoVerificationKey - closingSnapshot - healthyCloseLowerBoundSlot - healthyCloseUpperBoundPointInTime - openThreadOutput - (mkHeadId Fixture.testPolicyId) + closeTx + somePartyCardanoVerificationKey + closingSnapshot + healthyCloseLowerBoundSlot + healthyCloseUpperBoundPointInTime + openThreadOutput + (mkHeadId Fixture.testPolicyId) lookupUTxO = UTxO.singleton (healthyOpenHeadTxIn, healthyOpenHeadTxOut) From 05803bd0219e780976a32f1b5e46829f62558318 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Mon, 6 Feb 2023 14:34:09 +0100 Subject: [PATCH 05/10] Remove headOutputValue --- hydra-plutus/src/Hydra/Contract/Head.hs | 6 +++--- hydra-plutus/src/Hydra/Contract/Util.hs | 6 ------ 2 files changed, 3 insertions(+), 9 deletions(-) diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index aa0ec8c453c..909613eef89 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/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, headOutputValue, mustNotMintOrBurn, mustPreserveValue) +import Hydra.Contract.Util (hasST, mustNotMintOrBurn, mustPreserveValue) import Hydra.Data.ContestationPeriod (ContestationPeriod, addContestationPeriod, milliseconds) import Hydra.Data.Party (Party (vkey)) import Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator) @@ -280,7 +280,7 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId = && mustNotChangeParameters && mustPreserveValue outValue headOutValue where - headOutValue = headOutputValue $ txInfoOutputs txInfo + headOutValue = txOutValue . head $ txInfoOutputs txInfo hasBoundedValidity = traceIfFalse "hasBoundedValidity check failed" $ tMax - tMin <= cp @@ -377,7 +377,7 @@ checkContest ctx contestationDeadline parties closedSnapshotNumber sig contester && mustNotChangeParameters && mustPreserveValue outValue headOutValue where - headOutValue = headOutputValue $ txInfoOutputs txInfo + headOutValue = txOutValue . head $ txInfoOutputs txInfo outValue = maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx diff --git a/hydra-plutus/src/Hydra/Contract/Util.hs b/hydra-plutus/src/Hydra/Contract/Util.hs index 1da25733321..31cb3541edd 100644 --- a/hydra-plutus/src/Hydra/Contract/Util.hs +++ b/hydra-plutus/src/Hydra/Contract/Util.hs @@ -8,7 +8,6 @@ import Plutus.V2.Ledger.Api ( CurrencySymbol, TokenName (..), TxInfo (TxInfo, txInfoMint), - TxOut (txOutValue), Value (getValue), ) import qualified PlutusTx.AssocMap as Map @@ -53,8 +52,3 @@ 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 #-} From d1f5be97df6663ea00ddf0b3bf53db151312e79a Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Tue, 7 Feb 2023 09:38:31 +0100 Subject: [PATCH 06/10] Address PR review comments --- hydra-plutus/src/Hydra/Contract/Head.hs | 42 ++++++++++++++++--------- hydra-plutus/src/Hydra/Contract/Util.hs | 5 --- 2 files changed, 28 insertions(+), 19 deletions(-) diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 909613eef89..397ee7d6839 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/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, mustPreserveValue) +import Hydra.Contract.Util (hasST, mustNotMintOrBurn) import Hydra.Data.ContestationPeriod (ContestationPeriod, addContestationPeriod, milliseconds) import Hydra.Data.Party (Party (vkey)) import Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator) @@ -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,19 +277,25 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId = && checkDeadline && checkSnapshot && mustBeSignedByParticipant ctx headPolicyId - && hasST headPolicyId outValue + && hasST headPolicyId val && mustInitializeContesters + && hasST headPolicyId val && mustNotChangeParameters - && mustPreserveValue outValue headOutValue + && mustPreserveValue where - headOutValue = txOutValue . head $ txInfoOutputs txInfo + + mustPreserveValue = + traceIfFalse "head value is not preserved" $ + 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 @@ -353,6 +361,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 -> @@ -372,14 +382,18 @@ checkContest ctx contestationDeadline parties closedSnapshotNumber sig contester && mustBeSignedByParticipant ctx headId && checkSignedParticipantContestOnlyOnce && mustBeWithinContestationPeriod - && hasST headId outValue && mustUpdateContesters + && hasST headId val && mustNotChangeParameters - && mustPreserveValue outValue headOutValue + && mustPreserveValue where - headOutValue = txOutValue . head $ txInfoOutputs txInfo - outValue = - maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx + mustPreserveValue = + traceIfFalse "head value is not preserved" $ + val == val' + + val' = txOutValue . head $ txInfoOutputs txInfo + + val = maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx mustBeNewer = traceIfFalse "too old snapshot" $ diff --git a/hydra-plutus/src/Hydra/Contract/Util.hs b/hydra-plutus/src/Hydra/Contract/Util.hs index 31cb3541edd..c93bbd88b12 100644 --- a/hydra-plutus/src/Hydra/Contract/Util.hs +++ b/hydra-plutus/src/Hydra/Contract/Util.hs @@ -47,8 +47,3 @@ mustNotMintOrBurn TxInfo{txInfoMint} = isZero txInfoMint {-# INLINEABLE mustNotMintOrBurn #-} -mustPreserveValue :: Value -> Value -> Bool -mustPreserveValue outValue headOutValue = - traceIfFalse "head value is not preserved" $ - outValue == headOutValue -{-# INLINEABLE mustPreserveValue #-} From 8207d16140a410ee92f88b57e74cd7d11d1babd3 Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Tue, 7 Feb 2023 09:54:26 +0100 Subject: [PATCH 07/10] Bump maxSupported outputs to 39 --- hydra-node/test/Hydra/Chain/Direct/StateSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs index d14fa51e4a9..3bce12346bd 100644 --- a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs +++ b/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 = 39 countAssets = getSum . foldMap (Sum . valueSize . txOutValue) From 33995e2d8f223b0cf6f2e0d6f5e5432c98341474 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 7 Feb 2023 10:11:59 +0100 Subject: [PATCH 08/10] Update tx-cost to see limits of close/contest The transactions seem to be memory bound now. --- hydra-node/exe/tx-cost/TxCost.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/hydra-node/exe/tx-cost/TxCost.hs b/hydra-node/exe/tx-cost/TxCost.hs index 2ada3677d17..3ff4ec1aad1 100644 --- a/hydra-node/exe/tx-cost/TxCost.hs +++ b/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 From f874d39204ea1f7a65bfcf3ce696b9bb1b73befc Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Tue, 7 Feb 2023 10:51:42 +0100 Subject: [PATCH 09/10] Identify what makes close/contest expensive: Value equality The Eq Value instance is doing a lot of work to make two values equal even if their actual contents (associative lists) are shuffled but consistent. --- hydra-plutus/src/Hydra/Contract/Head.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 397ee7d6839..0f00bc9da33 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -277,15 +277,17 @@ checkClose ctx parties initialUtxoHash sig cperiod headPolicyId = && checkDeadline && checkSnapshot && mustBeSignedByParticipant ctx headPolicyId - && hasST headPolicyId val && mustInitializeContesters && hasST headPolicyId val - && mustNotChangeParameters && 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 @@ -389,6 +391,10 @@ checkContest ctx contestationDeadline parties closedSnapshotNumber sig contester 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 From 0ce2b93be4d6c1b4eff3b94d00791dd4d08dc4ae Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Tue, 7 Feb 2023 12:01:37 +0100 Subject: [PATCH 10/10] Reduce the supported outputs by one for the fanout tx --- hydra-node/test/Hydra/Chain/Direct/StateSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs index 3bce12346bd..bc7cd38c14f 100644 --- a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs +++ b/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 = 39 + maxSupported = 38 countAssets = getSum . foldMap (Sum . valueSize . txOutValue)