From 6893db2447e74f9b3e932a043f322ea417539984 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 14 Jan 2022 12:06:10 +0100 Subject: [PATCH 1/2] Write healthy collect com for mutation testing. It's not healthy though according to the failing property. --- .../test/Hydra/Chain/Direct/ContractSpec.hs | 102 +++++++++++++++++- hydra-plutus/src/Hydra/Contract/Head.hs | 8 +- 2 files changed, 108 insertions(+), 2 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs index 58bc6db9dce..ac7383bf8c9 100644 --- a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs @@ -24,8 +24,15 @@ import Data.Maybe.Strict (StrictMaybe (..)) import qualified Data.Sequence.Strict as StrictSeq import Hydra.Chain.Direct.Fixture (testNetworkId) import qualified Hydra.Chain.Direct.Fixture as Fixture -import Hydra.Chain.Direct.Tx (closeTx, fanoutTx, policyId) +import Hydra.Chain.Direct.Tx ( + closeTx, + collectComTx, + fanoutTx, + mkCommitDatum, + policyId, + ) import Hydra.Chain.Direct.TxSpec (mkHeadOutput) +import qualified Hydra.Contract.Commit as Commit import Hydra.Contract.Encoding (serialiseTxOuts) import qualified Hydra.Contract.Hash as Hash import Hydra.Contract.Head ( @@ -35,6 +42,7 @@ import Hydra.Contract.Head ( import qualified Hydra.Contract.Head as Head import Hydra.Data.Party (partyFromVerKey) import qualified Hydra.Data.Party as OnChain +import qualified Hydra.Data.Party as Party import Hydra.Ledger.Cardano ( AlonzoEra, BuildTxWith (BuildTxWith), @@ -47,6 +55,7 @@ import Hydra.Ledger.Cardano ( PlutusScriptV1, Tx (Tx), TxBodyScriptData (TxBodyNoScriptData, TxBodyScriptData), + TxIn, TxOut (..), Utxo, Utxo' (Utxo), @@ -59,30 +68,36 @@ import Hydra.Ledger.Cardano ( fromLedgerTxOut, fromLedgerUtxo, fromPlutusScript, + genAdaOnlyUtxo, genOutput, genUtxoWithSimplifiedAddresses, genValue, getOutputs, hashTxOuts, lovelaceToTxOutValue, + lovelaceToValue, mkDatumForTxIn, mkRedeemerForTxIn, mkScriptAddress, mkScriptWitness, mkTxOutDatum, mkTxOutDatumHash, + mkTxOutValue, modifyTxOutValue, shrinkUtxo, toCtxUTxOTxOut, + toLedgerTxIn, toLedgerTxOut, txOutValue, unsafeBuildTransaction, + utxoPairs, ) import qualified Hydra.Ledger.Cardano as Api import Hydra.Ledger.Cardano.Evaluate (evaluateTx) import Hydra.Ledger.Simple (SimpleTx) import Hydra.Party ( MultiSigned (MultiSigned), + Party, Signed (UnsafeSigned), SigningKey, aggregate, @@ -112,6 +127,7 @@ import Test.QuickCheck ( (===), ) import Test.QuickCheck.Instances () +import qualified Prelude spec :: Spec spec = do @@ -129,6 +145,9 @@ spec = do describe "TxOut hashing" $ do modifyMaxSuccess (const 20) $ prop "OffChain.hashTxOuts == OnChain.hashTxOuts" prop_consistentOnAndOffChainHashOfTxOuts + describe "CollectCom" $ do + prop "is healthy" $ + propTransactionValidates healthyCollectComTx describe "Close" $ do prop "is healthy" $ propTransactionValidates healthyCloseTx @@ -316,6 +335,87 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of [] (zip [0 ..] txOuts) +-- +-- CollectComTx +-- + +healthyCollectComTx :: (CardanoTx, Utxo) +healthyCollectComTx = + ( fromLedgerTx tx + , fromLedgerUtxo lookupUtxo + ) + where + tx = + collectComTx + Fixture.testNetworkId + (Utxo $ Map.fromList committedUtxo) + (headInput, headDatum, healthyCollectComOnChainParties) + ( (uncurry healthyCommitOutput <$> zip healthyCollectComParties committedUtxo) + & Map.fromList + & Map.mapKeys toLedgerTxIn + & Map.map (first toLedgerTxOut) + ) + + committedUtxo = + generateWith + (replicateM (length healthyCollectComParties) genCommittableTxOut) + 42 + + headInput = generateWith arbitrary 42 + headResolvedInput = mkHeadOutput (SJust headDatum) + headDatum = Ledger.Data $ toData healthyCollectComDatum + lookupUtxo = + Ledger.UTxO $ + Map.fromList + [ (headInput, headResolvedInput) + ] + +healthyCollectComDatum :: Head.State +healthyCollectComDatum = + Head.Initial + { contestationPeriod = generateWith arbitrary 42 + , parties = healthyCollectComOnChainParties + } + +healthyCollectComOnChainParties :: [OnChain.Party] +healthyCollectComOnChainParties = + Party.partyFromVerKey . vkey <$> healthyCollectComParties + +healthyCollectComParties :: [Party] +healthyCollectComParties = flip generateWith 42 $ do + alice <- arbitrary + bob <- arbitrary + carol <- arbitrary + pure [alice, bob, carol] + +genCommittableTxOut :: Gen (TxIn, TxOut CtxUTxO AlonzoEra) +genCommittableTxOut = + Prelude.head . utxoPairs <$> (genAdaOnlyUtxo `suchThat` (\u -> length u > 1)) + +healthyCommitOutput :: + Party -> + (TxIn, TxOut CtxUTxO AlonzoEra) -> + (TxIn, (TxOut CtxUTxO AlonzoEra, Ledger.Data LedgerEra)) +healthyCommitOutput party committed = + ( generateWith arbitrary seed + , + ( toCtxUTxOTxOut (TxOut commitAddress commitValue (mkTxOutDatum commitDatum)) + , Ledger.Data (toData commitDatum) + ) + ) + where + Party.UnsafeParty (fromIntegral -> seed) = Party.partyFromVerKey (vkey party) + + commitScript = + fromPlutusScript Commit.validatorScript + commitAddress = + mkScriptAddress @Api.PlutusScriptV1 Fixture.testNetworkId commitScript + commitValue = + mkTxOutValue $ + lovelaceToValue 2_000_000 <> (txOutValue . snd) committed + commitDatum = + mkCommitDatum party (Just committed) + -- -- CloseTx -- diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 8ef6dc54737..a93f6f0cf64 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -39,7 +39,13 @@ data State PlutusTx.unstableMakeIsData ''State data Input - = CollectCom {utxoHash :: Hash} + = -- FIXME: This `Hash` needs to be calculated by the on-chain script and not + -- provided as redeemer. This requires: + -- + -- (a) finding the new state-machine's state, make sure it's Open and extract the hash + -- (b) construct that merkle root from the collected UTXO + -- (c) controll that (a) and (b) matches. + CollectCom {utxoHash :: Hash} | Close { snapshotNumber :: SnapshotNumber , utxoHash :: Hash From 78e42c760f4d65cfd3f2a7dd48c81590182081e7 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 14 Jan 2022 12:12:35 +0100 Subject: [PATCH 2/2] Add missing commits to the lookup UTXO for healthy collectCom. --- .../test/Hydra/Chain/Direct/ContractSpec.hs | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs index ac7383bf8c9..44e6abf7ba3 100644 --- a/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/ContractSpec.hs @@ -345,30 +345,31 @@ healthyCollectComTx = , fromLedgerUtxo lookupUtxo ) where + lookupUtxo = + Ledger.UTxO $ + Map.singleton headInput headResolvedInput <> (fst <$> commits) + tx = collectComTx Fixture.testNetworkId (Utxo $ Map.fromList committedUtxo) (headInput, headDatum, healthyCollectComOnChainParties) - ( (uncurry healthyCommitOutput <$> zip healthyCollectComParties committedUtxo) - & Map.fromList - & Map.mapKeys toLedgerTxIn - & Map.map (first toLedgerTxOut) - ) + commits committedUtxo = generateWith (replicateM (length healthyCollectComParties) genCommittableTxOut) 42 + commits = + (uncurry healthyCommitOutput <$> zip healthyCollectComParties committedUtxo) + & Map.fromList + & Map.mapKeys toLedgerTxIn + & Map.map (first toLedgerTxOut) + headInput = generateWith arbitrary 42 headResolvedInput = mkHeadOutput (SJust headDatum) headDatum = Ledger.Data $ toData healthyCollectComDatum - lookupUtxo = - Ledger.UTxO $ - Map.fromList - [ (headInput, headResolvedInput) - ] healthyCollectComDatum :: Head.State healthyCollectComDatum =