From 4d648f5a626df10655e01adffdd80c10216b716f Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 21 Apr 2022 10:22:03 +0200 Subject: [PATCH 1/9] Test closeTx validity in StateSpec and keep Hydra signing keys in HydraContext --- hydra-node/src/Hydra/Chain/Direct/Context.hs | 20 +++++++++++-------- .../test/Hydra/Chain/Direct/StateSpec.hs | 10 ++++++++-- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/hydra-node/src/Hydra/Chain/Direct/Context.hs b/hydra-node/src/Hydra/Chain/Direct/Context.hs index 06a62632bc4..c2f1fcef006 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Context.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Context.hs @@ -25,7 +25,8 @@ import Hydra.Chain.Direct.State ( ) import Hydra.Ledger.Cardano (genOneUTxOFor, genTxIn, genVerificationKey, renderTx) import Hydra.Party (Party) -import Test.QuickCheck (choose, elements, frequency, vector) +import qualified Hydra.Party as Hydra +import Test.QuickCheck (choose, elements, frequency) -- | Define some 'global' context from which generators can pick -- values for generation. This allows to write fairly independent generators @@ -36,17 +37,20 @@ import Test.QuickCheck (choose, elements, frequency, vector) -- be coherent. data HydraContext = HydraContext { ctxVerificationKeys :: [VerificationKey PaymentKey] - , ctxParties :: [Party] + , ctxHydraSigningKeys :: [Hydra.SigningKey] , ctxNetworkId :: NetworkId , ctxContestationPeriod :: DiffTime } deriving (Show) +ctxParties :: HydraContext -> [Party] +ctxParties = fmap Hydra.deriveParty . ctxHydraSigningKeys + ctxHeadParameters :: HydraContext -> HeadParameters -ctxHeadParameters HydraContext{ctxContestationPeriod, ctxParties} = - HeadParameters ctxContestationPeriod ctxParties +ctxHeadParameters ctx@HydraContext{ctxContestationPeriod} = + HeadParameters ctxContestationPeriod (ctxParties ctx) -- -- Generators @@ -62,13 +66,13 @@ genHydraContext maxParties = choose (1, maxParties) >>= genHydraContextFor genHydraContextFor :: Int -> Gen HydraContext genHydraContextFor n = do ctxVerificationKeys <- replicateM n genVerificationKey - ctxParties <- vector n + let ctxHydraSigningKeys = Hydra.generateKey . fromIntegral <$> [1 .. n] ctxNetworkId <- Testnet . NetworkMagic <$> arbitrary ctxContestationPeriod <- arbitrary pure $ HydraContext { ctxVerificationKeys - , ctxParties + , ctxHydraSigningKeys , ctxNetworkId , ctxContestationPeriod } @@ -76,8 +80,8 @@ genHydraContextFor n = do genStIdle :: HydraContext -> Gen (OnChainHeadState 'StIdle) -genStIdle HydraContext{ctxVerificationKeys, ctxNetworkId, ctxParties} = do - ownParty <- elements ctxParties +genStIdle ctx@HydraContext{ctxVerificationKeys, ctxNetworkId} = do + ownParty <- elements (ctxParties ctx) ownVerificationKey <- elements ctxVerificationKeys let peerVerificationKeys = ctxVerificationKeys \\ [ownVerificationKey] pure $ idleOnChainHeadState ctxNetworkId peerVerificationKeys ownVerificationKey ownParty diff --git a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs index 86aae6eccf7..66c996d1c49 100644 --- a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs @@ -86,7 +86,9 @@ import Hydra.Ledger.Cardano ( simplifyUTxO, ) import Hydra.Ledger.Cardano.Evaluate (evaluateTx') -import Hydra.Snapshot (isInitialSnapshot) +import Hydra.Party (SigningKey) +import qualified Hydra.Party as Hydra +import Hydra.Snapshot (ConfirmedSnapshot, isInitialSnapshot) import Ouroboros.Consensus.Block (Point, blockPoint) import Ouroboros.Consensus.Cardano.Block (HardForkBlock (BlockAlonzo)) import Ouroboros.Consensus.Shelley.Ledger (mkShelleyBlock) @@ -186,6 +188,7 @@ spec = parallel $ do describe "close" $ do propBelowSizeLimit maxTxSize forAllClose + propIsValid maxTxExecutionUnits forAllClose describe "fanout" $ do propBelowSizeLimit maxTxSize forAllFanout @@ -508,7 +511,7 @@ forAllClose :: forAllClose action = do forAll (genHydraContext 3) $ \ctx -> forAll (genStOpen ctx) $ \stOpen -> - forAll arbitrary $ \snapshot -> + forAll (genConfirmedSnapshot (ctxHydraSigningKeys ctx)) $ \snapshot -> action stOpen (close snapshot stOpen) & classify (isInitialSnapshot snapshot) @@ -578,6 +581,9 @@ genBlockAt sl txs = do let body' = body{Ledger.bheaderSlotNo = sl} in Ledger.BHeader body' sig +genConfirmedSnapshot :: [Hydra.SigningKey] -> Gen (ConfirmedSnapshot Tx) +genConfirmedSnapshot = undefined + -- -- Wrapping Transition for easy labelling -- From c1e20845c756e42f62c11b14122c8d37907fde75 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 21 Apr 2022 08:35:10 +0000 Subject: [PATCH 2/9] Generate valid confirmed snapshot --- hydra-node/src/Hydra/Chain/Direct/Context.hs | 3 ++- hydra-node/test/Hydra/Chain/Direct/StateSpec.hs | 9 ++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/hydra-node/src/Hydra/Chain/Direct/Context.hs b/hydra-node/src/Hydra/Chain/Direct/Context.hs index c2f1fcef006..56a8e6b2071 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Context.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Context.hs @@ -66,7 +66,8 @@ genHydraContext maxParties = choose (1, maxParties) >>= genHydraContextFor genHydraContextFor :: Int -> Gen HydraContext genHydraContextFor n = do ctxVerificationKeys <- replicateM n genVerificationKey - let ctxHydraSigningKeys = Hydra.generateKey . fromIntegral <$> [1 .. n] + startPoint <- arbitrary + let ctxHydraSigningKeys = Hydra.generateKey . fromIntegral <$> [startPoint .. startPoint + n] ctxNetworkId <- Testnet . NetworkMagic <$> arbitrary ctxContestationPeriod <- arbitrary pure $ diff --git a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs index 66c996d1c49..3b7b6c8f427 100644 --- a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs @@ -47,6 +47,7 @@ import Hydra.Chain.Direct ( import Hydra.Chain.Direct.Context ( HydraContext (..), ctxHeadParameters, + ctxParties, executeCommits, genCommit, genCommits, @@ -86,9 +87,8 @@ import Hydra.Ledger.Cardano ( simplifyUTxO, ) import Hydra.Ledger.Cardano.Evaluate (evaluateTx') -import Hydra.Party (SigningKey) import qualified Hydra.Party as Hydra -import Hydra.Snapshot (ConfirmedSnapshot, isInitialSnapshot) +import Hydra.Snapshot (ConfirmedSnapshot (..), isInitialSnapshot) import Ouroboros.Consensus.Block (Point, blockPoint) import Ouroboros.Consensus.Cardano.Block (HardForkBlock (BlockAlonzo)) import Ouroboros.Consensus.Shelley.Ledger (mkShelleyBlock) @@ -582,7 +582,10 @@ genBlockAt sl txs = do in Ledger.BHeader body' sig genConfirmedSnapshot :: [Hydra.SigningKey] -> Gen (ConfirmedSnapshot Tx) -genConfirmedSnapshot = undefined +genConfirmedSnapshot sks = do + snapshot <- arbitrary + let signatures = Hydra.aggregate $ fmap (`Hydra.sign` snapshot) sks + pure $ ConfirmedSnapshot{snapshot, signatures} -- -- Wrapping Transition for easy labelling From 426dc5c477c61d3d1d2ef4e1719b361f5036c014 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 21 Apr 2022 08:41:29 +0000 Subject: [PATCH 3/9] Add trace when snapshot number negative in Head contract --- hydra-plutus/src/Hydra/Contract/Head.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 950effd2824..4c9abc76303 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -263,7 +263,7 @@ checkClose context headContext parties snapshotNumber sig = checkSnapshot | snapshotNumber == 0 = True | snapshotNumber > 0 = verifySnapshotSignature parties snapshotNumber sig - | otherwise = False + | otherwise = traceError "negative snapshot number" {-# INLINEABLE checkClose #-} txOutAdaValue :: TxOut -> Integer From f77c1bc04bfcc04167a70cb29abb7c80333cb9e0 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 21 Apr 2022 10:48:33 +0200 Subject: [PATCH 4/9] Add more traces to Head validator --- hydra-plutus/src/Hydra/Contract/Head.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs index 4c9abc76303..5e30e247b8e 100644 --- a/hydra-plutus/src/Hydra/Contract/Head.hs +++ b/hydra-plutus/src/Hydra/Contract/Head.hs @@ -63,7 +63,7 @@ headValidator commitAddress initialAddress oldState input context = checkClose context headContext parties snapshotNumber signature (Closed{utxoHash}, Fanout{numberOfFanoutOutputs}) -> checkFanout utxoHash numberOfFanoutOutputs context - _ -> False + _ -> traceError "invalid head state transition" where headContext = mkHeadContext context initialAddress commitAddress @@ -180,7 +180,8 @@ checkCollectCom context@ScriptContext{scriptContextTxInfo = txInfo} headContext && mustBeSignedByParticipant context headContext where everyoneHasCommitted = - nTotalCommits == length parties + traceIfFalse "not everyone committed" $ + nTotalCommits == length parties HeadContext { headAddress @@ -295,14 +296,14 @@ mustBeSignedByParticipant :: HeadContext -> Bool mustBeSignedByParticipant ScriptContext{scriptContextTxInfo = txInfo} HeadContext{headCurrencySymbol} = - traceIfFalse "mustBeSignedByParticipant: did not found expected signer" $ - case getPubKeyHash <$> txInfoSignatories txInfo of - [signer] -> + case getPubKeyHash <$> txInfoSignatories txInfo of + [signer] -> + traceIfFalse "mustBeSignedByParticipant: did not find expected signer" $ signer `elem` (unTokenName <$> participationTokens) - [] -> - traceError "mustBeSignedByParticipant: no signers" - _ -> - traceError "mustBeSignedByParticipant: too many signers" + [] -> + traceError "mustBeSignedByParticipant: no signers" + _ -> + traceError "mustBeSignedByParticipant: too many signers" where participationTokens = loop (txInfoInputs txInfo) loop = \case @@ -330,7 +331,7 @@ mustContinueHeadWith ScriptContext{scriptContextTxInfo = txInfo} headAddress cha (o : rest) | txOutAddress o == headAddress -> traceIfFalse "wrong output head datum" (txOutDatum txInfo o == datum) - && checkOutputValue (xs <> rest) + && traceIfFalse "wrong output value" (checkOutputValue (xs <> rest)) (o : rest) -> checkOutputDatum (o : xs) rest From a4ac8d875cb94312971fdea832b00e80105853e3 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 21 Apr 2022 10:59:22 +0200 Subject: [PATCH 5/9] Generate correct length of hydra signing keys in HydraContext --- hydra-node/src/Hydra/Chain/Direct/Context.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/hydra-node/src/Hydra/Chain/Direct/Context.hs b/hydra-node/src/Hydra/Chain/Direct/Context.hs index 56a8e6b2071..1639cd27ad9 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Context.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Context.hs @@ -26,7 +26,7 @@ import Hydra.Chain.Direct.State ( import Hydra.Ledger.Cardano (genOneUTxOFor, genTxIn, genVerificationKey, renderTx) import Hydra.Party (Party) import qualified Hydra.Party as Hydra -import Test.QuickCheck (choose, elements, frequency) +import Test.QuickCheck (choose, elements, frequency, vector) -- | Define some 'global' context from which generators can pick -- values for generation. This allows to write fairly independent generators @@ -66,8 +66,7 @@ genHydraContext maxParties = choose (1, maxParties) >>= genHydraContextFor genHydraContextFor :: Int -> Gen HydraContext genHydraContextFor n = do ctxVerificationKeys <- replicateM n genVerificationKey - startPoint <- arbitrary - let ctxHydraSigningKeys = Hydra.generateKey . fromIntegral <$> [startPoint .. startPoint + n] + ctxHydraSigningKeys <- fmap Hydra.generateKey <$> vector n ctxNetworkId <- Testnet . NetworkMagic <$> arbitrary ctxContestationPeriod <- arbitrary pure $ From 3cd61043905f871247fff9275592ce5967193588 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Thu, 21 Apr 2022 09:20:20 +0000 Subject: [PATCH 6/9] Add close to tx-cost and some refactoring into a common genCloseTx --- hydra-node/exe/tx-cost/Main.hs | 41 ++++++++++- hydra-node/exe/tx-cost/TxCost.hs | 41 +++++++---- hydra-node/src/Hydra/Chain/Direct/Context.hs | 36 ++++++++++ .../test/Hydra/Chain/Direct/StateSpec.hs | 71 ++++++------------- 4 files changed, 126 insertions(+), 63 deletions(-) diff --git a/hydra-node/exe/tx-cost/Main.hs b/hydra-node/exe/tx-cost/Main.hs index aee2cf1b9b9..abb1077e258 100644 --- a/hydra-node/exe/tx-cost/Main.hs +++ b/hydra-node/exe/tx-cost/Main.hs @@ -26,6 +26,7 @@ import System.FilePath (()) import System.IO.Unsafe (unsafePerformIO) import TxCost ( computeAbortCost, + computeCloseCost, computeCollectComCost, computeCommitCost, computeFanOutCost, @@ -78,11 +79,26 @@ writeTransactionCostMarkdown hdl = do initC <- costOfInit commitC <- costOfCommit collectComC <- costOfCollectCom + closeC <- costOfClose abortC <- costOfAbort fanout <- costOfFanOut mt <- costOfMerkleTree let h = costOfHashing - hPut hdl $ encodeUtf8 $ unlines $ pageHeader <> intersperse "" [initC, commitC, collectComC, abortC, fanout, mt, h] + hPut hdl $ + encodeUtf8 $ + unlines $ + pageHeader + <> intersperse + "" + [ initC + , commitC + , collectComC + , closeC + , abortC + , fanout + , mt + , h + ] pageHeader :: [Text] pageHeader = @@ -173,6 +189,29 @@ costOfCollectCom = markdownCollectComCost <$> computeCollectComCost ) stats +costOfClose :: IO Text +costOfClose = markdownClose <$> computeCloseCost + where + markdownClose stats = + unlines $ + [ "## Cost of Close Transaction" + , "" + , "| # Parties | Tx. size | % max Mem | % max CPU |" + , "| :-------- | -------: | --------: | ----------: |" + ] + <> fmap + ( \(numParties, txSize, mem, cpu) -> + "| " <> show numParties + <> "| " + <> show txSize + <> " | " + <> show (100 * fromIntegral mem / maxMem) + <> " | " + <> show (100 * fromIntegral cpu / maxCpu) + <> " |" + ) + stats + costOfAbort :: IO Text costOfAbort = markdownAbortCost <$> computeAbortCost where diff --git a/hydra-node/exe/tx-cost/TxCost.hs b/hydra-node/exe/tx-cost/TxCost.hs index e577dfd6e88..8f1d7704273 100644 --- a/hydra-node/exe/tx-cost/TxCost.hs +++ b/hydra-node/exe/tx-cost/TxCost.hs @@ -55,13 +55,20 @@ import Hydra.Chain.Direct.Context ( HydraContext (ctxVerificationKeys), ctxHeadParameters, executeCommits, + genCloseTx, + genCollectComTx, genCommits, genHydraContextFor, genInitTx, genStIdle, genStInitialized, ) -import Hydra.Chain.Direct.State (abort, collect, commit, getKnownUTxO, initialize) +import Hydra.Chain.Direct.State ( + abort, + commit, + getKnownUTxO, + initialize, + ) import Hydra.Chain.Direct.Tx (fanoutTx) import qualified Hydra.Contract.Hash as Hash import qualified Hydra.Contract.Head as Head @@ -180,25 +187,35 @@ computeCollectComCost = <$> forM [1 .. 100] ( \numParties -> do - (tx, knownUtxo) <- generate $ genCollectComTx numParties + (st, tx) <- generate $ genCollectComTx numParties + let utxo = getKnownUTxO st let txSize = LBS.length $ serialize tx if txSize < fromIntegral (Ledger._maxTxSize pparams) - then case evaluateTx tx knownUtxo of + then case evaluateTx tx utxo of + (Right (mconcat . rights . Map.elems -> (Ledger.ExUnits mem cpu))) + | fromIntegral mem <= maxMem && fromIntegral cpu <= maxCpu -> + pure $ Just (NumParties numParties, TxSize txSize, MemUnit mem, CpuUnit cpu) + _ -> pure Nothing + else pure Nothing + ) + +computeCloseCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit)] +computeCloseCost = + catMaybes + <$> forM + [1 .. 100] + ( \numParties -> do + (st, tx) <- generate $ genCloseTx numParties + let utxo = getKnownUTxO st + let txSize = LBS.length $ serialize tx + if txSize < fromIntegral (Ledger._maxTxSize pparams) + then case evaluateTx tx utxo of (Right (mconcat . rights . Map.elems -> (Ledger.ExUnits mem cpu))) | fromIntegral mem <= maxMem && fromIntegral cpu <= maxCpu -> pure $ Just (NumParties numParties, TxSize txSize, MemUnit mem, CpuUnit cpu) _ -> pure Nothing else pure Nothing ) - where - genCollectComTx numParties = do - genHydraContextFor numParties - >>= \ctx -> - genInitTx ctx >>= \initTx -> - genCommits ctx initTx >>= \commits -> - genStIdle ctx >>= \stIdle -> - let stInitialized = executeCommits initTx commits stIdle - in pure (collect stInitialized, getKnownUTxO stInitialized) computeAbortCost :: IO [(NumParties, TxSize, MemUnit, CpuUnit)] computeAbortCost = diff --git a/hydra-node/src/Hydra/Chain/Direct/Context.hs b/hydra-node/src/Hydra/Chain/Direct/Context.hs index 1639cd27ad9..e091cbdac13 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Context.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Context.hs @@ -18,6 +18,8 @@ import Hydra.Chain.Direct.State ( HeadStateKind (..), ObserveTx, OnChainHeadState, + close, + collect, commit, idleOnChainHeadState, initialize, @@ -26,6 +28,7 @@ import Hydra.Chain.Direct.State ( import Hydra.Ledger.Cardano (genOneUTxOFor, genTxIn, genVerificationKey, renderTx) import Hydra.Party (Party) import qualified Hydra.Party as Hydra +import Hydra.Snapshot (ConfirmedSnapshot (..)) import Test.QuickCheck (choose, elements, frequency, vector) -- | Define some 'global' context from which generators can pick @@ -122,6 +125,39 @@ genCommit = , (10, genVerificationKey >>= genOneUTxOFor) ] +genCollectComTx :: Int -> Gen (OnChainHeadState 'StInitialized, Tx) +genCollectComTx numParties = do + ctx <- genHydraContextFor numParties + initTx <- genInitTx ctx + commits <- genCommits ctx initTx + stIdle <- genStIdle ctx + let stInitialized = executeCommits initTx commits stIdle + pure (stInitialized, collect stInitialized) + +genCloseTx :: Int -> Gen (OnChainHeadState 'StOpen, Tx) +genCloseTx numParties = do + ctx <- genHydraContext numParties + stOpen <- genStOpen ctx + snapshot <- genConfirmedSnapshot (ctxHydraSigningKeys ctx) + pure (stOpen, close snapshot stOpen) + +genStOpen :: + HydraContext -> + Gen (OnChainHeadState 'StOpen) +genStOpen ctx = do + initTx <- genInitTx ctx + commits <- genCommits ctx initTx + stInitialized <- executeCommits initTx commits <$> genStIdle ctx + let collectComTx = collect stInitialized + pure $ snd $ unsafeObserveTx @_ @ 'StOpen collectComTx stInitialized + +genConfirmedSnapshot :: [Hydra.SigningKey] -> Gen (ConfirmedSnapshot Tx) +genConfirmedSnapshot sks = do + snapshot <- arbitrary + let signatures = Hydra.aggregate $ fmap (`Hydra.sign` snapshot) sks + -- TODO: yield some initial snapshots + pure $ ConfirmedSnapshot{snapshot, signatures} + -- -- Here be dragons -- diff --git a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs index 3b7b6c8f427..55920093cbe 100644 --- a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs @@ -49,12 +49,15 @@ import Hydra.Chain.Direct.Context ( ctxHeadParameters, ctxParties, executeCommits, + genCloseTx, + genCollectComTx, genCommit, genCommits, genHydraContext, genInitTx, genStIdle, genStInitialized, + genStOpen, unsafeCommit, unsafeObserveTx, ) @@ -69,7 +72,6 @@ import Hydra.Chain.Direct.State ( TransitionFrom (..), abort, close, - collect, commit, fanout, getKnownUTxO, @@ -87,8 +89,6 @@ import Hydra.Ledger.Cardano ( simplifyUTxO, ) import Hydra.Ledger.Cardano.Evaluate (evaluateTx') -import qualified Hydra.Party as Hydra -import Hydra.Snapshot (ConfirmedSnapshot (..), isInitialSnapshot) import Ouroboros.Consensus.Block (Point, blockPoint) import Ouroboros.Consensus.Cardano.Block (HardForkBlock (BlockAlonzo)) import Ouroboros.Consensus.Shelley.Ledger (mkShelleyBlock) @@ -354,7 +354,7 @@ propBelowSizeLimit :: SpecWith () propBelowSizeLimit txSizeLimit forAllTx = prop ("transaction size is below " <> showKB txSizeLimit) $ - forAllTx $ \_st tx -> + forAllTx $ \_ tx -> let cbor = serialize tx len = LBS.length cbor in len < txSizeLimit @@ -372,20 +372,20 @@ propIsValid :: SpecWith () propIsValid exUnits forAllTx = prop ("validates within " <> show exUnits) $ - forAllTx $ \st tx -> + forAllTx $ \st tx -> do let lookupUTxO = getKnownUTxO st - in case evaluateTx' exUnits tx lookupUTxO of - Left basicFailure -> - property False - & counterexample ("Tx: " <> renderTx tx) - & counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUTxO)) - & counterexample ("Phase-1 validation failed: " <> show basicFailure) - Right redeemerReport -> - all isRight (Map.elems redeemerReport) - & counterexample ("Tx: " <> renderTx tx) - & counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUTxO)) - & counterexample ("Redeemer report: " <> show redeemerReport) - & counterexample "Phase-2 validation failed" + case evaluateTx' exUnits tx lookupUTxO of + Left basicFailure -> + property False + & counterexample ("Tx: " <> renderTx tx) + & counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUTxO)) + & counterexample ("Phase-1 validation failed: " <> show basicFailure) + Right redeemerReport -> + all isRight (Map.elems redeemerReport) + & counterexample ("Tx: " <> renderTx tx) + & counterexample ("Lookup utxo: " <> decodeUtf8 (encodePretty lookupUTxO)) + & counterexample ("Redeemer report: " <> show redeemerReport) + & counterexample "Phase-2 validation failed" -- -- QuickCheck Extras @@ -496,29 +496,16 @@ forAllCollectCom :: (Testable property) => (OnChainHeadState 'StInitialized -> Tx -> property) -> Property -forAllCollectCom action = do - forAll (genHydraContext 3) $ \ctx -> - forAllShow (genInitTx ctx) renderTx $ \initTx -> do - forAllShow (genCommits ctx initTx) renderTxs $ \commits -> - forAll (genStIdle ctx) $ \stIdle -> - let stInitialized = executeCommits initTx commits stIdle - in action stInitialized (collect stInitialized) +forAllCollectCom action = + forAll (genCollectComTx 3) $ uncurry action forAllClose :: (Testable property) => (OnChainHeadState 'StOpen -> Tx -> property) -> Property forAllClose action = do - forAll (genHydraContext 3) $ \ctx -> - forAll (genStOpen ctx) $ \stOpen -> - forAll (genConfirmedSnapshot (ctxHydraSigningKeys ctx)) $ \snapshot -> - action stOpen (close snapshot stOpen) - & classify - (isInitialSnapshot snapshot) - "Close with initial snapshot" - & classify - (not (isInitialSnapshot snapshot)) - "Close with multi-signed snapshot" + -- TODO: label / classify tx and snapshots to understand test failures + forAll (genCloseTx 3) $ uncurry action forAllFanout :: (Testable property) => @@ -552,16 +539,6 @@ genByronCommit = do value <- genValue pure $ UTxO.singleton (input, TxOut addr value TxOutDatumNone) -genStOpen :: - HydraContext -> - Gen (OnChainHeadState 'StOpen) -genStOpen ctx = do - initTx <- genInitTx ctx - commits <- genCommits ctx initTx - stInitialized <- executeCommits initTx commits <$> genStIdle ctx - let collectComTx = collect stInitialized - pure $ snd $ unsafeObserveTx @_ @ 'StOpen collectComTx stInitialized - genStClosed :: HydraContext -> Gen (OnChainHeadState 'StClosed) @@ -581,12 +558,6 @@ genBlockAt sl txs = do let body' = body{Ledger.bheaderSlotNo = sl} in Ledger.BHeader body' sig -genConfirmedSnapshot :: [Hydra.SigningKey] -> Gen (ConfirmedSnapshot Tx) -genConfirmedSnapshot sks = do - snapshot <- arbitrary - let signatures = Hydra.aggregate $ fmap (`Hydra.sign` snapshot) sks - pure $ ConfirmedSnapshot{snapshot, signatures} - -- -- Wrapping Transition for easy labelling -- From 14cd8e22fb83f9644719d6db4cab0d040075f6f6 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 21 Apr 2022 11:54:30 +0200 Subject: [PATCH 7/9] Fix genCloseTx to use fixed number of parties --- hydra-node/src/Hydra/Chain/Direct/Context.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hydra-node/src/Hydra/Chain/Direct/Context.hs b/hydra-node/src/Hydra/Chain/Direct/Context.hs index e091cbdac13..35cf0854c01 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Context.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Context.hs @@ -136,7 +136,7 @@ genCollectComTx numParties = do genCloseTx :: Int -> Gen (OnChainHeadState 'StOpen, Tx) genCloseTx numParties = do - ctx <- genHydraContext numParties + ctx <- genHydraContextFor numParties stOpen <- genStOpen ctx snapshot <- genConfirmedSnapshot (ctxHydraSigningKeys ctx) pure (stOpen, close snapshot stOpen) From 65df2055b194821052e7b2db40b7672e09831036 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 21 Apr 2022 14:34:17 +0200 Subject: [PATCH 8/9] Generate InitialSnapshot in genConfirmedSnapshot Also move it to `Hydra.Snapshot` and use it in the `Arbitrary ConfirmedSnapshot` instance, which also benefits of higher frequency `ConfirmedSnapshot`. --- hydra-node/src/Hydra/Chain/Direct/Context.hs | 9 +------- hydra-node/src/Hydra/Snapshot.hs | 22 ++++++++++++++++++-- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/hydra-node/src/Hydra/Chain/Direct/Context.hs b/hydra-node/src/Hydra/Chain/Direct/Context.hs index 35cf0854c01..aaaa6867659 100644 --- a/hydra-node/src/Hydra/Chain/Direct/Context.hs +++ b/hydra-node/src/Hydra/Chain/Direct/Context.hs @@ -28,7 +28,7 @@ import Hydra.Chain.Direct.State ( import Hydra.Ledger.Cardano (genOneUTxOFor, genTxIn, genVerificationKey, renderTx) import Hydra.Party (Party) import qualified Hydra.Party as Hydra -import Hydra.Snapshot (ConfirmedSnapshot (..)) +import Hydra.Snapshot (genConfirmedSnapshot) import Test.QuickCheck (choose, elements, frequency, vector) -- | Define some 'global' context from which generators can pick @@ -151,13 +151,6 @@ genStOpen ctx = do let collectComTx = collect stInitialized pure $ snd $ unsafeObserveTx @_ @ 'StOpen collectComTx stInitialized -genConfirmedSnapshot :: [Hydra.SigningKey] -> Gen (ConfirmedSnapshot Tx) -genConfirmedSnapshot sks = do - snapshot <- arbitrary - let signatures = Hydra.aggregate $ fmap (`Hydra.sign` snapshot) sks - -- TODO: yield some initial snapshots - pure $ ConfirmedSnapshot{snapshot, signatures} - -- -- Here be dragons -- diff --git a/hydra-node/src/Hydra/Snapshot.hs b/hydra-node/src/Hydra/Snapshot.hs index 8ec0d8ca835..f8b67e52ad1 100644 --- a/hydra-node/src/Hydra/Snapshot.hs +++ b/hydra-node/src/Hydra/Snapshot.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Hydra.Snapshot where @@ -10,6 +9,8 @@ import Cardano.Crypto.Util (SignableRepresentation (..)) import Data.Aeson (object, withObject, (.:), (.=)) import Hydra.Ledger (IsTx (..)) import Hydra.Party (MultiSigned) +import qualified Hydra.Party as Hydra +import Test.QuickCheck (frequency) type SnapshotNumber = Natural @@ -105,4 +106,21 @@ isInitialSnapshot = \case ConfirmedSnapshot{} -> False instance (Arbitrary tx, Arbitrary (UTxOType tx)) => Arbitrary (ConfirmedSnapshot tx) where - arbitrary = genericArbitrary + arbitrary = do + ks <- fmap Hydra.generateKey <$> arbitrary + genConfirmedSnapshot ks + +genConfirmedSnapshot :: + (Arbitrary tx, Arbitrary (UTxOType tx)) => + [Hydra.SigningKey] -> + Gen (ConfirmedSnapshot tx) +genConfirmedSnapshot sks = + frequency + [ (1, InitialSnapshot <$> arbitrary) + , (9, confirmedSnapshot) + ] + where + confirmedSnapshot = do + snapshot <- arbitrary + let signatures = Hydra.aggregate $ fmap (`Hydra.sign` snapshot) sks + pure $ ConfirmedSnapshot{snapshot, signatures} From 99f2ad432911b76cdfeaa0afd67f5fee654b496a Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Thu, 21 Apr 2022 15:02:57 +0200 Subject: [PATCH 9/9] Fix initialSnapshot generator --- hydra-node/src/Hydra/Snapshot.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/hydra-node/src/Hydra/Snapshot.hs b/hydra-node/src/Hydra/Snapshot.hs index f8b67e52ad1..4b91eef8f2b 100644 --- a/hydra-node/src/Hydra/Snapshot.hs +++ b/hydra-node/src/Hydra/Snapshot.hs @@ -116,10 +116,18 @@ genConfirmedSnapshot :: Gen (ConfirmedSnapshot tx) genConfirmedSnapshot sks = frequency - [ (1, InitialSnapshot <$> arbitrary) + [ (1, initialSnapshot) , (9, confirmedSnapshot) ] where + initialSnapshot = do + s <- arbitrary + -- FIXME: The fact that we need to set a constant 0 here is a code smell. + -- Initial snapshots with a different snapshot number are not valid and we + -- should model 'InitialSnapshot' differently, i.e not holding a + -- SnapshotNumber + pure InitialSnapshot{snapshot = s{number = 0}} + confirmedSnapshot = do snapshot <- arbitrary let signatures = Hydra.aggregate $ fmap (`Hydra.sign` snapshot) sks