Skip to content

Commit eeeea5c

Browse files
v0d1chv0d1ch
committed
TxSpec: Refactor actions
1 parent 5844bc0 commit eeeea5c

File tree

1 file changed

+76
-109
lines changed

1 file changed

+76
-109
lines changed

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

Lines changed: 76 additions & 109 deletions
Original file line numberDiff line numberDiff line change
@@ -32,7 +32,6 @@ import Cardano.Ledger.Api (
3232
import Cardano.Ledger.Core (EraTx (getMinFeeTx))
3333
import Cardano.Ledger.Credential (Credential (..))
3434
import Control.Lens ((^.))
35-
import Data.List (findIndex)
3635
import Data.Map qualified as Map
3736
import Data.Maybe.Strict (StrictMaybe (..))
3837
import Data.Set qualified as Set
@@ -76,9 +75,7 @@ import Hydra.Chain.Direct.TxTraceSpec (ModelSnapshot (..), generateUTxOFromModel
7675
import Hydra.Chain.Direct.Wallet (ErrCoverFee (..), coverFee_)
7776
import Hydra.ContestationPeriod (ContestationPeriod (..))
7877
import Hydra.Contract.Commit qualified as Commit
79-
import Hydra.Contract.Error (toErrorCode)
8078
import Hydra.Contract.Head qualified as Head
81-
import Hydra.Contract.HeadError (HeadError (..))
8279
import Hydra.Contract.HeadState qualified as HeadState
8380
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
8481
import Hydra.Contract.Initial qualified as Initial
@@ -281,27 +278,29 @@ spec =
281278
UTxO.singleton (headTxIn, modifyTxOutValue (<> decommitValue) (healthyOpenHeadTxOut datum))
282279
<> registryUTxO scriptRegistry
283280

284-
let decrementSnapshot =
281+
let startingSnapshot =
285282
Snapshot{headId = headId', confirmed = [], number = 2, utxo = utxo', utxoToDecommit = Just utxoToDecommit'}
286283

287-
let decrementSnapshots =
288-
[ (decrementSnapshot, Nothing)
289-
, (mutateSnapshotNumber (\a -> abs $ a - 1) decrementSnapshot, Nothing)
284+
let validSnapshots =
285+
[ startingSnapshot
290286
]
291-
292-
let closeSnapshots = [(decrementSnapshot, Nothing)]
293-
294-
let contestSnapshots = [(mutateSnapshotNumber (+ 1) decrementSnapshot, Nothing)]
295-
-- (mutateSnapshotNumber (const 0) decrementSnapshot, createCloseDatumFromOpen, Just TooOldSnapshot)
296-
297-
let fanoutSnapshots = [(decrementSnapshot, Nothing)
298-
]
299-
300-
flip evalState spendableUTxO $ do
301-
void $ produceDecrement ctx scriptRegistry headId' parameters decrementSnapshots
302-
void $ produceClose ctx scriptRegistry headId' parameters closeSnapshots
303-
void $ produceContest ctx scriptRegistry headId' contestSnapshots
304-
produceFanout ctx scriptRegistry txIn fanoutSnapshots
287+
let decrementAction =
288+
produceDecrement ctx scriptRegistry headId' parameters
289+
let closeAction =
290+
produceClose ctx scriptRegistry headId' parameters
291+
let contestAction =
292+
produceContest ctx scriptRegistry headId'
293+
let fanoutAction =
294+
produceFanout ctx scriptRegistry txIn
295+
296+
let applySnapshot sn = do
297+
let (decrementResult, decrementUTxO) = decrementAction (spendableUTxO, sn)
298+
let (closeResult, closeUTxO) = closeAction (decrementUTxO, sn)
299+
let (contestResult, contestUTxO) = contestAction (closeUTxO, mutateSnapshotNumber (+ 1) sn)
300+
let (fanoutResult, _fanoutUTxO) = fanoutAction (contestUTxO, sn)
301+
[decrementResult, closeResult, contestResult, fanoutResult]
302+
303+
conjoin $ conjoin . applySnapshot <$> validSnapshots
305304

306305
mutateSnapshotNumber :: (SnapshotNumber -> SnapshotNumber) -> Snapshot Tx -> Snapshot Tx
307306
mutateSnapshotNumber fn snapshot =
@@ -333,93 +332,75 @@ produceDecrement ::
333332
ScriptRegistry ->
334333
HeadId ->
335334
HeadParameters ->
336-
[(Snapshot Tx, Maybe HeadError)] ->
337-
State UTxO Property
338-
produceDecrement ctx scriptRegistry headId parameters decrements =
339-
conjoin
340-
<$> mapM
341-
( \(snapshot, expectedError) -> do
342-
spendableUTxO <- get
343-
let signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]
344-
case decrement ctx headId parameters spendableUTxO snapshot signatures of
345-
Left err -> pure $ counterexample ("Decrement: " <> show err) $ property False
346-
Right tx ->
347-
if isNothing expectedError
348-
then do
349-
let decommitValue = foldMap (txOutValue . snd) (UTxO.pairs $ fromMaybe mempty $ utxoToDecommit snapshot)
350-
let (headIn, headOut) = findHeadUTxO (utxoFromTx tx)
351-
let headUTxO = UTxO.singleton (headIn, modifyTxOutValue (<> decommitValue) headOut)
352-
put $ headUTxO <> registryUTxO scriptRegistry
353-
pure $ evaluateAndMatchError tx spendableUTxO expectedError
354-
else pure $ evaluateAndMatchError tx spendableUTxO expectedError
355-
)
356-
decrements
335+
(UTxO, Snapshot Tx) ->
336+
(Property, UTxO)
337+
produceDecrement ctx scriptRegistry headId parameters (spendableUTxO, snapshot) = do
338+
let signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]
339+
case decrement ctx headId parameters spendableUTxO snapshot signatures of
340+
Left err -> (counterexample ("Decrement: " <> show err) $ property False, spendableUTxO)
341+
Right tx -> do
342+
case utxoToDecommit snapshot of
343+
Nothing ->
344+
( evaluateAndMatchError tx spendableUTxO
345+
& counterexample ("Decrement snapshot: " <> show snapshot)
346+
, utxoFromTx tx <> registryUTxO scriptRegistry
347+
)
348+
Just toDecommit -> do
349+
let decommitValue = foldMap (txOutValue . snd) (UTxO.pairs toDecommit)
350+
let (headIn, headOut) = findHeadUTxO (utxoFromTx tx)
351+
let headUTxO = UTxO.singleton (headIn, modifyTxOutValue (<> decommitValue) headOut)
352+
( evaluateAndMatchError tx spendableUTxO
353+
& counterexample ("Decrement snapshot: " <> show snapshot)
354+
, headUTxO <> registryUTxO scriptRegistry
355+
)
357356

358357
produceClose ::
359358
ChainContext ->
360359
ScriptRegistry ->
361360
HeadId ->
362361
HeadParameters ->
363-
[(Snapshot Tx, Maybe HeadError)] ->
364-
State UTxO Property
365-
produceClose ctx scriptRegistry headId parameters closes = do
366-
conjoin
367-
<$> mapM
368-
( \(snapshot, expectedError) -> do
369-
spendableUTxO <- get
370-
let signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]
371-
case close ctx spendableUTxO headId parameters ConfirmedSnapshot{snapshot, signatures} 0 (0, posixSecondsToUTCTime 0) of
372-
Left err -> pure $ counterexample ("Close: " <> show err) $ property False
373-
Right tx ->
374-
if isNothing expectedError
375-
then do
376-
put $ utxoFromTx tx <> registryUTxO scriptRegistry
377-
pure $ evaluateAndMatchError tx spendableUTxO expectedError
378-
else pure $ evaluateAndMatchError tx spendableUTxO expectedError
362+
(UTxO, Snapshot Tx) ->
363+
(Property, UTxO)
364+
produceClose ctx scriptRegistry headId parameters (spendableUTxO, snapshot) = do
365+
let signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]
366+
case close ctx spendableUTxO headId parameters ConfirmedSnapshot{snapshot, signatures} 0 (0, posixSecondsToUTCTime 0) of
367+
Left err -> (counterexample ("Close: " <> show err) $ property False, spendableUTxO)
368+
Right tx ->
369+
( evaluateAndMatchError tx spendableUTxO
370+
& counterexample ("Close snapshot: " <> show snapshot)
371+
, utxoFromTx tx <> registryUTxO scriptRegistry
379372
)
380-
closes
381373

382374
produceContest ::
383375
ChainContext ->
384376
ScriptRegistry ->
385377
HeadId ->
386-
[(Snapshot Tx, Maybe HeadError)] ->
387-
State UTxO Property
388-
produceContest ctx scriptRegistry headId contests =
389-
conjoin
390-
<$> mapM
391-
( \(snapshot, expectedError) -> do
392-
spendableUTxO <- get
393-
let signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]
394-
case contest ctx spendableUTxO headId defaultContestationPeriod ConfirmedSnapshot{snapshot, signatures} (0, posixSecondsToUTCTime 0) of
395-
Left err -> pure $ counterexample ("Contest: " <> show err) $ property False
396-
Right tx ->
397-
if isNothing expectedError
398-
then do
399-
put $ utxoFromTx tx <> registryUTxO scriptRegistry
400-
pure $ evaluateAndMatchError tx spendableUTxO expectedError
401-
else pure $ evaluateAndMatchError tx spendableUTxO expectedError
378+
(UTxO, Snapshot Tx) ->
379+
(Property, UTxO)
380+
produceContest ctx scriptRegistry headId (spendableUTxO, snapshot) = do
381+
let signatures = aggregate [sign sk snapshot | sk <- [aliceSk, bobSk, carolSk]]
382+
case contest ctx spendableUTxO headId defaultContestationPeriod ConfirmedSnapshot{snapshot, signatures} (0, posixSecondsToUTCTime 0) of
383+
Left err -> (counterexample ("Contest: " <> show err) $ property False, spendableUTxO)
384+
Right tx ->
385+
( evaluateAndMatchError tx spendableUTxO
386+
& counterexample ("Contest snapshot: " <> show snapshot)
387+
, utxoFromTx tx <> registryUTxO scriptRegistry
402388
)
403-
contests
404389

405390
produceFanout ::
406391
ChainContext ->
407392
ScriptRegistry ->
408393
TxIn ->
409-
[(Snapshot Tx, Maybe HeadError)] ->
410-
State UTxO Property
411-
produceFanout ctx scriptRegistry seedTxIn fanouts =
412-
conjoin
413-
<$> mapM
414-
( \(snapshot, expectedError) -> do
415-
spendableUTxO <- get
416-
case fanout ctx spendableUTxO seedTxIn (utxo snapshot) (utxoToDecommit snapshot) 20 of
417-
Left err -> pure $ counterexample ("Fanout: " <> show err) $ property False
418-
Right tx -> do
419-
put $ utxoFromTx tx <> registryUTxO scriptRegistry
420-
pure $ evaluateAndMatchError tx spendableUTxO expectedError
394+
(UTxO, Snapshot Tx) ->
395+
(Property, UTxO)
396+
produceFanout ctx scriptRegistry seedTxIn (spendableUTxO, snapshot) =
397+
case fanout ctx spendableUTxO seedTxIn (utxo snapshot) (utxoToDecommit snapshot) 20 of
398+
Left err -> (counterexample ("Fanout: " <> show err) $ property False, spendableUTxO)
399+
Right tx ->
400+
( evaluateAndMatchError tx spendableUTxO
401+
& counterexample ("Fanout snapshot: " <> show snapshot)
402+
, utxoFromTx tx <> registryUTxO scriptRegistry
421403
)
422-
fanouts
423404

424405
hasHigherSnapshotNumber :: [(Snapshot Tx, Snapshot Tx, Maybe String)] -> Bool
425406
hasHigherSnapshotNumber =
@@ -429,32 +410,18 @@ hasLowerSnapshotNumber :: [(Snapshot Tx, Snapshot Tx, Maybe String)] -> Bool
429410
hasLowerSnapshotNumber =
430411
any (\(mutated, original, _) -> number mutated < number original)
431412

432-
-- | Evaluates the transaction and in case the expected error is provided
433-
-- it will yield green test since we indeed got the expected error.
434-
evaluateAndMatchError :: Tx -> UTxO -> Maybe HeadError -> Property
435-
evaluateAndMatchError tx spendableUTxO expectedError =
413+
evaluateAndMatchError :: Tx -> UTxO -> Property
414+
evaluateAndMatchError tx spendableUTxO =
436415
case evaluateTx tx spendableUTxO of
437416
Left err ->
438417
property False
439418
& counterexample ("Transaction: " <> renderTxWithUTxO spendableUTxO tx)
440419
& counterexample ("Phase-1 validation failed: " <> show err)
441420
Right redeemerReport ->
442-
if isJust expectedError
443-
then
444-
any isLeft (Map.elems redeemerReport) && contains expectedError (show redeemerReport)
445-
& counterexample ("Transaction: " <> renderTxWithUTxO spendableUTxO tx)
446-
& counterexample ("Redeemer report: " <> show redeemerReport)
447-
& counterexample ("Error doesn't match: " <> show expectedError)
448-
& counterexample "Phase-2 validation failed"
449-
else
450-
all isRight (Map.elems redeemerReport)
451-
& counterexample ("Transaction: " <> renderTxWithUTxO spendableUTxO tx)
452-
& counterexample ("Redeemer report: " <> show redeemerReport)
453-
& counterexample "Phase-2 validation failed"
454-
where
455-
contains Nothing _ = False
456-
contains (Just expectedError') searchStr =
457-
isJust (findIndex (isPrefixOf (T.unpack $ toErrorCode expectedError')) (tails searchStr))
421+
all isRight (Map.elems redeemerReport)
422+
& counterexample ("Transaction: " <> renderTxWithUTxO spendableUTxO tx)
423+
& counterexample ("Redeemer report: " <> show redeemerReport)
424+
& counterexample "Phase-2 validation failed"
458425

459426
genPerfectModelSnapshot :: Gen ModelSnapshot
460427
genPerfectModelSnapshot = do

0 commit comments

Comments
 (0)