From f13d00b9f1e2b1bf79416fb67ff474ab8a553a36 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 5 Apr 2022 11:59:39 +0000 Subject: [PATCH 01/10] Add mutation on initial output address #243 --- .../test/Hydra/Chain/Direct/Contract/Init.hs | 42 +++++++++++++------ 1 file changed, 30 insertions(+), 12 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index e1662001099..b853ee2ed93 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + -- | Mutation-based script validator tests for the init transaction where a -- 'healthyInitTx' gets mutated by an arbitrary 'InitMutation'. module Hydra.Chain.Direct.Contract.Init where @@ -15,7 +17,7 @@ import Hydra.Chain.Direct.Contract.Mutation ( ) import Hydra.Chain.Direct.Fixture (testNetworkId) import Hydra.Chain.Direct.Tx (initTx) -import Hydra.Ledger.Cardano (genOneUTxOFor, genValue) +import Hydra.Ledger.Cardano (genOneUTxOFor, genValue, genVerificationKey) import Test.QuickCheck (choose, elements, oneof, suchThat, vectorOf) import qualified Prelude @@ -55,24 +57,40 @@ healthyLookupUTxO = data InitMutation = MutateThreadTokenQuantity | MutateAddAnotherPT - | MutateInitialOutputValue + | MutateSomePT | MutateDropInitialOutput | MutateDropSeedInput + | MutateInitialOutputAddress deriving (Generic, Show, Enum, Bounded) genInitMutation :: (Tx, UTxO) -> Gen SomeMutation genInitMutation (tx, _utxo) = oneof - [ SomeMutation MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx 1 - , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1 - , SomeMutation MutateInitialOutputValue <$> do + [ -- SomeMutation MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx 1 + -- , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1 + -- , SomeMutation MutateInitialOutputValue <$> do + -- let outs = txOuts' tx + -- (ix, out) <- elements (zip [1 .. length outs - 1] outs) + -- value' <- genValue `suchThat` (/= txOutValue out) + -- pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) + -- , + SomeMutation MutateInitialOutputAddress <$> do let outs = txOuts' tx (ix, out) <- elements (zip [1 .. length outs - 1] outs) - value' <- genValue `suchThat` (/= txOutValue out) - pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) - , SomeMutation MutateDropInitialOutput <$> do - ix <- choose (1, length (txOuts' tx) - 1) - pure $ RemoveOutput (fromIntegral ix) - , SomeMutation MutateDropSeedInput <$> do - pure $ RemoveInput healthySeedInput + vk' <- genVerificationKey `suchThat` (`notElem` healthyParties) + pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (swapTokenName $ verificationKeyHash vk') out) + -- , SomeMutation MutateDropInitialOutput <$> do + -- ix <- choose (1, length (txOuts' tx) - 1) + -- pure $ RemoveOutput (fromIntegral ix) + -- , SomeMutation MutateDropSeedInput <$> do + -- pure $ RemoveInput healthySeedInput ] + +swapTokenName :: Hash PaymentKey -> Value -> Value +swapTokenName vkh val = + valueFromList $ fmap swapPT $ valueToList val + where + swapPT :: (AssetId, Quantity) -> (AssetId, Quantity) + swapPT adas@(AdaAssetId, _) = adas + swapPT (AssetId pid _an, 1) = (AssetId pid (AssetName $ serialiseToRawBytes vkh), 1) + swapPT v = error $ "supernumerary value :" <> show v From d19f707ad1987e6244865840832e160dd6aad6aa Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 14:31:17 +0200 Subject: [PATCH 02/10] Add pub key hashes to list of parties in on-chain head parameters. --- hydra-plutus/src/Hydra/Contract/Head.hs | 12 ++++++------ hydra-plutus/src/Hydra/Contract/HeadState.hs | 15 ++++++++++++--- 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 950effd2824..5467daf7efc 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -131,7 +131,7 @@ mkHeadContext context initialAddress commitAddress = checkAbort :: ScriptContext -> HeadContext -> - [Party] -> + [(Party, PubKeyHash)] -> Bool checkAbort context@ScriptContext{scriptContextTxInfo = txInfo} headContext parties = consumeInputsForAllParties @@ -172,7 +172,7 @@ checkCollectCom :: -- | Static information about the head (i.e. address, value, currency...) HeadContext -> -- | Initial state - (ContestationPeriod, [Party]) -> + (ContestationPeriod, [(Party, PubKeyHash)]) -> Bool checkCollectCom context@ScriptContext{scriptContextTxInfo = txInfo} headContext (_, parties) = mustContinueHeadWith context headAddress expectedChangeValue expectedOutputDatum @@ -253,7 +253,7 @@ checkCollectCom context@ScriptContext{scriptContextTxInfo = txInfo} headContext checkClose :: ScriptContext -> HeadContext -> - [Party] -> + [(Party, PubKeyHash)] -> SnapshotNumber -> [Signature] -> Bool @@ -364,15 +364,15 @@ hashTxOuts = sha2_256 . serialiseTxOuts {-# INLINEABLE hashTxOuts #-} -verifySnapshotSignature :: [Party] -> SnapshotNumber -> [Signature] -> Bool +verifySnapshotSignature :: [(Party, PubKeyHash)] -> SnapshotNumber -> [Signature] -> Bool verifySnapshotSignature parties snapshotNumber sigs = traceIfFalse "signature verification failed" $ length parties == length sigs && all (uncurry $ verifyPartySignature snapshotNumber) (zip parties sigs) {-# INLINEABLE verifySnapshotSignature #-} -verifyPartySignature :: SnapshotNumber -> Party -> Signature -> Bool -verifyPartySignature snapshotNumber vkey signed = +verifyPartySignature :: SnapshotNumber -> (Party, PubKeyHash) -> Signature -> Bool +verifyPartySignature snapshotNumber (vkey, _) signed = traceIfFalse "party signature verification failed" $ mockVerifySignature vkey snapshotNumber (getSignature signed) {-# INLINEABLE verifyPartySignature #-} diff --git a/hydra-plutus/src/Hydra/Contract/HeadState.hs b/hydra-plutus/src/Hydra/Contract/HeadState.hs index 4e04b93f967..2b581199aa5 100644 --- a/hydra-plutus/src/Hydra/Contract/HeadState.hs +++ b/hydra-plutus/src/Hydra/Contract/HeadState.hs @@ -20,9 +20,18 @@ type SnapshotNumber = Integer type Hash = BuiltinByteString data State - = Initial {contestationPeriod :: ContestationPeriod, parties :: [Party]} - | Open {parties :: [Party], utxoHash :: Hash} - | Closed {snapshotNumber :: SnapshotNumber, utxoHash :: Hash} + = Initial + { contestationPeriod :: ContestationPeriod + , parties :: [(Party, PubKeyHash)] + } + | Open + { parties :: [(Party, PubKeyHash)] + , utxoHash :: Hash + } + | Closed + { snapshotNumber :: SnapshotNumber + , utxoHash :: Hash + } | Final deriving stock (Generic, Show) deriving anyclass (FromJSON, ToJSON) From 265767fead4d9d30c609f64bda2c2664361887f5 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 14:31:53 +0200 Subject: [PATCH 03/10] Verify PTs match their respective pubkey hashes in head parameters. --- hydra-plutus/src/Hydra/Contract/HeadTokens.hs | 40 ++++++++++++------- 1 file changed, 25 insertions(+), 15 deletions(-) diff --git a/hydra-plutus/src/Hydra/Contract/HeadTokens.hs b/hydra-plutus/src/Hydra/Contract/HeadTokens.hs index 9fb5d2769f6..795501675e6 100644 --- a/hydra-plutus/src/Hydra/Contract/HeadTokens.hs +++ b/hydra-plutus/src/Hydra/Contract/HeadTokens.hs @@ -14,7 +14,7 @@ import qualified Hydra.Contract.Initial as Initial import Hydra.Contract.MintAction (MintAction (Burn, Mint)) import Ledger.Typed.Scripts (ValidatorTypes (..), wrapMintingPolicy) import Plutus.V1.Ledger.Api (fromBuiltinData) -import Plutus.V1.Ledger.Value (getValue) +import Plutus.V1.Ledger.Value (TokenName (..), getValue) import qualified PlutusTx import qualified PlutusTx.AssocMap as Map @@ -39,7 +39,7 @@ validate initialValidator headValidator seedInput action context = validateTokensMinting :: ValidatorHash -> ValidatorHash -> TxOutRef -> ScriptContext -> Bool validateTokensMinting initialValidator headValidator seedInput context = traceIfFalse "minted wrong" $ - participationTokensAreDistributed currency initialValidator txInfo nParties + participationTokensAreDistributed currency initialValidator txInfo parties && checkQuantities && assetNamesInPolicy == nParties + 1 && seedInputIsConsumed @@ -58,7 +58,8 @@ validateTokensMinting initialValidator headValidator seedInput context = ScriptContext{scriptContextTxInfo = txInfo} = context - nParties = + nParties = length parties + parties = case scriptOutputsAt headValidator txInfo of [(dh, _)] -> case getDatum <$> findDatum dh txInfo of @@ -66,7 +67,8 @@ validateTokensMinting initialValidator headValidator seedInput context = Just da -> case fromBuiltinData @(DatumType Head) da of Nothing -> traceError "expected commit datum type, got something else" - Just Head.Initial{Head.parties = parties} -> length parties + Just Head.Initial{Head.parties = headParties} -> + snd <$> headParties Just _ -> traceError "unexpected State in datum" _ -> traceError "expected single head output" @@ -100,19 +102,27 @@ validateTokensBurning context = Nothing -> 0 Just tokenMap -> negate $ sum tokenMap -participationTokensAreDistributed :: CurrencySymbol -> ValidatorHash -> TxInfo -> Integer -> Bool -participationTokensAreDistributed currency initialValidator txInfo nParties = +participationTokensAreDistributed :: CurrencySymbol -> ValidatorHash -> TxInfo -> [PubKeyHash] -> Bool +participationTokensAreDistributed currency initialValidator txInfo parties = case scriptOutputsAt initialValidator txInfo of - [] -> traceIfFalse "no initial outputs for parties" $ nParties == (0 :: Integer) - outs -> nParties == length outs && all hasParticipationToken outs + [] -> + traceIfFalse "no initial outputs for parties" $ length parties == (0 :: Integer) + outs -> + length parties == length outs && allHasParticipationToken (outs, parties) where - hasParticipationToken :: (DatumHash, Value) -> Bool - hasParticipationToken (_, val) = - case Map.lookup currency (getValue val) of - Nothing -> traceError "no PT distributed" - (Just tokenMap) -> case Map.toList tokenMap of - [(_, qty)] -> qty == 1 - _ -> traceError "wrong quantity of PT distributed" + allHasParticipationToken :: ([(DatumHash, Value)], [PubKeyHash]) -> Bool + allHasParticipationToken = \case + ([], []) -> + True + ((_, val) : outs, pks) -> + case Map.lookup currency (getValue val) of + Nothing -> traceError "no PT distributed" + (Just tokenMap) -> case Map.toList tokenMap of + [(TokenName vkh, qty)] -> + let pks' = filter (/= PubKeyHash vkh) pks + in qty == 1 && pks' /= pks && allHasParticipationToken (outs, pks') + _ -> traceError "wrong quantity of PT distributed" + ([], _) -> False mintingPolicy :: TxOutRef -> MintingPolicy mintingPolicy txOutRef = From 1fa86d62a2af3913df02816e7d45aa7e90e9ae15 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 15:02:53 +0200 Subject: [PATCH 04/10] Revert "Verify PTs match their respective pubkey hashes in head parameters." & Revert "Add pub key hashes to list of parties in on-chain head parameters.". After discussing the next steps, we realized that passing the pub key hashes on-chain and checking the PTs does not actually provide any extra security guarantees and only makes the on-chain code more complicated. In the end, this is something we can only truly handle off-chain, durign the observation of an init transaction. It is the observer who knows the configuration it is expecting, and that can decide whether some observation is valid or not. On-chain, there isn't much we can do since, anyone crafting the init transaction may also change the redeemer, parameters or anything really. The participants of a head are BY DEFINITION the keys identified by the PT. Now, those participants may or may not reflect a known configuration of a node, but this is decided off-chain exclusively. --- hydra-plutus/src/Hydra/Contract/Head.hs | 12 +++--- hydra-plutus/src/Hydra/Contract/HeadState.hs | 15 ++----- hydra-plutus/src/Hydra/Contract/HeadTokens.hs | 40 +++++++------------ 3 files changed, 24 insertions(+), 43 deletions(-) diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 5467daf7efc..950effd2824 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -131,7 +131,7 @@ mkHeadContext context initialAddress commitAddress = checkAbort :: ScriptContext -> HeadContext -> - [(Party, PubKeyHash)] -> + [Party] -> Bool checkAbort context@ScriptContext{scriptContextTxInfo = txInfo} headContext parties = consumeInputsForAllParties @@ -172,7 +172,7 @@ checkCollectCom :: -- | Static information about the head (i.e. address, value, currency...) HeadContext -> -- | Initial state - (ContestationPeriod, [(Party, PubKeyHash)]) -> + (ContestationPeriod, [Party]) -> Bool checkCollectCom context@ScriptContext{scriptContextTxInfo = txInfo} headContext (_, parties) = mustContinueHeadWith context headAddress expectedChangeValue expectedOutputDatum @@ -253,7 +253,7 @@ checkCollectCom context@ScriptContext{scriptContextTxInfo = txInfo} headContext checkClose :: ScriptContext -> HeadContext -> - [(Party, PubKeyHash)] -> + [Party] -> SnapshotNumber -> [Signature] -> Bool @@ -364,15 +364,15 @@ hashTxOuts = sha2_256 . serialiseTxOuts {-# INLINEABLE hashTxOuts #-} -verifySnapshotSignature :: [(Party, PubKeyHash)] -> SnapshotNumber -> [Signature] -> Bool +verifySnapshotSignature :: [Party] -> SnapshotNumber -> [Signature] -> Bool verifySnapshotSignature parties snapshotNumber sigs = traceIfFalse "signature verification failed" $ length parties == length sigs && all (uncurry $ verifyPartySignature snapshotNumber) (zip parties sigs) {-# INLINEABLE verifySnapshotSignature #-} -verifyPartySignature :: SnapshotNumber -> (Party, PubKeyHash) -> Signature -> Bool -verifyPartySignature snapshotNumber (vkey, _) signed = +verifyPartySignature :: SnapshotNumber -> Party -> Signature -> Bool +verifyPartySignature snapshotNumber vkey signed = traceIfFalse "party signature verification failed" $ mockVerifySignature vkey snapshotNumber (getSignature signed) {-# INLINEABLE verifyPartySignature #-} diff --git a/hydra-plutus/src/Hydra/Contract/HeadState.hs b/hydra-plutus/src/Hydra/Contract/HeadState.hs index 2b581199aa5..4e04b93f967 100644 --- a/hydra-plutus/src/Hydra/Contract/HeadState.hs +++ b/hydra-plutus/src/Hydra/Contract/HeadState.hs @@ -20,18 +20,9 @@ type SnapshotNumber = Integer type Hash = BuiltinByteString data State - = Initial - { contestationPeriod :: ContestationPeriod - , parties :: [(Party, PubKeyHash)] - } - | Open - { parties :: [(Party, PubKeyHash)] - , utxoHash :: Hash - } - | Closed - { snapshotNumber :: SnapshotNumber - , utxoHash :: Hash - } + = Initial {contestationPeriod :: ContestationPeriod, parties :: [Party]} + | Open {parties :: [Party], utxoHash :: Hash} + | Closed {snapshotNumber :: SnapshotNumber, utxoHash :: Hash} | Final deriving stock (Generic, Show) deriving anyclass (FromJSON, ToJSON) diff --git a/hydra-plutus/src/Hydra/Contract/HeadTokens.hs b/hydra-plutus/src/Hydra/Contract/HeadTokens.hs index 795501675e6..9fb5d2769f6 100644 --- a/hydra-plutus/src/Hydra/Contract/HeadTokens.hs +++ b/hydra-plutus/src/Hydra/Contract/HeadTokens.hs @@ -14,7 +14,7 @@ import qualified Hydra.Contract.Initial as Initial import Hydra.Contract.MintAction (MintAction (Burn, Mint)) import Ledger.Typed.Scripts (ValidatorTypes (..), wrapMintingPolicy) import Plutus.V1.Ledger.Api (fromBuiltinData) -import Plutus.V1.Ledger.Value (TokenName (..), getValue) +import Plutus.V1.Ledger.Value (getValue) import qualified PlutusTx import qualified PlutusTx.AssocMap as Map @@ -39,7 +39,7 @@ validate initialValidator headValidator seedInput action context = validateTokensMinting :: ValidatorHash -> ValidatorHash -> TxOutRef -> ScriptContext -> Bool validateTokensMinting initialValidator headValidator seedInput context = traceIfFalse "minted wrong" $ - participationTokensAreDistributed currency initialValidator txInfo parties + participationTokensAreDistributed currency initialValidator txInfo nParties && checkQuantities && assetNamesInPolicy == nParties + 1 && seedInputIsConsumed @@ -58,8 +58,7 @@ validateTokensMinting initialValidator headValidator seedInput context = ScriptContext{scriptContextTxInfo = txInfo} = context - nParties = length parties - parties = + nParties = case scriptOutputsAt headValidator txInfo of [(dh, _)] -> case getDatum <$> findDatum dh txInfo of @@ -67,8 +66,7 @@ validateTokensMinting initialValidator headValidator seedInput context = Just da -> case fromBuiltinData @(DatumType Head) da of Nothing -> traceError "expected commit datum type, got something else" - Just Head.Initial{Head.parties = headParties} -> - snd <$> headParties + Just Head.Initial{Head.parties = parties} -> length parties Just _ -> traceError "unexpected State in datum" _ -> traceError "expected single head output" @@ -102,27 +100,19 @@ validateTokensBurning context = Nothing -> 0 Just tokenMap -> negate $ sum tokenMap -participationTokensAreDistributed :: CurrencySymbol -> ValidatorHash -> TxInfo -> [PubKeyHash] -> Bool -participationTokensAreDistributed currency initialValidator txInfo parties = +participationTokensAreDistributed :: CurrencySymbol -> ValidatorHash -> TxInfo -> Integer -> Bool +participationTokensAreDistributed currency initialValidator txInfo nParties = case scriptOutputsAt initialValidator txInfo of - [] -> - traceIfFalse "no initial outputs for parties" $ length parties == (0 :: Integer) - outs -> - length parties == length outs && allHasParticipationToken (outs, parties) + [] -> traceIfFalse "no initial outputs for parties" $ nParties == (0 :: Integer) + outs -> nParties == length outs && all hasParticipationToken outs where - allHasParticipationToken :: ([(DatumHash, Value)], [PubKeyHash]) -> Bool - allHasParticipationToken = \case - ([], []) -> - True - ((_, val) : outs, pks) -> - case Map.lookup currency (getValue val) of - Nothing -> traceError "no PT distributed" - (Just tokenMap) -> case Map.toList tokenMap of - [(TokenName vkh, qty)] -> - let pks' = filter (/= PubKeyHash vkh) pks - in qty == 1 && pks' /= pks && allHasParticipationToken (outs, pks') - _ -> traceError "wrong quantity of PT distributed" - ([], _) -> False + hasParticipationToken :: (DatumHash, Value) -> Bool + hasParticipationToken (_, val) = + case Map.lookup currency (getValue val) of + Nothing -> traceError "no PT distributed" + (Just tokenMap) -> case Map.toList tokenMap of + [(_, qty)] -> qty == 1 + _ -> traceError "wrong quantity of PT distributed" mintingPolicy :: TxOutRef -> MintingPolicy mintingPolicy txOutRef = From f7a5b9a4be0bfe93900e6283b842f89181b862f5 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 15:40:22 +0200 Subject: [PATCH 05/10] Extract observe init mutations from init mutations. --- .../test/Hydra/Chain/Direct/Contract/Init.hs | 51 ++++++++++++------- 1 file changed, 32 insertions(+), 19 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index b853ee2ed93..01ab4db81b9 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -57,33 +57,45 @@ healthyLookupUTxO = data InitMutation = MutateThreadTokenQuantity | MutateAddAnotherPT - | MutateSomePT | MutateDropInitialOutput | MutateDropSeedInput - | MutateInitialOutputAddress + | MutateInitialOutputValue + deriving (Generic, Show, Enum, Bounded) + +data ObserveInitMutation + = MutateSomePT deriving (Generic, Show, Enum, Bounded) genInitMutation :: (Tx, UTxO) -> Gen SomeMutation genInitMutation (tx, _utxo) = oneof - [ -- SomeMutation MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx 1 - -- , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1 - -- , SomeMutation MutateInitialOutputValue <$> do - -- let outs = txOuts' tx - -- (ix, out) <- elements (zip [1 .. length outs - 1] outs) - -- value' <- genValue `suchThat` (/= txOutValue out) - -- pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) - -- , - SomeMutation MutateInitialOutputAddress <$> do + [ SomeMutation MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx 1 + , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1 + , SomeMutation MutateInitialOutputValue <$> do + let outs = txOuts' tx + (ix, out) <- elements (zip [1 .. length outs - 1] outs) + value' <- genValue `suchThat` (/= txOutValue out) + pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) + , SomeMutation MutateDropInitialOutput <$> do + ix <- choose (1, length (txOuts' tx) - 1) + pure $ RemoveOutput (fromIntegral ix) + , SomeMutation MutateDropSeedInput <$> do + pure $ RemoveInput healthySeedInput + ] + +-- These are mutations we expect to be valid from an on-chain standpoint, yet +-- invalid for the off-chain observation. There's mainly only the `init` +-- transaction which is in this situation, because the on-chain parameters are +-- specified during the init and there's no way to check, on-chain, that they +-- correspond to what a node expects in terms of configuration. +genObserveInitMutation :: (Tx, UTxO) -> Gen SomeMutation +genObserveInitMutation (tx, _utxo) = + oneof + [ SomeMutation MutateSomePT <$> do let outs = txOuts' tx (ix, out) <- elements (zip [1 .. length outs - 1] outs) vk' <- genVerificationKey `suchThat` (`notElem` healthyParties) pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (swapTokenName $ verificationKeyHash vk') out) - -- , SomeMutation MutateDropInitialOutput <$> do - -- ix <- choose (1, length (txOuts' tx) - 1) - -- pure $ RemoveOutput (fromIntegral ix) - -- , SomeMutation MutateDropSeedInput <$> do - -- pure $ RemoveInput healthySeedInput ] swapTokenName :: Hash PaymentKey -> Value -> Value @@ -91,6 +103,7 @@ swapTokenName vkh val = valueFromList $ fmap swapPT $ valueToList val where swapPT :: (AssetId, Quantity) -> (AssetId, Quantity) - swapPT adas@(AdaAssetId, _) = adas - swapPT (AssetId pid _an, 1) = (AssetId pid (AssetName $ serialiseToRawBytes vkh), 1) - swapPT v = error $ "supernumerary value :" <> show v + swapPT = \case + adas@(AdaAssetId, _) -> adas + (AssetId pid _an, 1) -> (AssetId pid (AssetName $ serialiseToRawBytes vkh), 1) + v -> error $ "supernumerary value :" <> show v From f65726e3945d2596dd76127fd65b96b8f937fdef Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 16:06:16 +0200 Subject: [PATCH 06/10] Define new mutation properties for testing off-chain code observation. Use it for catching errors on an illed-formed init tx. --- .../test/Hydra/Chain/Direct/Contract/Init.hs | 34 ++++++++++----- .../Hydra/Chain/Direct/Contract/Mutation.hs | 42 ++++++++++++++++++- .../test/Hydra/Chain/Direct/ContractSpec.hs | 22 ++++++---- 3 files changed, 77 insertions(+), 21 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index 01ab4db81b9..996639c089b 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -13,11 +13,14 @@ import Hydra.Chain.Direct.Contract.Mutation ( Mutation (..), SomeMutation (..), addPTWithQuantity, + cardanoCredentialsFor, changeMintedValueQuantityFrom, ) import Hydra.Chain.Direct.Fixture (testNetworkId) +import Hydra.Chain.Direct.State (HeadStateKind (..), OnChainHeadState, idleOnChainHeadState) import Hydra.Chain.Direct.Tx (initTx) import Hydra.Ledger.Cardano (genOneUTxOFor, genValue, genVerificationKey) +import Hydra.Party (Party) import Test.QuickCheck (choose, elements, oneof, suchThat, vectorOf) import qualified Prelude @@ -32,27 +35,38 @@ healthyInitTx = tx = initTx testNetworkId - healthyParties - parameters + healthyCardanoKeys + healthyHeadParameters healthySeedInput - parameters = - flip generateWith 42 $ - HeadParameters - <$> arbitrary - <*> vectorOf (length healthyParties) arbitrary +healthyHeadParameters :: HeadParameters +healthyHeadParameters = + flip generateWith 42 $ + HeadParameters + <$> arbitrary + <*> vectorOf (length healthyParties) arbitrary healthySeedInput :: TxIn healthySeedInput = fst . Prelude.head $ UTxO.pairs healthyLookupUTxO -healthyParties :: [VerificationKey PaymentKey] +healthyParties :: [Party] healthyParties = generateWith (vectorOf 3 arbitrary) 42 +healthyCardanoKeys :: [VerificationKey PaymentKey] +healthyCardanoKeys = + fst . cardanoCredentialsFor <$> healthyParties + healthyLookupUTxO :: UTxO healthyLookupUTxO = - generateWith (genOneUTxOFor (Prelude.head healthyParties)) 42 + generateWith (genOneUTxOFor (Prelude.head healthyCardanoKeys)) 42 + +genHealthyIdleSt :: Gen (OnChainHeadState 'StIdle) +genHealthyIdleSt = do + party <- elements healthyParties + let (vk, _sk) = cardanoCredentialsFor party + pure $ idleOnChainHeadState testNetworkId vk party data InitMutation = MutateThreadTokenQuantity @@ -94,7 +108,7 @@ genObserveInitMutation (tx, _utxo) = [ SomeMutation MutateSomePT <$> do let outs = txOuts' tx (ix, out) <- elements (zip [1 .. length outs - 1] outs) - vk' <- genVerificationKey `suchThat` (`notElem` healthyParties) + vk' <- genVerificationKey `suchThat` (`notElem` healthyCardanoKeys) pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (swapTokenName $ verificationKeyHash vk') out) ] diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs index 348f7fc5291..ffc88cddc4d 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs @@ -143,6 +143,7 @@ import qualified Data.Map as Map import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set import qualified Hydra.Chain.Direct.Fixture as Fixture +import Hydra.Chain.Direct.State (SomeOnChainHeadState (..), observeSomeTx, reifyState) import qualified Hydra.Contract.Head as Head import qualified Hydra.Contract.HeadState as Head import qualified Hydra.Data.Party as Party @@ -159,8 +160,10 @@ import Test.QuickCheck ( Property, checkCoverage, choose, + conjoin, counterexample, forAll, + forAllBlind, property, suchThat, vector, @@ -176,8 +179,8 @@ import Test.QuickCheck.Instances () -- -- Note that only "level 2" validation is run, e.g the transaction is assume to be -- structurally valid and having passed "level 1" checks. -propMutation :: (Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property -propMutation (tx, utxo) genMutation = +propMutationOnChain :: (Tx, UTxO) -> ((Tx, UTxO) -> Gen SomeMutation) -> Property +propMutationOnChain (tx, utxo) genMutation = forAll @_ @Property (genMutation (tx, utxo)) $ \SomeMutation{label, mutation} -> (tx, utxo) & applyMutation mutation @@ -185,6 +188,27 @@ propMutation (tx, utxo) genMutation = & genericCoverTable [label] & checkCoverage +propMutationOffChain :: + (Tx, UTxO) -> + ((Tx, UTxO) -> Gen SomeMutation) -> + Gen SomeOnChainHeadState -> + Property +propMutationOffChain (tx, utxo) genMutation genSt = + forAll @_ @Property (genMutation (tx, utxo)) $ \SomeMutation{label, mutation} -> + forAllBlind genSt $ \st -> + (tx, utxo) + & applyMutation mutation + & ( \x -> + conjoin + [ propTransactionValidates x + & counterexample "Transaction should have validated but didn't." + , propTransactionIsNotObserved x st + & counterexample "Transaction should have not been observed but was observed." + ] + ) + & genericCoverTable [label] + & checkCoverage + -- | A 'Property' checking some (transaction, UTxO) pair is invalid. propTransactionDoesNotValidate :: (Tx, UTxO) -> Property propTransactionDoesNotValidate (tx, lookupUTxO) = @@ -213,6 +237,20 @@ propTransactionValidates (tx, lookupUTxO) = & counterexample ("Redeemer report: " <> show redeemerReport) & counterexample "Phase-2 validation failed" +-- | A 'Property' checking some (on-chain valid) (transaction, UTxO) is not +-- properly observe given a configuration. +propTransactionIsNotObserved :: (Tx, UTxO) -> SomeOnChainHeadState -> Property +propTransactionIsNotObserved (tx, _) st = + case observeSomeTx tx st of + Nothing -> + property True + Just (onChainTx, SomeOnChainHeadState st') -> + property False + & counterexample ("Observed tx: " <> strawmanGetConstr onChainTx) + & counterexample ("New head state: " <> show (reifyState st')) + where + strawmanGetConstr = toString . Prelude.head . words . show + -- * Mutations -- | Existential wrapper 'SomeMutation' and some label type. diff --git a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs index 6fdb6223118..5a7ef7ae089 100644 --- a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs @@ -21,12 +21,14 @@ import Hydra.Chain.Direct.Contract.Close (genCloseMutation, healthyCloseTx) import Hydra.Chain.Direct.Contract.CollectCom (genCollectComMutation, healthyCollectComTx) import Hydra.Chain.Direct.Contract.Commit (genCommitMutation, healthyCommitTx) import Hydra.Chain.Direct.Contract.FanOut (genFanoutMutation, healthyFanoutTx) -import Hydra.Chain.Direct.Contract.Init (genInitMutation, healthyInitTx) +import Hydra.Chain.Direct.Contract.Init (genHealthyIdleSt, genInitMutation, genObserveInitMutation, healthyInitTx) import Hydra.Chain.Direct.Contract.Mutation ( genListOfSigningKeys, - propMutation, + propMutationOffChain, + propMutationOnChain, propTransactionValidates, ) +import Hydra.Chain.Direct.State (SomeOnChainHeadState (..)) import Hydra.Contract.Encoding (serialiseTxOuts) import Hydra.Contract.Head ( verifyPartySignature, @@ -82,8 +84,10 @@ spec = parallel $ do describe "Init" $ do prop "is healthy" $ propTransactionValidates healthyInitTx - prop "does not survive random adversarial mutations" $ - propMutation healthyInitTx genInitMutation + prop "does not survive random adversarial mutations (on-chain)" $ + propMutationOnChain healthyInitTx genInitMutation + prop "does not survive random adversarial mutations (off-chain)" $ + propMutationOffChain healthyInitTx genObserveInitMutation (SomeOnChainHeadState <$> genHealthyIdleSt) describe "Abort" $ do prop "is healthy" $ @@ -93,27 +97,27 @@ spec = parallel $ do , propHasInitial healthyAbortTx ] prop "does not survive random adversarial mutations" $ - propMutation healthyAbortTx genAbortMutation + propMutationOnChain healthyAbortTx genAbortMutation describe "Commit" $ do prop "is healthy" $ propTransactionValidates healthyCommitTx prop "does not survive random adversarial mutations" $ - propMutation healthyCommitTx genCommitMutation + propMutationOnChain healthyCommitTx genCommitMutation describe "CollectCom" $ do prop "is healthy" $ propTransactionValidates healthyCollectComTx prop "does not survive random adversarial mutations" $ - propMutation healthyCollectComTx genCollectComMutation + propMutationOnChain healthyCollectComTx genCollectComMutation describe "Close" $ do prop "is healthy" $ propTransactionValidates healthyCloseTx prop "does not survive random adversarial mutations" $ - propMutation healthyCloseTx genCloseMutation + propMutationOnChain healthyCloseTx genCloseMutation describe "Fanout" $ do prop "is healthy" $ propTransactionValidates healthyFanoutTx prop "does not survive random adversarial mutations" $ - propMutation healthyFanoutTx genFanoutMutation + propMutationOnChain healthyFanoutTx genFanoutMutation -- -- Properties From f95de75d039269d1b0fb0323011f9d436e033afc Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 16:16:59 +0200 Subject: [PATCH 07/10] Fix output selection for init mutation: make tests fail for the right reason. Whoopsie... --- hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index 996639c089b..21ce2eb9fb2 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -87,7 +87,7 @@ genInitMutation (tx, _utxo) = , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1 , SomeMutation MutateInitialOutputValue <$> do let outs = txOuts' tx - (ix, out) <- elements (zip [1 .. length outs - 1] outs) + (ix :: Int, out) <- elements (drop 1 $ zip [0 ..] outs) value' <- genValue `suchThat` (/= txOutValue out) pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out) , SomeMutation MutateDropInitialOutput <$> do @@ -107,7 +107,7 @@ genObserveInitMutation (tx, _utxo) = oneof [ SomeMutation MutateSomePT <$> do let outs = txOuts' tx - (ix, out) <- elements (zip [1 .. length outs - 1] outs) + (ix :: Int, out) <- elements (drop 1 $ zip [0 ..] outs) vk' <- genVerificationKey `suchThat` (`notElem` healthyCardanoKeys) pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (swapTokenName $ verificationKeyHash vk') out) ] From a4bc8adb2cc026101c90085267a1fbf4d90d902c Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 17:48:47 +0200 Subject: [PATCH 08/10] Add Cardano credentials verification during init observation. --- .../src/Hydra/Cardano/Api/Value.hs | 10 ++++++++ hydra-node/src/Hydra/Chain/Direct.hs | 2 ++ hydra-node/src/Hydra/Chain/Direct/Context.hs | 9 +++++--- hydra-node/src/Hydra/Chain/Direct/State.hs | 23 +++++++++++++------ hydra-node/src/Hydra/Chain/Direct/Tx.hs | 14 +++++++++-- .../test/Hydra/Chain/Direct/Contract/Init.hs | 3 ++- hydra-node/test/Hydra/Chain/Direct/TxSpec.hs | 2 +- 7 files changed, 49 insertions(+), 14 deletions(-) diff --git a/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs b/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs index 7f4beec02f9..f0b23b57fdd 100644 --- a/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs +++ b/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs @@ -12,6 +12,16 @@ import qualified Plutus.V1.Ledger.Api as Plutus valueSize :: Value -> Int valueSize = length . valueToList +-- | Access minted assets of a transaction, as an ordered list. +txMintAssets :: Tx era -> [(AssetId, Quantity)] +txMintAssets = + asList . txMintValue . getTxBodyContent . getTxBody + where + getTxBodyContent (TxBody x) = x + asList = \case + TxMintNone -> [] + TxMintValue _ val _ -> valueToList val + -- * Type Conversions -- | Convert a cardano-ledger's 'Value' into a cardano-api's 'Value' diff --git a/hydra-node/src/Hydra/Chain/Direct.hs b/hydra-node/src/Hydra/Chain/Direct.hs index d3ede7bcc63..a9be6f0ead7 100644 --- a/hydra-node/src/Hydra/Chain/Direct.hs +++ b/hydra-node/src/Hydra/Chain/Direct.hs @@ -42,6 +42,7 @@ import Control.Monad.Class.MonadSTM ( import Control.Monad.Class.MonadTimer (timeout) import Control.Tracer (nullTracer) import Data.Aeson (Value (String), object, (.=)) +import Data.List ((\\)) import Data.Sequence.Strict (StrictSeq) import Hydra.Cardano.Api ( NetworkId, @@ -158,6 +159,7 @@ withDirectChain tracer networkId iocp socketPath keyPair party cardanoKeys callb SomeOnChainHeadState $ idleOnChainHeadState networkId + (cardanoKeys \\ [verificationKey wallet]) (verificationKey wallet) party race_ diff --git a/hydra-node/src/Hydra/Chain/Direct/Context.hs b/hydra-node/src/Hydra/Chain/Direct/Context.hs index 4ae8a9d8252..06a62632bc4 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Context.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Context.hs @@ -4,6 +4,7 @@ module Hydra.Chain.Direct.Context where import Hydra.Prelude +import Data.List ((\\)) import Hydra.Cardano.Api ( NetworkId (..), NetworkMagic (..), @@ -78,7 +79,8 @@ genStIdle :: genStIdle HydraContext{ctxVerificationKeys, ctxNetworkId, ctxParties} = do ownParty <- elements ctxParties ownVerificationKey <- elements ctxVerificationKeys - pure $ idleOnChainHeadState ctxNetworkId ownVerificationKey ownParty + let peerVerificationKeys = ctxVerificationKeys \\ [ownVerificationKey] + pure $ idleOnChainHeadState ctxNetworkId peerVerificationKeys ownVerificationKey ownParty genStInitialized :: HydraContext -> @@ -102,8 +104,9 @@ genCommits :: Tx -> Gen [Tx] genCommits ctx initTx = do - forM (zip (ctxVerificationKeys ctx) (ctxParties ctx)) $ \(p, vk) -> do - let stIdle = idleOnChainHeadState (ctxNetworkId ctx) p vk + forM (zip (ctxVerificationKeys ctx) (ctxParties ctx)) $ \(vk, p) -> do + let peerVerificationKeys = ctxVerificationKeys ctx \\ [vk] + let stIdle = idleOnChainHeadState (ctxNetworkId ctx) peerVerificationKeys vk p let (_, stInitialized) = unsafeObserveTx @_ @ 'StInitialized initTx stIdle utxo <- genCommit pure $ unsafeCommit utxo stInitialized diff --git a/hydra-node/src/Hydra/Chain/Direct/State.hs b/hydra-node/src/Hydra/Chain/Direct/State.hs index a5df0f05de0..254831b07fa 100644 --- a/hydra-node/src/Hydra/Chain/Direct/State.hs +++ b/hydra-node/src/Hydra/Chain/Direct/State.hs @@ -66,6 +66,7 @@ import qualified Text.Show -- happening on the layer-1 for a given Hydra head. data OnChainHeadState (st :: HeadStateKind) = OnChainHeadState { networkId :: NetworkId + , peerVerificationKeys :: [VerificationKey PaymentKey] , ownVerificationKey :: VerificationKey PaymentKey , ownParty :: Party , stateMachine :: HydraStateMachine st @@ -180,12 +181,14 @@ reifyState OnChainHeadState{stateMachine} = -- | Initialize a new 'OnChainHeadState'. idleOnChainHeadState :: NetworkId -> + [VerificationKey PaymentKey] -> VerificationKey PaymentKey -> Party -> OnChainHeadState 'StIdle -idleOnChainHeadState networkId ownVerificationKey ownParty = +idleOnChainHeadState networkId peerVerificationKeys ownVerificationKey ownParty = OnChainHeadState { networkId + , peerVerificationKeys , ownVerificationKey , ownParty , stateMachine = Idle @@ -316,14 +319,16 @@ instance HasTransition 'StIdle where ] instance ObserveTx 'StIdle 'StInitialized where - observeTx tx OnChainHeadState{networkId, ownParty, ownVerificationKey} = do - (event, observation) <- observeInitTx networkId ownParty tx + observeTx tx OnChainHeadState{networkId, peerVerificationKeys, ownParty, ownVerificationKey} = do + let allVerificationKeys = ownVerificationKey : peerVerificationKeys + (event, observation) <- observeInitTx networkId allVerificationKeys ownParty tx let InitObservation{threadOutput, initials, commits, headId, headTokenScript} = observation let st' = OnChainHeadState { networkId , ownParty , ownVerificationKey + , peerVerificationKeys , stateMachine = Initialized { initialThreadOutput = threadOutput @@ -370,7 +375,7 @@ instance ObserveTx 'StInitialized 'StInitialized where } = stateMachine instance ObserveTx 'StInitialized 'StOpen where - observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty, stateMachine} = do + observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty, stateMachine} = do let utxo = getKnownUTxO st (event, observation) <- observeCollectComTx utxo tx let CollectComObservation{threadOutput, headId} = observation @@ -378,6 +383,7 @@ instance ObserveTx 'StInitialized 'StOpen where let st' = OnChainHeadState { networkId + , peerVerificationKeys , ownVerificationKey , ownParty , stateMachine = @@ -395,12 +401,13 @@ instance ObserveTx 'StInitialized 'StOpen where } = stateMachine instance ObserveTx 'StInitialized 'StIdle where - observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty} = do + observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty} = do let utxo = getKnownUTxO st (event, ()) <- observeAbortTx utxo tx let st' = OnChainHeadState { networkId + , peerVerificationKeys , ownVerificationKey , ownParty , stateMachine = Idle @@ -417,7 +424,7 @@ instance HasTransition 'StOpen where ] instance ObserveTx 'StOpen 'StClosed where - observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty, stateMachine} = do + observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty, stateMachine} = do let utxo = getKnownUTxO st (event, observation) <- observeCloseTx utxo tx let CloseObservation{threadOutput, headId} = observation @@ -425,6 +432,7 @@ instance ObserveTx 'StOpen 'StClosed where let st' = OnChainHeadState { networkId + , peerVerificationKeys , ownVerificationKey , ownParty , stateMachine = @@ -451,12 +459,13 @@ instance HasTransition 'StClosed where ] instance ObserveTx 'StClosed 'StIdle where - observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty} = do + observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty} = do let utxo = getKnownUTxO st (event, ()) <- observeFanoutTx utxo tx let st' = OnChainHeadState { networkId + , peerVerificationKeys , ownVerificationKey , ownParty , stateMachine = Idle diff --git a/hydra-node/src/Hydra/Chain/Direct/Tx.hs b/hydra-node/src/Hydra/Chain/Direct/Tx.hs index d2f84ca49a9..12d0d9ed5ca 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Tx.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Tx.hs @@ -400,17 +400,21 @@ data InitObservation = InitObservation -- only returning a Maybe, i.e. 'Either Reason (OnChainTx tx, OnChainHeadState)' observeInitTx :: NetworkId -> + [VerificationKey PaymentKey] -> Party -> Tx -> Maybe (OnChainTx Tx, InitObservation) -observeInitTx networkId party tx = do +observeInitTx networkId cardanoKeys party tx = do -- FIXME: This is affected by "same structure datum attacks", we should be -- using the Head script address instead. (ix, headOut, headData, Head.Initial cp ps) <- findFirst headOutput indexedOutputs let parties = map convertParty ps let cperiod = contestationPeriodToDiffTime cp guard $ party `elem` parties - (headTokenPolicyId, _headAssetName) <- findHeadAssetId headOut + (headTokenPolicyId, headAssetName) <- findHeadAssetId headOut + let expectedNames = assetNameFromVerificationKey <$> cardanoKeys + let actualNames = assetNames headAssetName + guard $ sort expectedNames == sort actualNames headTokenScript <- findScriptMinting tx headTokenPolicyId pure ( OnInitTx cperiod parties @@ -451,6 +455,12 @@ observeInitTx networkId party tx = do initialScript = fromPlutusScript Initial.validatorScript + assetNames headAssetName = + [ assetName + | (AssetId _ assetName, _) <- txMintAssets tx + , assetName /= headAssetName + ] + convertParty :: OnChain.Party -> Party convertParty = Party . partyToVerKey diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index 21ce2eb9fb2..788013a20e6 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -8,6 +8,7 @@ import Hydra.Cardano.Api import Hydra.Prelude import qualified Cardano.Api.UTxO as UTxO +import Data.List ((\\)) import Hydra.Chain (HeadParameters (..)) import Hydra.Chain.Direct.Contract.Mutation ( Mutation (..), @@ -66,7 +67,7 @@ genHealthyIdleSt :: Gen (OnChainHeadState 'StIdle) genHealthyIdleSt = do party <- elements healthyParties let (vk, _sk) = cardanoCredentialsFor party - pure $ idleOnChainHeadState testNetworkId vk party + pure $ idleOnChainHeadState testNetworkId (healthyCardanoKeys \\ [vk]) vk party data InitMutation = MutateThreadTokenQuantity diff --git a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs index 8bb78ae04ed..15ac9a4d7ca 100644 --- a/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/TxSpec.hs @@ -180,7 +180,7 @@ spec = forAll (cardanoCredentialsFor <$> elements (party : parties)) $ \(signer, _) -> let params = HeadParameters cperiod (party : parties) tx = initTx testNetworkId cardanoKeys params txIn - in case observeInitTx testNetworkId party tx of + in case observeInitTx testNetworkId cardanoKeys party tx of Just (_, InitObservation{initials, threadOutput}) -> do let (headInput, headOutput, headDatum, _) = threadOutput initials' = Map.fromList [(a, (b, c)) | (a, b, c) <- initials] From 7df5d2ce37a5ddfe8084e1a0c38ed4fc1711ab65 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 5 Apr 2022 17:49:46 +0200 Subject: [PATCH 09/10] Tweak observe-init mutation to mutate minted values instead of outputs. Indeed... mutating outputs isn't caught by our guard because we only check minted values. Which is this however sufficient? (a) The ledger rules ensure that any minted value is actually properly distributed in outputs (transaction ins and outs must balance each other) (b) Our on-chain validator does ensure that the right number of assets are minted, in the right quantity, and that assets are distributed across the right number of outputs. --- .../test/Hydra/Chain/Direct/Contract/Init.hs | 27 ++++++++++--------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index 788013a20e6..a74dd93fa18 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -19,7 +19,7 @@ import Hydra.Chain.Direct.Contract.Mutation ( ) import Hydra.Chain.Direct.Fixture (testNetworkId) import Hydra.Chain.Direct.State (HeadStateKind (..), OnChainHeadState, idleOnChainHeadState) -import Hydra.Chain.Direct.Tx (initTx) +import Hydra.Chain.Direct.Tx (hydraHeadV1AssetName, initTx) import Hydra.Ledger.Cardano (genOneUTxOFor, genValue, genVerificationKey) import Hydra.Party (Party) import Test.QuickCheck (choose, elements, oneof, suchThat, vectorOf) @@ -107,18 +107,19 @@ genObserveInitMutation :: (Tx, UTxO) -> Gen SomeMutation genObserveInitMutation (tx, _utxo) = oneof [ SomeMutation MutateSomePT <$> do - let outs = txOuts' tx - (ix :: Int, out) <- elements (drop 1 $ zip [0 ..] outs) + let minted = txMintAssets tx vk' <- genVerificationKey `suchThat` (`notElem` healthyCardanoKeys) - pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (swapTokenName $ verificationKeyHash vk') out) + let minted' = swapTokenName (verificationKeyHash vk') minted + pure $ ChangeMintedValue (valueFromList minted') ] -swapTokenName :: Hash PaymentKey -> Value -> Value -swapTokenName vkh val = - valueFromList $ fmap swapPT $ valueToList val - where - swapPT :: (AssetId, Quantity) -> (AssetId, Quantity) - swapPT = \case - adas@(AdaAssetId, _) -> adas - (AssetId pid _an, 1) -> (AssetId pid (AssetName $ serialiseToRawBytes vkh), 1) - v -> error $ "supernumerary value :" <> show v +swapTokenName :: Hash PaymentKey -> [(AssetId, Quantity)] -> [(AssetId, Quantity)] +swapTokenName vkh = \case + [] -> + [] + x@(AdaAssetId, _) : xs -> + x : swapTokenName vkh xs + x@(AssetId pid assetName, q) : xs -> + if assetName == hydraHeadV1AssetName + then x : swapTokenName vkh xs + else (AssetId pid (AssetName $ serialiseToRawBytes vkh), q) : xs From 781472173b2575821f73c3687233c22dd2a86bbf Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 6 Apr 2022 09:16:47 +0200 Subject: [PATCH 10/10] Neat-pick and add clarifications to newly added functionality. --- .../src/Hydra/Cardano/Api/Value.hs | 2 +- hydra-node/src/Hydra/Chain/Direct.hs | 2 +- .../test/Hydra/Chain/Direct/Contract/Init.hs | 24 +++++++++---------- 3 files changed, 13 insertions(+), 15 deletions(-) diff --git a/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs b/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs index f0b23b57fdd..62e890e18c8 100644 --- a/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs +++ b/hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs @@ -12,7 +12,7 @@ import qualified Plutus.V1.Ledger.Api as Plutus valueSize :: Value -> Int valueSize = length . valueToList --- | Access minted assets of a transaction, as an ordered list. +-- | Access minted assets of a transaction, as an ordered association list. txMintAssets :: Tx era -> [(AssetId, Quantity)] txMintAssets = asList . txMintValue . getTxBodyContent . getTxBody diff --git a/hydra-node/src/Hydra/Chain/Direct.hs b/hydra-node/src/Hydra/Chain/Direct.hs index a9be6f0ead7..491d8d8881e 100644 --- a/hydra-node/src/Hydra/Chain/Direct.hs +++ b/hydra-node/src/Hydra/Chain/Direct.hs @@ -148,7 +148,7 @@ withDirectChain :: (VerificationKey PaymentKey, SigningKey PaymentKey) -> -- | Hydra party of our hydra node. Party -> - -- | Cardano keys of all Head participants. + -- | Cardano keys of all Head participants (including our key pair). [VerificationKey PaymentKey] -> ChainComponent Tx IO () withDirectChain tracer networkId iocp socketPath keyPair party cardanoKeys callback action = do diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs index a74dd93fa18..6fb2183a537 100644 --- a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs +++ b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} - -- | Mutation-based script validator tests for the init transaction where a -- 'healthyInitTx' gets mutated by an arbitrary 'InitMutation'. module Hydra.Chain.Direct.Contract.Init where @@ -112,14 +110,14 @@ genObserveInitMutation (tx, _utxo) = let minted' = swapTokenName (verificationKeyHash vk') minted pure $ ChangeMintedValue (valueFromList minted') ] - -swapTokenName :: Hash PaymentKey -> [(AssetId, Quantity)] -> [(AssetId, Quantity)] -swapTokenName vkh = \case - [] -> - [] - x@(AdaAssetId, _) : xs -> - x : swapTokenName vkh xs - x@(AssetId pid assetName, q) : xs -> - if assetName == hydraHeadV1AssetName - then x : swapTokenName vkh xs - else (AssetId pid (AssetName $ serialiseToRawBytes vkh), q) : xs + where + swapTokenName :: Hash PaymentKey -> [(AssetId, Quantity)] -> [(AssetId, Quantity)] + swapTokenName vkh = \case + [] -> + [] + x@(AdaAssetId, _) : xs -> + x : swapTokenName vkh xs + x@(AssetId pid assetName, q) : xs -> + if assetName == hydraHeadV1AssetName + then x : swapTokenName vkh xs + else (AssetId pid (AssetName $ serialiseToRawBytes vkh), q) : xs