Skip to content

Commit 0ca9288

Browse files
v0d1chv0d1ch
committed
TxTrace: Re-add validFailingAction and introduce more arbitrary values
in the generator
1 parent 6e132e5 commit 0ca9288

File tree

1 file changed

+75
-50
lines changed

1 file changed

+75
-50
lines changed

‎hydra-node/test/Hydra/Chain/Direct/TxTraceSpec.hs

Lines changed: 75 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,6 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
2020
import Hydra.Cardano.Api (
2121
SlotNo (..),
2222
mkTxOutDatumInline,
23-
renderUTxO,
2423
selectLovelace,
2524
throwError,
2625
txOutAddress,
@@ -40,7 +39,7 @@ import Hydra.Ledger (hashUTxO, utxoFromTx)
4039
import Hydra.Ledger.Cardano (Tx, adjustUTxO, genTxOut, genUTxO1)
4140
import Hydra.Ledger.Cardano.Evaluate (evaluateTx)
4241
import Hydra.Party (partyToChain)
43-
import Hydra.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber (..), getSnapshot, number)
42+
import Hydra.Snapshot (ConfirmedSnapshot (..), Snapshot (..), SnapshotNumber (..), number)
4443
import PlutusTx.Builtins (toBuiltin)
4544
import Test.Hydra.Fixture qualified as Fixture
4645
import Test.QuickCheck (Property, Smart (..), checkCoverage, cover, elements, forAll, frequency, ioProperty, oneof)
@@ -50,7 +49,7 @@ import Test.QuickCheck.StateModel (
5049
Actions (..),
5150
Any (..),
5251
HasVariables (getAllVariables),
53-
Polarity (PosPolarity),
52+
Polarity (..),
5453
PostconditionM,
5554
Realized,
5655
RunModel (..),
@@ -80,6 +79,7 @@ prop_traces =
8079
& cover 1 (countContests steps >= 2) "has multiple contests"
8180
& cover 5 (closeNonInitial steps) "close with non initial snapshots"
8281
& cover 5 (hasDecrement steps) "has successful decrements"
82+
& cover 1 (hasNegativeDecrement steps) "has negative decrements"
8383
where
8484
hasFanout =
8585
any $
@@ -118,10 +118,16 @@ prop_traces =
118118
Decrement{} -> polarity == PosPolarity
119119
_ -> False
120120

121+
hasNegativeDecrement =
122+
any $
123+
\(_ := ActionWithPolarity{polarAction, polarity}) -> case polarAction of
124+
Decrement{} -> polarity == NegPolarity
125+
_ -> False
126+
121127
prop_runActions :: Actions Model -> Property
122128
prop_runActions actions =
123129
monadic runAppMProperty $ do
124-
print actions
130+
-- print actions
125131
void (runActions actions)
126132
where
127133
runAppMProperty :: AppM Property -> Property
@@ -209,13 +215,16 @@ instance StateModel Model where
209215
oneof $
210216
[ do
211217
actor <- elements allActors
218+
someUTxOToDecrement <-
219+
if not (null utxoInHead) then oneof $ pure <$> [utxoInHead] else pure $ Set.fromList []
220+
212221
snapshot <-
213222
ModelSnapshot
214223
{ snapshotNumber = latestSnapshot
215224
, snapshotUTxO = utxoInHead
216-
, decommitUTxO = mempty
225+
, decommitUTxO = someUTxOToDecrement
217226
}
218-
`orSometimes` arbitrary
227+
`orArbitrary` arbitrary
219228
pure $ Some $ Close{actor, snapshot}
220229
]
221230
<> [ do
@@ -227,20 +236,22 @@ instance StateModel Model where
227236
, snapshotUTxO = Set.delete someUTxOToDecrement utxoInHead
228237
, decommitUTxO = Set.fromList [someUTxOToDecrement]
229238
}
230-
`orSometimes` arbitrary
239+
`orArbitrary` arbitrary
231240
pure $ Some Decrement{actor, snapshot}
232241
| not (null utxoInHead)
233242
]
234243
Closed{} ->
235244
oneof $
236245
[ do
237-
let snapshot =
238-
ModelSnapshot
239-
{ snapshotNumber = latestSnapshot
240-
, snapshotUTxO = utxoInHead
241-
, decommitUTxO = mempty
242-
}
243-
-- `orSometimes` arbitrary
246+
someUTxOToDecrement <-
247+
if not (null utxoInHead) then oneof $ pure <$> [utxoInHead] else pure $ Set.fromList []
248+
snapshot <-
249+
ModelSnapshot
250+
{ snapshotNumber = latestSnapshot
251+
, snapshotUTxO = utxoInHead
252+
, decommitUTxO = someUTxOToDecrement
253+
}
254+
`orArbitrary` arbitrary
244255
pure $ Some $ Fanout{snapshot}
245256
]
246257
<> [ do
@@ -253,7 +264,7 @@ instance StateModel Model where
253264
, snapshotUTxO = Set.delete someUTxOToDecrement utxoInHead
254265
, decommitUTxO = Set.fromList [someUTxOToDecrement]
255266
}
256-
`orSometimes` arbitrary
267+
`orArbitrary` arbitrary
257268
pure $ Some Contest{actor, snapshot}
258269
| not (null utxoInHead)
259270
]
@@ -265,7 +276,6 @@ instance StateModel Model where
265276
Decrement{snapshot} ->
266277
headState == Open
267278
&& snapshotNumber snapshot > latestSnapshot
268-
&& decommitUTxO snapshot `Set.isSubsetOf` utxoInHead
269279
Close{snapshot} ->
270280
headState == Open
271281
&& if snapshotNumber snapshot == 0
@@ -277,11 +287,32 @@ instance StateModel Model where
277287
headState == Closed
278288
&& actor `notElem` alreadyContested
279289
&& snapshotNumber snapshot > latestSnapshot
280-
&& decommitUTxO snapshot `Set.isSubsetOf` utxoInHead
281290
Fanout{snapshot} ->
282291
headState == Closed
283292
&& snapshotUTxO snapshot == utxoInHead
284293

294+
validFailingAction :: Model -> Action Model a -> Bool
295+
validFailingAction Model{headState, latestSnapshot, alreadyContested, utxoInHead} = \case
296+
Decrement{snapshot} ->
297+
headState == Open
298+
&& ( snapshotNumber snapshot <= latestSnapshot
299+
|| decommitUTxO snapshot `Set.isSubsetOf` utxoInHead
300+
)
301+
Close{snapshot} ->
302+
headState == Open
303+
&& snapshotNumber snapshot < latestSnapshot
304+
Contest{actor, snapshot} ->
305+
headState == Closed
306+
&& ( snapshotNumber snapshot <= latestSnapshot
307+
|| actor `elem` alreadyContested
308+
)
309+
Fanout{snapshot} ->
310+
headState == Closed
311+
&& ( snapshotNumber snapshot /= latestSnapshot
312+
|| snapshotUTxO snapshot /= utxoInHead
313+
)
314+
_ -> False
315+
285316
nextState :: Model -> Action Model a -> Var a -> Model
286317
nextState m t _result =
287318
case t of
@@ -535,17 +566,15 @@ newDecrementTx actor (snapshot, signatures) = do
535566
newCloseTx :: HasCallStack => Actor -> ConfirmedSnapshot Tx -> AppM Tx
536567
newCloseTx actor snapshot = do
537568
spendableUTxO <- get
538-
traceShow "close utxo" $
539-
traceShow (renderUTxO $ utxo $ getSnapshot snapshot) $
540-
either (failure . show) pure $
541-
close
542-
(actorChainContext actor)
543-
spendableUTxO
544-
(mkHeadId Fixture.testPolicyId)
545-
Fixture.testHeadParameters
546-
snapshot
547-
lowerBound
548-
upperBound
569+
either (failure . show) pure $
570+
close
571+
(actorChainContext actor)
572+
spendableUTxO
573+
(mkHeadId Fixture.testPolicyId)
574+
Fixture.testHeadParameters
575+
snapshot
576+
lowerBound
577+
upperBound
549578
where
550579
lowerBound = 0
551580

@@ -557,16 +586,14 @@ newCloseTx actor snapshot = do
557586
newContestTx :: HasCallStack => Actor -> ConfirmedSnapshot Tx -> AppM Tx
558587
newContestTx actor snapshot = do
559588
spendableUTxO <- get
560-
traceShow "contest utxo" $
561-
traceShow (renderUTxO $ utxo $ getSnapshot snapshot) $
562-
either (failure . show) pure $
563-
contest
564-
(actorChainContext actor)
565-
spendableUTxO
566-
(mkHeadId Fixture.testPolicyId)
567-
Fixture.cperiod
568-
snapshot
569-
currentTime
589+
either (failure . show) pure $
590+
contest
591+
(actorChainContext actor)
592+
spendableUTxO
593+
(mkHeadId Fixture.testPolicyId)
594+
Fixture.cperiod
595+
snapshot
596+
currentTime
570597
where
571598
currentTime = (0, posixSecondsToUTCTime 0)
572599

@@ -577,16 +604,14 @@ newFanoutTx :: Actor -> ModelSnapshot -> AppM (Either FanoutTxError Tx)
577604
newFanoutTx actor snapshot = do
578605
spendableUTxO <- get
579606
let (snapshot', _) = signedSnapshot snapshot
580-
traceShow "fanout utxo" $
581-
traceShow (renderUTxO $ utxo snapshot') $
582-
pure $
583-
fanout
584-
(actorChainContext actor)
585-
spendableUTxO
586-
Fixture.testSeedInput
587-
(utxo snapshot')
588-
(utxoToDecommit snapshot')
589-
deadline
607+
pure $
608+
fanout
609+
(actorChainContext actor)
610+
spendableUTxO
611+
Fixture.testSeedInput
612+
(utxo snapshot')
613+
(utxoToDecommit snapshot')
614+
deadline
590615
where
591616
CP.UnsafeContestationPeriod contestationPeriod = Fixture.cperiod
592617
deadline = SlotNo $ fromIntegral contestationPeriod * fromIntegral (length allActors)
@@ -655,5 +680,5 @@ expectInvalid = \case
655680

656681
-- | Generate sometimes a value with given generator, bur more often just use
657682
-- the given value.
658-
orSometimes :: a -> Gen a -> Gen a
659-
orSometimes a gen = frequency [(2, pure a), (1, gen)]
683+
orArbitrary :: a -> Gen a -> Gen a
684+
orArbitrary a gen = frequency [(1, pure a), (1, gen)]

0 commit comments

Comments
 (0)