Skip to content

Commit 3fa596d

Browse files
v0d1chv0d1ch
committed
Rename checkTokens to splitTokens
Signed-off-by: Sasha Bogicevic <[email protected]>
1 parent 607cdb4 commit 3fa596d

File tree

3 files changed

+163
-35
lines changed

3 files changed

+163
-35
lines changed

‎hydra-node/src/Hydra/Chain/Direct/Handlers.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -82,7 +82,7 @@ import Hydra.Tx (
8282
headSeedToTxIn,
8383
)
8484
import Hydra.Tx.ContestationPeriod (toNominalDiffTime)
85-
import Hydra.Tx.Deposit (DepositObservation (..), checkTokens, depositTx)
85+
import Hydra.Tx.Deposit (DepositObservation (..), splitTokens, depositTx)
8686
import Hydra.Tx.Observe (
8787
AbortObservation (..),
8888
CloseObservation (..),
@@ -194,7 +194,7 @@ mkChain tracer queryTimeHandle wallet ctx LocalChainState{getLatest} submitTx =
194194
liftEither $ do
195195
checkAmount lookupUTxO amount
196196
rejectLowDeposits pparams lookupUTxO amount
197-
let (validTokens, _invalidTokens) = checkTokens lookupUTxO (fromMaybe mempty tokens)
197+
let (validTokens, _invalidTokens) = splitTokens lookupUTxO (fromMaybe mempty tokens)
198198
(currentSlot, currentTime) <- case currentPointInTime of
199199
Left failureReason -> throwError FailedToConstructDepositTx{failureReason}
200200
Right (s, t) -> pure (s, t)

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

Lines changed: 73 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,7 @@ import Hydra.Contract.Commit qualified as Commit
1616
import Hydra.Contract.Deposit qualified as Deposit
1717
import Hydra.Plutus (depositValidatorScript)
1818
import Hydra.Plutus.Extras.Time (posixFromUTCTime, posixToUTCTime)
19-
import Hydra.Tx (CommitBlueprintTx (..), HeadId, currencySymbolToHeadId, headIdToCurrencySymbol, txId)
19+
import Hydra.Tx (CommitBlueprintTx (..), HeadId, currencySymbolToHeadId, headIdToCurrencySymbol, txId, withoutUTxO)
2020
import Hydra.Tx.Utils (addMetadata, mkHydraHeadV1TxName)
2121
import PlutusLedgerApi.V3 (POSIXTime)
2222

@@ -35,7 +35,7 @@ depositTx ::
3535
Maybe Coin ->
3636
Map PolicyId PolicyAssets ->
3737
Tx
38-
depositTx networkId headId commitBlueprintTx upperSlot deadline amount _tokens =
38+
depositTx networkId headId commitBlueprintTx upperSlot deadline amount tokens =
3939
fromLedgerTx $
4040
toLedgerTx blueprintTx
4141
& addDepositInputs
@@ -52,21 +52,78 @@ depositTx networkId headId commitBlueprintTx upperSlot deadline amount _tokens =
5252

5353
CommitBlueprintTx{lookupUTxO = depositUTxO, blueprintTx} = commitBlueprintTx
5454

55-
(utxoToDeposit, leftoverUTxO) = maybe (depositUTxO, mempty) (capUTxO depositUTxO) amount
55+
(utxoToDeposit', leftoverUTxO') = maybe (depositUTxO, mempty) (capUTxO depositUTxO) amount
5656

57+
utxoToDeposit = utxoToDeposit' <> tokensToDepositUTxO
58+
59+
tokensToDepositUTxO = undefined -- pickTokensToDeposit leftoverUTxO' tokens
5760
leftoverOutput =
58-
if UTxO.null leftoverUTxO
59-
then StrictSeq.empty
60-
else
61-
let leftoverAddress = List.head $ txOutAddress <$> UTxO.txOutputs leftoverUTxO
62-
in StrictSeq.singleton $
63-
toLedgerTxOut $
64-
TxOut leftoverAddress (UTxO.totalValue leftoverUTxO) TxOutDatumNone ReferenceScriptNone
61+
let leftoverUTxO = (leftoverUTxO' `withoutUTxO` tokensToDepositUTxO)
62+
in if UTxO.null leftoverUTxO
63+
then StrictSeq.empty
64+
else
65+
let leftoverAddress = List.head $ txOutAddress <$> UTxO.txOutputs leftoverUTxO
66+
in StrictSeq.singleton $
67+
toLedgerTxOut $
68+
TxOut leftoverAddress (UTxO.totalValue leftoverUTxO) TxOutDatumNone ReferenceScriptNone
6569

6670
depositInputsList = toList (UTxO.inputSet utxoToDeposit)
6771

6872
depositInputs = (,BuildTxWith $ KeyWitness KeyWitnessForSpending) <$> depositInputsList
6973

74+
pickTokensToDeposit :: UTxO -> Map PolicyId PolicyAssets -> UTxO
75+
pickTokensToDeposit leftoverUTxO depositTokens =
76+
if null depositTokens
77+
then mempty
78+
else
79+
let x = concatMap (go mempty) (UTxO.toList leftoverUTxO)
80+
in combineTxOutAssets x
81+
where
82+
go :: [(TxIn, TxOut CtxUTxO)] -> (TxIn, TxOut CtxUTxO) -> [(TxIn, TxOut CtxUTxO)]
83+
go defVal (i, o) = do
84+
let outputAssets = valueToPolicyAssets $ txOutValue o
85+
providedUTxOAssets = concatMap (\(pid, PolicyAssets a) -> (\(x, y) -> (pid, x, y)) <$> toList a) (Map.toList outputAssets)
86+
(k, PolicyAssets v) <- Map.assocs depositTokens
87+
88+
if k `elem` Map.keys outputAssets
89+
then do
90+
(wantedAssetName, wantedAssetVal) <- Map.toList v
91+
case find (\(pid, n, val) -> pid == k && wantedAssetName == n && wantedAssetVal <= val) providedUTxOAssets of
92+
Nothing -> defVal
93+
Just (pid', _an, _av) -> do
94+
let newValue = fromList [(AssetId pid' wantedAssetName, wantedAssetVal)]
95+
defVal <> [(i, mkTxOutValueKeepingLovelace o newValue)]
96+
else defVal
97+
98+
combineTxOutAssets :: [(TxIn, TxOut CtxUTxO)] -> UTxO.UTxO
99+
combineTxOutAssets =
100+
foldl'
101+
( \finalUTxO (i, o) ->
102+
case UTxO.findBy (existingTxId i) finalUTxO of
103+
Nothing -> finalUTxO <> UTxO.singleton i o
104+
Just (existingInput, existingOutput) ->
105+
let val = valueToPolicyAssets $ txOutValue o
106+
in UTxO.singleton existingInput (addTxOutValue existingOutput val)
107+
)
108+
mempty
109+
110+
existingTxId :: TxIn -> (TxIn, TxOut CtxUTxO) -> Bool
111+
existingTxId txIn (a, _) = a == txIn
112+
113+
mkTxOutValueKeepingLovelace :: TxOut ctx -> Value -> TxOut ctx
114+
mkTxOutValueKeepingLovelace (TxOut addr val datum refScript) newValue =
115+
TxOut addr (lovelaceToValue (selectLovelace val) <> newValue) datum refScript
116+
117+
addTxOutValue :: TxOut ctx -> Map PolicyId PolicyAssets -> TxOut ctx
118+
addTxOutValue (TxOut addr val datum refScript) newAssets =
119+
TxOut addr (lovelaceToValue (selectLovelace val) <> assetsToVal (valueToPolicyAssets val) <> assetsToVal newAssets) datum refScript
120+
where
121+
assetsToVal :: Map PolicyId PolicyAssets -> Value
122+
assetsToVal m = foldMap (uncurry policyAssetsToValue) $ toList m
123+
124+
bumpIndex :: TxIn -> TxIn
125+
bumpIndex (TxIn i (TxIx n)) = TxIn i (TxIx $ n + 1)
126+
70127
mkDepositOutput ::
71128
NetworkId ->
72129
HeadId ->
@@ -91,8 +148,8 @@ mkDepositOutput networkId headId depositUTxO deadline =
91148
depositAddress :: NetworkId -> AddressInEra
92149
depositAddress networkId = mkScriptAddress networkId depositValidatorScript
93150

94-
checkTokens :: UTxO.UTxO -> Map PolicyId PolicyAssets -> (Map PolicyId PolicyAssets, Map PolicyId PolicyAssets)
95-
checkTokens userUTxO specifiedTokens
151+
splitTokens :: UTxO.UTxO -> Map PolicyId PolicyAssets -> (Map PolicyId PolicyAssets, Map PolicyId PolicyAssets)
152+
splitTokens userUTxO specifiedTokens
96153
| Map.null specifiedTokens = (mempty, mempty) -- Trivial case: no tokens specified
97154
| otherwise =
98155
let utxoValue = UTxO.totalValue userUTxO
@@ -172,17 +229,17 @@ capUTxO utxo target
172229
-- Split the output to meet the target exactly.
173230
let cappedValue = target - currentSum
174231
leftoverVal = x - cappedValue
175-
cappedTxOut = updateTxOutValue txOut cappedValue
176-
leftoverTxOut = updateTxOutValue txOut leftoverVal
232+
cappedTxOut = updateTxOutAdaValue txOut cappedValue
233+
leftoverTxOut = updateTxOutAdaValue txOut leftoverVal
177234
in go
178235
(foundSoFar <> UTxO.singleton txIn cappedTxOut)
179236
(UTxO.difference leftovers (UTxO.singleton txIn txOut) <> UTxO.singleton txIn leftoverTxOut)
180237
target
181238
rest
182239

183240
-- | Helper to create a new TxOut with a specified lovelace value
184-
updateTxOutValue :: TxOut ctx -> Coin -> TxOut ctx
185-
updateTxOutValue (TxOut addr _ datum refScript) newValue =
241+
updateTxOutAdaValue :: TxOut ctx -> Coin -> TxOut ctx
242+
updateTxOutAdaValue (TxOut addr _ datum refScript) newValue =
186243
TxOut addr (fromLedgerValue $ mkAdaValue ShelleyBasedEraConway newValue) datum refScript
187244

188245
-- * Observation

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

Lines changed: 88 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -7,53 +7,124 @@ import Cardano.Api.UTxO qualified as UTxO
77
import Data.Map.Strict qualified as Map
88
import Data.Set qualified as Set
99
import Hydra.Cardano.Api (AssetId (..), AssetName, Coin (..), PolicyAssets (..), PolicyId, Quantity (..), UTxO, selectLovelace, txOutValue, valueToPolicyAssets)
10-
import Hydra.Tx.Deposit (capUTxO, checkTokens)
10+
import Hydra.Tx.Deposit (capUTxO, pickTokensToDeposit, splitTokens)
1111
import Test.Hydra.Tx.Fixture (testPolicyId)
1212
import Test.Hydra.Tx.Gen (genUTxOSized)
1313
import Test.QuickCheck (Property, chooseInteger, counterexample, (===), (==>))
1414

1515
spec :: Spec
1616
spec =
1717
parallel $ do
18-
describe "checkTokens" $ do
18+
describe "pickTokensToDeposit" $ do
1919
describe "tests" $ do
2020
it "returns empty results when no tokens are specified" $ do
2121
let utxo = genUTxOSized 3 `generateWith` 42
22-
let (valid, invalid) = checkTokens utxo mempty
22+
let toDeposit = pickTokensToDeposit utxo mempty
23+
toDeposit `shouldBe` mempty
24+
it "returns empty results when UTxO is empty" $ do
25+
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 10)])]
26+
let toDeposit = pickTokensToDeposit mempty tokens
27+
toDeposit `shouldBe` mempty
28+
it "returns all tokens as invalid when policy is missing from UTxO" $ do
29+
let utxo = genUTxOSized 3 `generateWith` 42 -- UTxO with only ADA
30+
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 10)])]
31+
let toDeposit = pickTokensToDeposit utxo tokens
32+
toDeposit `shouldBe` mempty
33+
it "validates tokens correctly when exact quantities match" $ do
34+
let testUTxO = utxoWithTokens [(testPolicyId, testAssetName, Quantity 100)]
35+
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)])]
36+
let toDeposit = pickTokensToDeposit testUTxO tokens
37+
toDeposit `shouldBe` testUTxO
38+
it "validates tokens correctly when UTxO has more than required" $ do
39+
let testUTxO = utxoWithTokens [(testPolicyId, testAssetName, Quantity 150)]
40+
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)])]
41+
let toDeposit = pickTokensToDeposit testUTxO tokens
42+
toDeposit `shouldBe` utxoWithTokens [(testPolicyId, testAssetName, Quantity 100)]
43+
it "returns tokens intact when UTxO has less than required" $ do
44+
let testUTxO = utxoWithTokens [(testPolicyId, testAssetName, Quantity 50)]
45+
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)])]
46+
let toDeposit = pickTokensToDeposit testUTxO tokens
47+
toDeposit `shouldBe` mempty
48+
it "handles mixed scenarios with multiple tokens" $ do
49+
let testUTxO =
50+
utxoWithTokens
51+
[ (testPolicyId, testAssetName, Quantity 100)
52+
, (testPolicyId2, testAssetName, Quantity 50)
53+
]
54+
let tokens =
55+
Map.fromList
56+
[ (testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)]) -- Valid
57+
, (testPolicyId2, PolicyAssets $ Map.fromList [(testAssetName, Quantity 75)]) -- Invalid - insufficient
58+
, (testPolicyId3, PolicyAssets $ Map.fromList [(testAssetName, Quantity 25)]) -- Invalid - missing policy
59+
]
60+
let toDeposit = pickTokensToDeposit testUTxO tokens
61+
62+
toDeposit `shouldBe` utxoWithTokens [(testPolicyId, testAssetName, Quantity 100)]
63+
64+
fit "handles multiple assets within the same policy" $ do
65+
let testUTxO =
66+
utxoWithTokens
67+
[ (testPolicyId, testAssetName, Quantity 100)
68+
, (testPolicyId, testAssetName2, Quantity 200)
69+
]
70+
let tokens =
71+
Map.fromList
72+
[
73+
( testPolicyId
74+
, PolicyAssets $
75+
Map.fromList
76+
[ (testAssetName, Quantity 50) -- Valid
77+
, (testAssetName2, Quantity 150) -- Valid
78+
, (testAssetName3, Quantity 10) -- Invalid - missing asset
79+
]
80+
)
81+
]
82+
let toDeposit = pickTokensToDeposit testUTxO tokens
83+
let additionalUTxO =
84+
utxoWithTokens
85+
[ (testPolicyId, testAssetName, 50)
86+
, (testPolicyId, testAssetName2, 150)
87+
]
88+
toDeposit `shouldBe` additionalUTxO
89+
describe "splitTokens" $ do
90+
describe "tests" $ do
91+
it "returns empty results when no tokens are specified" $ do
92+
let utxo = genUTxOSized 3 `generateWith` 42
93+
let (valid, invalid) = splitTokens utxo mempty
2394
valid `shouldBe` mempty
2495
invalid `shouldBe` mempty
2596

2697
it "returns empty results when UTxO is empty" $ do
2798
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 10)])]
28-
let (valid, invalid) = checkTokens mempty tokens
99+
let (valid, invalid) = splitTokens mempty tokens
29100
valid `shouldBe` mempty
30101
invalid `shouldBe` tokens
31102

32103
it "returns all tokens as invalid when policy is missing from UTxO" $ do
33104
let utxo = genUTxOSized 3 `generateWith` 42 -- UTxO with only ADA
34105
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 10)])]
35-
let (valid, invalid) = checkTokens utxo tokens
106+
let (valid, invalid) = splitTokens utxo tokens
36107
valid `shouldBe` mempty
37108
invalid `shouldBe` tokens
38109

39110
it "validates tokens correctly when exact quantities match" $ do
40111
let testUTxO = utxoWithTokens [(testPolicyId, testAssetName, Quantity 100)]
41112
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)])]
42-
let (valid, invalid) = checkTokens testUTxO tokens
113+
let (valid, invalid) = splitTokens testUTxO tokens
43114
valid `shouldBe` tokens
44115
invalid `shouldBe` mempty
45116

46117
it "validates tokens correctly when UTxO has more than required" $ do
47118
let testUTxO = utxoWithTokens [(testPolicyId, testAssetName, Quantity 150)]
48119
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)])]
49-
let (valid, invalid) = checkTokens testUTxO tokens
120+
let (valid, invalid) = splitTokens testUTxO tokens
50121
valid `shouldBe` tokens
51122
invalid `shouldBe` mempty
52123

53124
it "returns tokens as invalid when UTxO has less than required" $ do
54125
let testUTxO = utxoWithTokens [(testPolicyId, testAssetName, Quantity 50)]
55126
let tokens = Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)])]
56-
let (valid, invalid) = checkTokens testUTxO tokens
127+
let (valid, invalid) = splitTokens testUTxO tokens
57128
valid `shouldBe` mempty
58129
invalid `shouldBe` tokens
59130

@@ -69,7 +140,7 @@ spec =
69140
, (testPolicyId2, PolicyAssets $ Map.fromList [(testAssetName, Quantity 75)]) -- Invalid - insufficient
70141
, (testPolicyId3, PolicyAssets $ Map.fromList [(testAssetName, Quantity 25)]) -- Invalid - missing policy
71142
]
72-
let (valid, invalid) = checkTokens testUTxO tokens
143+
let (valid, invalid) = splitTokens testUTxO tokens
73144

74145
valid `shouldBe` Map.fromList [(testPolicyId, PolicyAssets $ Map.fromList [(testAssetName, Quantity 100)])]
75146
invalid
@@ -96,7 +167,7 @@ spec =
96167
]
97168
)
98169
]
99-
let (valid, invalid) = checkTokens testUTxO tokens
170+
let (valid, invalid) = splitTokens testUTxO tokens
100171
valid `shouldBe` mempty -- All assets in policy must be valid for policy to be valid
101172
invalid `shouldBe` tokens
102173

@@ -248,7 +319,7 @@ propNoUTxOLoss utxo target =
248319
& counterexample ("Selected set size: " <> show (Set.size selectedSet))
249320
& counterexample ("Leftover set size: " <> show (Set.size leftoverSet))
250321

251-
-- * Helper functions for checkTokens tests
322+
-- * Helper functions for splitTokens tests
252323

253324
-- | Create additional test PolicyIds for testing (using the existing testPolicyId from fixtures)
254325
testPolicyId2 :: PolicyId
@@ -279,12 +350,12 @@ utxoWithTokens tokens =
279350
txOut = baseTxOut{txOutValue = valueWithAda}
280351
in UTxO.singleton txIn txOut
281352

282-
-- * Property tests for checkTokens
353+
-- * Property tests for splitTokens
283354

284355
-- | Property: All input tokens are preserved in either valid or invalid results
285356
propPreservesAllTokens :: UTxO -> Map PolicyId PolicyAssets -> Property
286357
propPreservesAllTokens utxo specifiedTokens =
287-
let (valid, invalid) = checkTokens utxo specifiedTokens
358+
let (valid, invalid) = splitTokens utxo specifiedTokens
288359
inputPolicies = Map.keysSet specifiedTokens
289360
validPolicies = Map.keysSet valid
290361
invalidPolicies = Map.keysSet invalid
@@ -297,7 +368,7 @@ propPreservesAllTokens utxo specifiedTokens =
297368
-- | Property: Valid and invalid results are disjoint sets
298369
propValidInvalidDisjoint :: UTxO -> Map PolicyId PolicyAssets -> Property
299370
propValidInvalidDisjoint utxo specifiedTokens =
300-
let (valid, invalid) = checkTokens utxo specifiedTokens
371+
let (valid, invalid) = splitTokens utxo specifiedTokens
301372
validPolicies = Map.keysSet valid
302373
invalidPolicies = Map.keysSet invalid
303374
intersection = Set.intersection validPolicies invalidPolicies
@@ -309,7 +380,7 @@ propValidInvalidDisjoint utxo specifiedTokens =
309380
-- | Property: All valid tokens must exist in UTxO with sufficient quantities
310381
propValidTokensExistInUTxO :: UTxO -> Map PolicyId PolicyAssets -> Property
311382
propValidTokensExistInUTxO utxo specifiedTokens =
312-
let (valid, _) = checkTokens utxo specifiedTokens
383+
let (valid, _) = splitTokens utxo specifiedTokens
313384
utxoValue = UTxO.totalValue utxo
314385
utxoPolicyAssets = valueToPolicyAssets utxoValue
315386
in all (checkValidTokenInUTxO utxoPolicyAssets) (Map.toList valid)
@@ -333,8 +404,8 @@ propValidTokensExistInUTxO utxo specifiedTokens =
333404
propMonotonicUTxOAdditions :: UTxO -> UTxO -> Map PolicyId PolicyAssets -> Property
334405
propMonotonicUTxOAdditions utxo1 utxo2 specifiedTokens =
335406
let combinedUTxO = utxo1 <> utxo2
336-
(valid1, _) = checkTokens utxo1 specifiedTokens
337-
(validCombined, _) = checkTokens combinedUTxO specifiedTokens
407+
(valid1, _) = splitTokens utxo1 specifiedTokens
408+
(validCombined, _) = splitTokens combinedUTxO specifiedTokens
338409
valid1Policies = Map.keysSet valid1
339410
validCombinedPolicies = Map.keysSet validCombined
340411
in valid1Policies `Set.isSubsetOf` validCombinedPolicies

0 commit comments

Comments
 (0)