Skip to content

Commit a02c8d1

Browse files
vrom911v0d1ch
vrom911
authored and
v0d1ch
committed
Add capUTxO tests
1 parent 4d5b113 commit a02c8d1

File tree

3 files changed

+163
-3
lines changed

3 files changed

+163
-3
lines changed

‎hydra-tx/hydra-tx.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -172,6 +172,7 @@ test-suite tests
172172
Hydra.Tx.Contract.Increment
173173
Hydra.Tx.Contract.Init
174174
Hydra.Tx.Contract.Recover
175+
Hydra.Tx.DepositSpec
175176
Hydra.Tx.HeadIdSpec
176177
Hydra.Tx.IsTxSpec
177178
Spec

‎hydra-tx/src/Hydra/Tx/Deposit.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -129,13 +129,14 @@ capUTxO utxo target
129129
[] -> (foundSoFar, leftovers)
130130
(txIn, txOut) : rest ->
131131
let x = selectLovelace (txOutValue txOut)
132-
in if currentSum + x <= target
132+
newSum = currentSum + x
133+
in if newSum <= target
133134
then
134135
-- Include the entire output if it doesn't exceed the target.
135136
go
136137
(foundSoFar <> UTxO.singleton txIn txOut)
137138
(UTxO.difference leftovers $ UTxO.singleton txIn txOut)
138-
(currentSum + x)
139+
newSum
139140
rest
140141
else
141142
-- Split the output to meet the target exactly.
@@ -146,7 +147,7 @@ capUTxO utxo target
146147
in go
147148
(foundSoFar <> UTxO.singleton txIn cappedTxOut)
148149
(UTxO.difference leftovers (UTxO.singleton txIn txOut) <> UTxO.singleton txIn leftoverTxOut)
149-
(currentSum + cappedValue)
150+
target
150151
rest
151152

152153
-- | Helper to create a new TxOut with a specified lovelace value

‎hydra-tx/test/Hydra/Tx/DepositSpec.hs‎

Lines changed: 158 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,158 @@
1+
module Hydra.Tx.DepositSpec where
2+
3+
import Hydra.Prelude
4+
import Test.Hydra.Prelude
5+
6+
import Cardano.Api.UTxO qualified as UTxO
7+
import Data.Set qualified as Set
8+
import Hydra.Cardano.Api (Coin (..), UTxO, selectLovelace, txOutValue)
9+
import Hydra.Tx.Deposit (capUTxO)
10+
import Test.Hydra.Tx.Gen (genUTxOSized)
11+
import Test.QuickCheck (Property, counterexample, (===), (==>))
12+
13+
spec :: Spec
14+
spec =
15+
parallel $ do
16+
describe "capUTxO" $ do
17+
describe "tests" $ do
18+
it "returns empty UTxO when target is 0" $ do
19+
let utxo = genUTxOSized 3 `generateWith` 42
20+
let (selected, leftovers) = capUTxO utxo 0
21+
selected `shouldBe` mempty
22+
leftovers `shouldBe` utxo
23+
24+
it "returns empty UTxO when input UTxO is empty" $ do
25+
let (selected, leftovers) = capUTxO mempty 100
26+
selected `shouldBe` mempty
27+
leftovers `shouldBe` mempty
28+
29+
it "selects UTxO entries up to target amount" $ do
30+
let utxo = genUTxOSized 5 `generateWith` 42
31+
let totalValue = UTxO.totalValue utxo
32+
let target = toInteger (selectLovelace totalValue) `div` 2
33+
let (selected, leftovers) = capUTxO utxo (Coin target)
34+
35+
toInteger (selectLovelace (UTxO.totalValue selected)) `shouldSatisfy` \v -> v <= target
36+
37+
UTxO.totalValue selected <> UTxO.totalValue leftovers `shouldBe` totalValue
38+
39+
let originalSize = length (UTxO.toList utxo)
40+
selectedSize = length (UTxO.toList selected)
41+
leftoverSize = length (UTxO.toList leftovers)
42+
(selectedSize + leftoverSize) `shouldSatisfy` (>= originalSize)
43+
44+
selectedSize `shouldSatisfy` (> 0)
45+
leftoverSize `shouldSatisfy` (> 0)
46+
47+
let originalInputs = UTxO.inputSet utxo
48+
selectedInputs = UTxO.inputSet selected
49+
leftoverInputs = UTxO.inputSet leftovers
50+
allInputs = selectedInputs <> leftoverInputs
51+
originalInputs `shouldBe` allInputs
52+
53+
it "prioritizes smaller outputs" $ do
54+
let smallOutput = genUTxOSized 1 `generateWith` 42
55+
let largeOutput = genUTxOSized 3 `generateWith` 43
56+
let mixedUTxO = smallOutput <> largeOutput
57+
58+
let target = Coin $ toInteger (selectLovelace (UTxO.totalValue smallOutput)) + 1000
59+
let (selected, _) = capUTxO mixedUTxO target
60+
61+
length (UTxO.toList selected) `shouldSatisfy` (> 1)
62+
63+
describe "property tests" $ do
64+
prop "preserves total value" propPreservesTotalValue
65+
prop "selected value never exceeds target" propSelectedValueNeverExceedsTarget
66+
prop "greedy selection - takes smallest UTxOs first" propGreedySelection
67+
prop "exact target when possible" propExactTargetWhenPossible
68+
prop "idempotent" propIdempotent
69+
prop "monotonic with respect to target" propMonotonicTarget
70+
prop "no UTxO loss" propNoUTxOLoss
71+
72+
-- | Property: The sum of selected and leftover values equals the input value
73+
propPreservesTotalValue :: UTxO -> Coin -> Property
74+
propPreservesTotalValue utxo target =
75+
let (selected, leftovers) = capUTxO utxo target
76+
inputTotal = UTxO.totalValue utxo
77+
selectedTotal = UTxO.totalValue selected
78+
leftoverTotal = UTxO.totalValue leftovers
79+
inputLovelace = selectLovelace inputTotal
80+
selectedLovelace = selectLovelace selectedTotal
81+
leftoverLovelace = selectLovelace leftoverTotal
82+
in selectedLovelace + leftoverLovelace === inputLovelace
83+
& counterexample ("Input total: " <> show inputTotal)
84+
& counterexample ("Selected total: " <> show selectedTotal)
85+
& counterexample ("Leftover total: " <> show leftoverTotal)
86+
87+
-- | Property: Selected value never exceeds the target
88+
propSelectedValueNeverExceedsTarget :: UTxO -> Coin -> Property
89+
propSelectedValueNeverExceedsTarget utxo target =
90+
let (selected, _) = capUTxO utxo target
91+
selectedTotal = UTxO.totalValue selected
92+
in selectLovelace selectedTotal <= target
93+
& counterexample ("Selected total: " <> show selectedTotal)
94+
& counterexample ("Target: " <> show target)
95+
96+
-- | Property: Greedy selection - takes smallest UTxOs first
97+
propGreedySelection :: UTxO -> Coin -> Property
98+
propGreedySelection utxo target =
99+
let (selected, _) = capUTxO utxo target
100+
selectedList = UTxO.toList selected
101+
sortedByValue = sortBy (comparing (selectLovelace . txOutValue . snd)) (UTxO.toList utxo)
102+
in all
103+
( \selectedUTxO ->
104+
let selectedValue = selectLovelace (txOutValue (snd selectedUTxO))
105+
smallerUTxOs = takeWhile (\utx -> selectLovelace (txOutValue (snd utx)) < selectedValue) sortedByValue
106+
in all (`elem` selectedList) smallerUTxOs
107+
)
108+
selectedList
109+
& counterexample ("Selected count: " <> show (length selectedList))
110+
& counterexample ("Total UTxO count: " <> show (length sortedByValue))
111+
112+
-- | Property: Reaches target exactly when possible
113+
propExactTargetWhenPossible :: UTxO -> Coin -> Property
114+
propExactTargetWhenPossible utxo target =
115+
let (selected, _) = capUTxO utxo target
116+
selectedTotal = UTxO.totalValue selected
117+
inputTotal = UTxO.totalValue utxo
118+
in (selectLovelace inputTotal >= target) ==>
119+
( selectLovelace selectedTotal == target
120+
|| selectLovelace selectedTotal == target - 1
121+
)
122+
& counterexample ("Selected total: " <> show selectedTotal)
123+
& counterexample ("Target: " <> show target)
124+
& counterexample ("Input total: " <> show inputTotal)
125+
126+
-- | Property: Function is idempotent
127+
propIdempotent :: UTxO -> Coin -> Property
128+
propIdempotent utxo target =
129+
let firstResult = capUTxO utxo target
130+
secondResult = capUTxO (fst firstResult) target
131+
in fst firstResult === fst secondResult
132+
& counterexample ("First selected count: " <> show (length (UTxO.toList (fst firstResult))))
133+
& counterexample ("Second selected count: " <> show (length (UTxO.toList (fst secondResult))))
134+
135+
-- | Property: Monotonic with respect to target
136+
propMonotonicTarget :: UTxO -> Coin -> Coin -> Property
137+
propMonotonicTarget utxo target1 target2 =
138+
(target1 <= target2) ==>
139+
let (selected1, _) = capUTxO utxo target1
140+
(selected2, _) = capUTxO utxo target2
141+
total1 = UTxO.totalValue selected1
142+
total2 = UTxO.totalValue selected2
143+
in selectLovelace total1 <= selectLovelace total2
144+
& counterexample ("Target1: " <> show target1 <> ", Selected1: " <> show total1)
145+
& counterexample ("Target2: " <> show target2 <> ", Selected2: " <> show total2)
146+
147+
-- | Property: No UTxO loss - all input UTxOs appear in either selected or leftovers
148+
propNoUTxOLoss :: UTxO -> Coin -> Property
149+
propNoUTxOLoss utxo target =
150+
let (selected, leftovers) = capUTxO utxo target
151+
inputSet = UTxO.inputSet utxo
152+
selectedSet = UTxO.inputSet selected
153+
leftoverSet = UTxO.inputSet leftovers
154+
unionSet = selectedSet <> leftoverSet
155+
in inputSet === unionSet
156+
& counterexample ("Input set size: " <> show (Set.size inputSet))
157+
& counterexample ("Selected set size: " <> show (Set.size selectedSet))
158+
& counterexample ("Leftover set size: " <> show (Set.size leftoverSet))

0 commit comments

Comments
 (0)