From f351de9457245e956c59e0200919f519e868ce7d Mon Sep 17 00:00:00 2001 From: Sasha Bogicevic Date: Wed, 13 Nov 2024 14:03:31 +0100 Subject: [PATCH] Fix all of state spec tests --- hydra-node/src/Hydra/Chain/Direct/State.hs | 25 +++++++--------- .../test/Hydra/Chain/Direct/StateSpec.hs | 30 +++++++++---------- hydra-tx/src/Hydra/Tx/IsTx.hs | 1 - 3 files changed, 24 insertions(+), 32 deletions(-) diff --git a/hydra-node/src/Hydra/Chain/Direct/State.hs b/hydra-node/src/Hydra/Chain/Direct/State.hs index e06c2b11646..6ca58b10503 100644 --- a/hydra-node/src/Hydra/Chain/Direct/State.hs +++ b/hydra-node/src/Hydra/Chain/Direct/State.hs @@ -129,7 +129,6 @@ import Test.Hydra.Tx.Gen ( ) import Test.QuickCheck (choose, frequency, oneof, suchThat, vector) import Test.QuickCheck.Gen (elements) -import Test.QuickCheck.Modifiers (Positive (Positive)) -- | A class for accessing the known 'UTxO' set in a type. This is useful to get -- all the relevant UTxO for resolving transaction inputs. @@ -306,7 +305,7 @@ data ClosedState = ClosedState instance Arbitrary ClosedState where arbitrary = do -- XXX: Untangle the whole generator mess here - (_, st, _, _) <- genFanoutTx maxGenParties maxGenAssets + (_, st, _, _) <- genFanoutTx maxGenParties pure st shrink = genericShrink @@ -1003,10 +1002,7 @@ genChainStateWithTx = genFanoutWithState :: Gen (ChainContext, ChainState, UTxO, Tx, ChainTransition) genFanoutWithState = do - Positive numParties <- arbitrary - Positive numOutputs <- arbitrary - (hctx, st, utxo, tx) <- genFanoutTx numParties numOutputs - ctx <- pickChainContext hctx + (ctx, st, utxo, tx) <- genFanoutTx maxGenParties pure (ctx, Closed st, utxo, tx, Fanout) -- ** Warning zone @@ -1237,7 +1233,7 @@ genCloseTx numParties = do let cp = ctxContestationPeriod ctx (startSlot, pointInTime) <- genValidityBoundsFromContestationPeriod cp let utxo = getKnownUTxO stOpen - pure (cctx, stOpen, mempty, unsafeClose cctx utxo headId (ctxHeadParameters ctx) version snapshot startSlot pointInTime, snapshot) + pure (cctx, stOpen, utxo, unsafeClose cctx utxo headId (ctxHeadParameters ctx) version snapshot startSlot pointInTime, snapshot) genContestTx :: Gen (HydraContext, PointInTime, ClosedState, UTxO, Tx) genContestTx = do @@ -1259,16 +1255,15 @@ genContestTx = do contestPointInTime <- genPointInTimeBefore (getContestationDeadline stClosed) pure (ctx, closePointInTime, stClosed, mempty, unsafeContest cctx utxo headId cp version contestSnapshot contestPointInTime) -genFanoutTx :: Int -> Int -> Gen (HydraContext, ClosedState, UTxO, Tx) -genFanoutTx numParties numOutputs = do - ctx <- genHydraContext numParties - utxo <- genUTxOAdaOnlyOfSize numOutputs - let (inHead', toDecommit') = splitUTxO utxo - (_, toFanout, toDecommit, stClosed@ClosedState{seedTxIn}) <- genStClosed ctx inHead' (Just toDecommit') - cctx <- pickChainContext ctx +genFanoutTx :: Int -> Gen (ChainContext, ClosedState, UTxO, Tx) +genFanoutTx numParties = do + (cctx, stOpen, _utxo, txClose, snapshot) <- genCloseTx numParties + let toDecommit = utxoToDecommit $ getSnapshot snapshot + let toFanout = utxo $ getSnapshot snapshot + let stClosed@ClosedState{seedTxIn} = snd $ fromJust $ observeClose stOpen txClose let deadlineSlotNo = slotNoFromUTCTime systemStart slotLength (getContestationDeadline stClosed) spendableUTxO = getKnownUTxO stClosed - pure (ctx, stClosed, mempty, unsafeFanout cctx spendableUTxO seedTxIn toFanout toDecommit deadlineSlotNo) + pure (cctx, stClosed, mempty, unsafeFanout cctx spendableUTxO seedTxIn toFanout toDecommit deadlineSlotNo) getContestationDeadline :: ClosedState -> UTCTime getContestationDeadline diff --git a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs index d789218c1f4..94ce009cf28 100644 --- a/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs +++ b/hydra-node/test/Hydra/Chain/Direct/StateSpec.hs @@ -144,7 +144,6 @@ import Test.QuickCheck ( forAllShrink, getPositive, label, - sized, sublistOf, tabulate, (.&&.), @@ -350,20 +349,20 @@ spec = parallel $ do False & counterexample ("observeRecoverTx ignored transaction: " <> renderTxWithUTxO utxo tx) describe "increment" $ do - -- propBelowSizeLimit maxTxSize forAllIncrement + propBelowSizeLimit maxTxSize forAllIncrement propIsValid forAllIncrement describe "decrement" $ do propBelowSizeLimit maxTxSize forAllDecrement propIsValid forAllDecrement - prop "observes distributed outputs" $ - forAllDecrement' $ \toDistribute utxo tx -> - case observeDecrementTx utxo tx of - Just DecrementObservation{distributedOutputs} -> - distributedOutputs === toDistribute - Nothing -> - False & counterexample ("observeDecrementTx ignored transaction: " <> renderTxWithUTxO utxo tx) + prop "observes distributed outputs" $ + forAllDecrement' $ \toDistribute utxo tx -> + case observeDecrementTx utxo tx of + Just DecrementObservation{distributedOutputs} -> + distributedOutputs === toDistribute + Nothing -> + False & counterexample ("observeDecrementTx ignored transaction: " <> renderTxWithUTxO utxo tx) describe "close" $ do propBelowSizeLimit maxTxSize forAllClose @@ -692,8 +691,8 @@ forAllDecrement' :: ([TxOut CtxUTxO] -> UTxO -> Tx -> property) -> Property forAllDecrement' action = do - forAllShrink (genDecrementTx maximumNumberOfParties) shrink $ \(ctx, distributed, st, _, tx) -> - let utxo = getKnownUTxO st <> getKnownUTxO ctx <> utxo + forAllShrink (genDecrementTx maximumNumberOfParties) shrink $ \(ctx, distributed, st, utxo', tx) -> + let utxo = getKnownUTxO st <> getKnownUTxO ctx <> utxo' in action distributed utxo tx forAllClose :: @@ -753,11 +752,10 @@ forAllFanout :: Property forAllFanout action = -- TODO: The utxo to fanout should be more arbitrary to have better test coverage - forAll (sized $ \n -> genFanoutTx maximumNumberOfParties (n `min` maxSupported)) $ \(hctx, stClosed, _, tx) -> - forAllBlind (pickChainContext hctx) $ \ctx -> - let utxo = getKnownUTxO stClosed <> getKnownUTxO ctx - in action utxo tx - & label ("Fanout size: " <> prettyLength (countAssets $ txOuts' tx)) + forAll (genFanoutTx maximumNumberOfParties) $ \(ctx, stClosed, _, tx) -> + let utxo = getKnownUTxO stClosed <> getKnownUTxO ctx + in action utxo tx + & label ("Fanout size: " <> prettyLength (countAssets $ txOuts' tx)) where maxSupported = 44 diff --git a/hydra-tx/src/Hydra/Tx/IsTx.hs b/hydra-tx/src/Hydra/Tx/IsTx.hs index 0ed429d61ae..d3878b95deb 100644 --- a/hydra-tx/src/Hydra/Tx/IsTx.hs +++ b/hydra-tx/src/Hydra/Tx/IsTx.hs @@ -22,7 +22,6 @@ import Data.Text.Lazy.Builder (toLazyText) import Formatting.Buildable (build) import Hydra.Cardano.Api.Tx qualified as Api import Hydra.Cardano.Api.UTxO qualified as Api -import Hydra.Contract.Head qualified as Head import Hydra.Contract.Util qualified as Util import PlutusLedgerApi.V3 (fromBuiltin)