From 05759d2e35e76b56e1fb50a017fbaddd2422d37f Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 11:33:13 +0200 Subject: [PATCH 1/9] Pin deadline-free transfer withdraw with a test and document pending-instruction recovery --- packages/token/tokenCIP112-v1/README.md | 8 ++++++++ .../daml/OpenZeppelin/TokenCIP112V1Test.daml | 19 +++++++++++++++++++ 2 files changed, 27 insertions(+) diff --git a/packages/token/tokenCIP112-v1/README.md b/packages/token/tokenCIP112-v1/README.md index c703569..a63531c 100644 --- a/packages/token/tokenCIP112-v1/README.md +++ b/packages/token/tokenCIP112-v1/README.md @@ -55,6 +55,14 @@ Daml interfaces or exceptions of its own. - The instrument admin and the account parties jointly maintain holdings. - Wallets act through the TSv2 interface choices; the choice bodies validate identity, funding, and expiry before they move value. +- A two-step transfer locks the transfer amount in a sender holding whose + lock holders are the admin and the receiver's account parties, so the + receiver's parties see that holding while the offer is pending. Accept + fails after `executeBefore`. Reject and withdraw have no deadline. Until + the lock expires at `executeBefore` plus `lockGrace`, withdraw is the only + recovery the sender's parties can perform alone. After `executeBefore`, the + admin alone may also return the funds to the sender through + `TokenTransferInstruction_Expire`. - An allocation created with `nextIterationFunding` set enables iterated settlement: the executors supply extra transfer legs per settlement iteration, bounded by the locked reserve plus incoming credits, and may diff --git a/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml b/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml index 9c2527e..289431c 100644 --- a/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml +++ b/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml @@ -440,6 +440,25 @@ testTransferRejectAndWithdraw = do aliceAfter <- holdingAmounts alice sum aliceAfter === 10.0 +-- | Withdraw has no deadline. After `executeBefore`, while the lock is still +-- live, the sender's parties recover the funds alone; accept already fails +-- here (`testTransferGuards`). +testTransferWithdrawAfterDeadline : Script () +testTransferWithdrawAfterDeadline = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + result <- instructTransfer s [alice] (mkTransfer s alice bob 7.0 [aliceInput]) + instrCid <- pendingCid result + -- Past executeBefore (t2), before the lock expires at t2 plus lockGrace. + setTime t3 + _ <- submit (actAs alice) do + exerciseCmd instrCid TransferInstructionV2.TransferInstruction_Withdraw with + actors = [alice] + extraArgs = emptyExtraArgs + assertNoLocks alice + aliceAfter <- holdingAmounts alice + sum aliceAfter === 10.0 + -- | Guards: underfunded transfers and expired execution windows fail closed. testTransferGuards : Script () testTransferGuards = do From a3625c6ea5a79c09611caf8a056c742b853d004f Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 12:11:45 +0200 Subject: [PATCH 2/9] add missing custom-token tests to cover all choices --- .../daml/MyApp/TokenTest.daml | 76 ++++++++++++++++++- 1 file changed, 72 insertions(+), 4 deletions(-) diff --git a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml index dcee50e..593b4a5 100644 --- a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml +++ b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml @@ -3,15 +3,16 @@ -- runs `MyHolding_Spend`, a late acceptance creates a `MyHolding`, iteration -- successors are `MyAllocation`s, a frozen holding cannot move on any path, -- the pause switch blocks the factories, the fee leg pays the treasury, the --- executor allowlist is enforced, roles are separate, and a foreign holding --- is refused. +-- executor allowlist is enforced, roles are separate, expired funding is +-- reclaimed, and a foreign holding is refused. module MyApp.TokenTest where import DA.Action (unless) import DA.Assert ((===)) import DA.Date (date, Month(Jan)) +import DA.Foldable (forA_) import DA.List (sort) -import DA.Optional (isSome, optionalToList) +import DA.Optional (isNone, isSome, optionalToList) import DA.Text (isInfixOf) import DA.TextMap qualified as TextMap import DA.Time (days, hours, time) @@ -28,10 +29,12 @@ import Splice.TokenStandard.Utils (basicAccount, senderSide, receiverSide, nonIt import OpenZeppelin.TokenCIP112WorkflowsV1.Holding (RegistryConfig(..)) import MyApp.Token -t0, t1, t2 : Time +t0, t1, t2, t3, t4 : Time t0 = time (date 2026 Jan 1) 0 0 0 t1 = time (date 2026 Jan 1) 0 10 0 t2 = time (date 2026 Jan 1) 0 20 0 +t3 = time (date 2026 Jan 1) 0 30 0 +t4 = time (date 2026 Jan 1) 2 0 0 emptyExtraArgs : ExtraArgs emptyExtraArgs = ExtraArgs with context = emptyChoiceContext; meta = emptyMetadata @@ -478,6 +481,71 @@ testExecutorAllowlist = do _ <- allocate app alice (mkSpec app alice [senderSide leg] None) [aliceTok] pure () +-- Expiry and cleanup +--------------------- + +-- | Alice's pending transfer of 7 to bob and her allocation of 5. Both expire +-- at t2, and both funding locks expire one lock grace later. +lockAliceFunds : App -> Script (ContractId TransferInstructionV2.TransferInstruction, ContractId AllocationV2.Allocation) +lockAliceFunds app@App{..} = do + transferInput <- mint app alice 10.0 + allocationInput <- mint app alice 5.0 + result <- submit (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd app [alice] (mkTransfer app alice bob 7.0 [transferInput])) + instrCid <- pendingCid result + allocCid <- allocate app alice (mkSpec app alice [senderSide (mkLeg "leg-1" alice bob 5.0)] None) [allocationInput] + pure (instrCid, allocCid) + +-- | All of `owner`'s holdings are unlocked. +assertNoLocks : Party -> Script () +assertNoLocks owner = do + holdings <- query @MyHolding owner + all (\(_, h) -> isNone h.holding.lock) holdings === True + +-- | Past t2 the admin expires the instruction and the allocation in batches +-- through the rules contract, and the locked funds return to alice. +testAdminExpiryReturnsFunds : Script () +testAdminExpiryReturnsFunds = do + app@App{..} <- setup + (instrCid, allocCid) <- lockAliceFunds app + setTime t3 + submit (actAs admin) do + exerciseCmd rulesCid MyRules_ExpireTransferInstructions with + instructionCids = [fromInterfaceContractId @MyTransferInstruction instrCid] + submit (actAs admin) do + exerciseCmd rulesCid MyRules_ExpireAllocations with + cancelArgs = [(allocCid, AllocationV2.Allocation_Cancel with actors = [admin]; extraArgs = emptyExtraArgs)] + balanceSeenBy alice alice >>= (=== [3.0, 5.0, 7.0]) + assertNoLocks alice + +-- | Once the funding locks expire, alice unlocks her own holdings and the +-- admin removes the instruction and allocation that still reference them. +testOwnerUnlockThenAdminGC : Script () +testOwnerUnlockThenAdminGC = do + app@App{..} <- setup + (instrCid, allocCid) <- lockAliceFunds app + setTime t4 + holdings <- query @MyHolding alice + forA_ [cid | (cid, h) <- holdings, isSome h.holding.lock] $ \cid -> + submit (actAs alice) do exerciseCmd cid MyHolding_OwnerUnlock + balanceSeenBy alice alice >>= (=== [3.0, 5.0, 7.0]) + assertNoLocks alice + let instrTemplateCid = fromInterfaceContractId @MyTransferInstruction instrCid + allocTemplateCid = fromInterfaceContractId @MyAllocation allocCid + submit (actAs admin) do exerciseCmd instrTemplateCid MyTransferInstruction_AdminGC + submit (actAs admin) do exerciseCmd allocTemplateCid MyAllocation_AdminGC + queryContractId admin instrTemplateCid >>= (=== None) + queryContractId admin allocTemplateCid >>= (=== None) + +-- | The signatories can archive a holding and the rules contract directly. +testSignatoriesArchive : Script () +testSignatoriesArchive = do + app@App{..} <- setup + aliceTok <- mint app alice 10.0 + submit (actAs [admin, alice]) do archiveCmd (fromInterfaceContractId @MyHolding aliceTok) + submit (actAs admin) do archiveCmd rulesCid + balanceSeenBy alice alice >>= (=== []) + -- Trust boundary ----------------- From 241604bdb30fd5016607afd5cc7a80f7b2b70cc0 Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 12:18:27 +0200 Subject: [PATCH 3/9] Cover expiry, GC, unlock and archive choices in custom-token tests and pin the frozen unlock refusal --- .../daml/MyApp/TokenTest.daml | 25 ++++++++++++++++--- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml index 593b4a5..878980c 100644 --- a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml +++ b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml @@ -353,9 +353,9 @@ testAuditorObservesEvents = do -------------------- -- | Only the compliance officer can freeze. A frozen holding is refused on --- every consumption path, transfer, allocation, and burn, and on owner --- unlock, while the standard view still shows it as an ordinary holding. --- After unfreezing, the same transfer goes through. +-- every consumption path, transfer, allocation, and burn, while the standard +-- view still shows it as an ordinary holding. After unfreezing, the same +-- transfer goes through. testFrozenHoldingCannotMove : Script () testFrozenHoldingCannotMove = do app@App{..} <- setup @@ -377,7 +377,6 @@ testFrozenHoldingCannotMove = do holdingCid = frozenIface account = basicAccount alice reason = "redeem" - submitMustFail (actAs alice) do exerciseCmd frozenCid MyHolding_OwnerUnlock -- Wallets reading the standard interface see nothing unusual. Some v <- queryInterfaceContractId @HoldingV2.Holding alice frozenIface @@ -390,6 +389,24 @@ testFrozenHoldingCannotMove = do balanceSeenBy bob bob >>= (=== [7.0]) balanceSeenBy alice alice >>= (=== [3.0]) +-- | Owner unlock recreates the holding through `createHolding`, which would +-- drop the freeze, so a frozen holding whose lock has expired is refused. +-- Once unfrozen, the same unlock goes through. +testFrozenHoldingCannotUnlock : Script () +testFrozenHoldingCannotUnlock = do + app@App{..} <- setup + aliceTok <- mint app alice 10.0 + _ <- submit (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd app [alice] (mkTransfer app alice bob 7.0 [aliceTok])) + [(lockedCid, _)] <- queryFilter @MyHolding alice (\h -> isSome h.holding.lock) + -- t4 is past the lock's expiry: t2 plus the one-hour lock grace. + setTime t4 + frozenCid <- submit (actAs complianceOfficer) do exerciseCmd lockedCid MyHolding_Freeze + mustFailWith "holding is frozen" (actAs alice) do exerciseCmd frozenCid MyHolding_OwnerUnlock + thawedCid <- submit (actAs complianceOfficer) do exerciseCmd frozenCid MyHolding_Unfreeze + _ <- submit (actAs alice) do exerciseCmd thawedCid MyHolding_OwnerUnlock + assertNoLocks alice + -- Pause switch --------------- From 4358fc9c83b109e1bd5b91cb5a570d8eb14b9506 Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 12:20:07 +0200 Subject: [PATCH 4/9] add one step note in CIP112 readme --- packages/token/tokenCIP112-v1/README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/packages/token/tokenCIP112-v1/README.md b/packages/token/tokenCIP112-v1/README.md index a63531c..3d9ff96 100644 --- a/packages/token/tokenCIP112-v1/README.md +++ b/packages/token/tokenCIP112-v1/README.md @@ -55,6 +55,9 @@ Daml interfaces or exceptions of its own. - The instrument admin and the account parties jointly maintain holdings. - Wallets act through the TSv2 interface choices; the choice bodies validate identity, funding, and expiry before they move value. +- A transfer completes in one step when the receiver's account parties + authorize the same transaction. Otherwise the receiver accepts a pending + instruction. - A two-step transfer locks the transfer amount in a sender holding whose lock holders are the admin and the receiver's account parties, so the receiver's parties see that holding while the offer is pending. Accept From 97bf8dec2002f7b80904ac62980674977ef15220 Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 12:35:17 +0200 Subject: [PATCH 5/9] test: add testFrozenHoldingCannotBeFrozenAgain --- .../custom-token-test/daml/MyApp/TokenTest.daml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml index 878980c..896a678 100644 --- a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml +++ b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml @@ -389,6 +389,16 @@ testFrozenHoldingCannotMove = do balanceSeenBy bob bob >>= (=== [7.0]) balanceSeenBy alice alice >>= (=== [3.0]) +-- | A frozen holding cannot be frozen again. +testFrozenHoldingCannotBeFrozenAgain : Script () +testFrozenHoldingCannotBeFrozenAgain = do + app@App{..} <- setup + aliceTok <- mint app alice 10.0 + frozenCid <- submit (actAs complianceOfficer) do + exerciseCmd (fromInterfaceContractId @MyHolding aliceTok) MyHolding_Freeze + mustFailWith "holding is already frozen" (actAs complianceOfficer) do + exerciseCmd frozenCid MyHolding_Freeze + -- | Owner unlock recreates the holding through `createHolding`, which would -- drop the freeze, so a frozen holding whose lock has expired is refused. -- Once unfrozen, the same unlock goes through. From c132dc2e23f90f3fda5a4ebbc4c54761ff745cc2 Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 12:36:54 +0200 Subject: [PATCH 6/9] test: add testUnfrozenHoldingCannotBeUnfrozen --- .../custom-token-test/daml/MyApp/TokenTest.daml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml index 896a678..76adca6 100644 --- a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml +++ b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml @@ -399,6 +399,14 @@ testFrozenHoldingCannotBeFrozenAgain = do mustFailWith "holding is already frozen" (actAs complianceOfficer) do exerciseCmd frozenCid MyHolding_Freeze +-- | A holding that is not frozen cannot be unfrozen. +testUnfrozenHoldingCannotBeUnfrozen : Script () +testUnfrozenHoldingCannotBeUnfrozen = do + app@App{..} <- setup + aliceTok <- mint app alice 10.0 + mustFailWith "holding is not frozen" (actAs complianceOfficer) do + exerciseCmd (fromInterfaceContractId @MyHolding aliceTok) MyHolding_Unfreeze + -- | Owner unlock recreates the holding through `createHolding`, which would -- drop the freeze, so a frozen holding whose lock has expired is refused. -- Once unfrozen, the same unlock goes through. From 606e2c1710119a33d0c997a2e8df11c91e023d95 Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 13:35:40 +0200 Subject: [PATCH 7/9] add EOF newline --- .gitignore | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 256907b..4d6da86 100644 --- a/.gitignore +++ b/.gitignore @@ -35,4 +35,4 @@ artifacts/ post-core/ # Extension ideas for CIP112 -packages/token/tokenCIP112-v1/ideas.md \ No newline at end of file +packages/token/tokenCIP112-v1/ideas.md From d94775729125adce77fec667db3b78af1f6a87fa Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 13:54:41 +0200 Subject: [PATCH 8/9] Add tests for every untested CIP112 guard and assert guard-specific failure messages --- .../daml/MyApp/TokenTest.daml | 160 ++++++- .../OpenZeppelin/TokenCIP112V1GuardTest.daml | 399 ++++++++++++++++++ .../daml/OpenZeppelin/TokenCIP112V1Test.daml | 7 +- .../TokenCIP112WorkflowsV1Test.daml | 249 ++++++++++- 4 files changed, 782 insertions(+), 33 deletions(-) create mode 100644 test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1GuardTest.daml diff --git a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml index 76adca6..869d903 100644 --- a/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml +++ b/examples/tokenCIP112/custom-token-test/daml/MyApp/TokenTest.daml @@ -4,7 +4,7 @@ -- successors are `MyAllocation`s, a frozen holding cannot move on any path, -- the pause switch blocks the factories, the fee leg pays the treasury, the -- executor allowlist is enforced, roles are separate, expired funding is --- reclaimed, and a foreign holding is refused. +-- reclaimed, and a foreign holding or allocation is refused. module MyApp.TokenTest where import DA.Action (unless) @@ -12,6 +12,7 @@ import DA.Assert ((===)) import DA.Date (date, Month(Jan)) import DA.Foldable (forA_) import DA.List (sort) +import DA.Map qualified as Map import DA.Optional (isNone, isSome, optionalToList) import DA.Text (isInfixOf) import DA.TextMap qualified as TextMap @@ -180,16 +181,19 @@ allocate app trader spec inputs = do AllocationInstructionV2.AllocationInstructionResult_Completed cid -> pure cid other -> abort ("expected completed allocation, got: " <> show other) +settleBatchCmd : App -> [AllocationV2.TransferLeg] -> [AllocationV2.FinalizedAllocation] -> Commands AllocationV2.SettlementFactory_SettleBatchResult +settleBatchCmd App{..} legs finalizedAllocs = + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = legs + allocations = finalizedAllocs + actors = [exchange] + extraArgs = emptyExtraArgs + settleBatch : App -> [AllocationV2.TransferLeg] -> [AllocationV2.FinalizedAllocation] -> Script AllocationV2.SettlementFactory_SettleBatchResult -settleBatch App{..} legs finalizedAllocs = - submit (actAs exchange <> discloseMany [rulesDisclosure]) do - exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) - AllocationV2.SettlementFactory_SettleBatch with - settlement - transferLegs = legs - allocations = finalizedAllocs - actors = [exchange] - extraArgs = emptyExtraArgs +settleBatch app legs finalizedAllocs = + submit (actAs app.exchange <> discloseMany [app.rulesDisclosure]) (settleBatchCmd app legs finalizedAllocs) -- | `MyHolding_Spend` exercises anywhere in a transaction tree. countSpends : TransactionTree -> Int @@ -462,6 +466,34 @@ testPauseBlocksFactories = do (transferCmd app2 [alice, bob] (mkTransfer app2 alice bob 7.0 [aliceTok])) balanceSeenBy bob bob >>= (=== [7.0]) +-- | The settlement factory is paused too, so allocations made before the +-- pause cannot settle until the registry is unpaused. +testPauseBlocksSettlement : Script () +testPauseBlocksSettlement = do + app0@App{..} <- setup + aliceTok <- mint app0 alice 10.0 + let leg = mkLeg "leg-1" alice bob 10.0 + aliceAlloc <- allocate app0 alice (mkSpec app0 alice [senderSide leg] None) [aliceTok] + bobAlloc <- allocate app0 bob (mkSpec app0 bob [receiverSide leg] None) [] + app <- pauseRegistry app0 + mustFailWith "registry is paused" (actAs exchange <> discloseMany [app.rulesDisclosure]) + (settleBatchCmd app [leg] (map nonIteratedAllocation [aliceAlloc, bobAlloc])) + +-- | A paused registry cannot be paused again. +testPausedRegistryCannotBePausedAgain : Script () +testPausedRegistryCannotBePausedAgain = do + app0 <- setup + app <- pauseRegistry app0 + mustFailWith "registry is already paused" (actAs app.pauser) do + exerciseCmd app.rulesCid MyRules_Pause + +-- | A registry that is not paused cannot be unpaused. +testUnpausedRegistryCannotBeUnpaused : Script () +testUnpausedRegistryCannotBeUnpaused = do + App{..} <- setup + mustFailWith "registry is not paused" (actAs pauser) do + exerciseCmd rulesCid MyRules_Unpause + -- Fee on transfer ------------------ @@ -499,6 +531,17 @@ testFeeComposesTwoWorkflowCalls = do balanceSeenBy alice alice >>= (=== [49.5]) balanceSeenBy bob bob >>= (=== [50.0]) +-- | The fee is a share of the transfer amount, so it must lie between 0 and +-- 10000 basis points inclusive. +testTransferFeeMustBeInRange : Script () +testTransferFeeMustBeInRange = do + App{..} <- setup + Some rules <- queryContractId admin rulesCid + submitMustFail admin do createCmd rules with transferFeeBps = -1 + submitMustFail admin do createCmd rules with transferFeeBps = 10001 + _ <- submit admin do createCmd rules with transferFeeBps = 10000 + pure () + -- Registry policy ------------------ @@ -516,6 +559,23 @@ testExecutorAllowlist = do _ <- allocate app alice (mkSpec app alice [senderSide leg] None) [aliceTok] pure () +-- | The allowlist is checked again at settlement, so allocations made before +-- the admin dropped an executor cannot settle through the new rules. +testSettlementChecksExecutorAllowlist : Script () +testSettlementChecksExecutorAllowlist = do + app0@App{..} <- setup + aliceTok <- mint app0 alice 10.0 + let leg = mkLeg "leg-1" alice bob 10.0 + aliceAlloc <- allocate app0 alice (mkSpec app0 alice [senderSide leg] None) [aliceTok] + bobAlloc <- allocate app0 bob (mkSpec app0 bob [receiverSide leg] None) [] + Some rules <- queryContractId admin rulesCid + submit admin do archiveCmd rulesCid + newRulesCid <- submit admin do createCmd rules with allowedExecutors = [] + Some disclosure <- queryDisclosure @MyRules admin newRulesCid + let app = app0 with rulesCid = newRulesCid; rulesDisclosure = disclosure + mustFailWith "a settlement executor is not approved" (actAs exchange <> discloseMany [disclosure]) + (settleBatchCmd app [leg] (map nonIteratedAllocation [aliceAlloc, bobAlloc])) + -- Expiry and cleanup --------------------- @@ -611,3 +671,83 @@ testForeignHoldingRefused = do (transferCmd app [attacker] (mkTransfer app attacker attacker 1000000.0 [toInterfaceContractId @HoldingV2.Holding forgedCid])) balanceSeenBy attacker attacker >>= (=== []) + +-- | An `Allocation` the registry never created, whose view claims this +-- registry. Its choice bodies fail, so a refusal from the registry shows the +-- registry never ran them with its authority. +template ForeignAllocation with + attacker : Party + claimedView : AllocationV2.AllocationView + observers : [Party] + where + signatory attacker + observer observers + interface instance AllocationV2.Allocation for ForeignAllocation where + view = claimedView + allocation_settleExtraObservers _ = [] + allocation_cancelExtraObservers _ = [] + allocation_withdrawExtraObservers _ = [] + allocation_settleImpl _ _ = fail "foreign settle body ran" + allocation_withdrawImpl _ _ = fail "foreign withdraw body ran" + allocation_cancelImpl _ _ = fail "foreign cancel body ran" + +-- | A forged allocation by `attacker` for `sides`, visible to the admin and +-- the exchange, and already expired. +forgeAllocation : App -> Party -> [AllocationV2.TransferLegSide] -> Script (ContractId AllocationV2.Allocation) +forgeAllocation app@App{..} attacker sides = do + cid <- submit attacker do + createCmd ForeignAllocation with + attacker + observers = [admin, exchange] + claimedView = AllocationV2.AllocationView with + originalAllocationCid = None + settlement + allocation = mkSpec app attacker sides None + holdingCids = [] + createdAt = t0 + numIterations = 0 + expiresAt = Some t0 + availableActions = Map.empty + meta = emptyMetadata + pure (toInterfaceContractId cid) + +-- | A forged sender-side allocation would pay bob from funds the attacker +-- never locked. Settlement accepts only `MyAllocation`s. +testForeignAllocationRefusedAtSettlement : Script () +testForeignAllocationRefusedAtSettlement = do + app@App{..} <- setup + attacker <- allocateParty "attacker" + let leg = mkLeg "leg-1" attacker bob 10.0 + forged <- forgeAllocation app attacker [senderSide leg] + bobAlloc <- allocate app bob (mkSpec app bob [receiverSide leg] None) [] + mustFailWith "allocation is not an accepted implementation" (actAs exchange <> discloseMany [rulesDisclosure]) + (settleBatchCmd app [leg] (map nonIteratedAllocation [forged, bobAlloc])) + +-- | Expiry would run the forged allocation's cancel body with the admin's +-- authority. It accepts only `MyAllocation`s. +testForeignAllocationRefusedAtExpiry : Script () +testForeignAllocationRefusedAtExpiry = do + app@App{..} <- setup + attacker <- allocateParty "attacker" + forged <- forgeAllocation app attacker [senderSide (mkLeg "leg-1" attacker bob 10.0)] + mustFailWith "allocation is not an accepted implementation" (actAs admin) do + exerciseCmd rulesCid MyRules_ExpireAllocations with + cancelArgs = [(forged, AllocationV2.Allocation_Cancel with actors = [admin]; extraArgs = emptyExtraArgs)] + +-- | The registry only expires its own instructions. Its admin can fetch +-- another registry's instruction when it is the receiver of that transfer. +testExpireTransferInstructionsRefusesOtherRegistry : Script () +testExpireTransferInstructionsRefusesOtherRegistry = do + app@App{..} <- setup + otherAdmin <- allocateParty "otherAdmin" + Some rules <- queryContractId admin rulesCid + otherRulesCid <- submit otherAdmin do createCmd rules with config = rules.config with admin = otherAdmin + Some otherDisclosure <- queryDisclosure @MyRules otherAdmin otherRulesCid + let other = app with admin = otherAdmin; rulesCid = otherRulesCid; rulesDisclosure = otherDisclosure + aliceTok <- mint other alice 10.0 + instrCid <- pendingCid =<< submit (actAs alice <> discloseMany [otherDisclosure]) + (transferCmd other [alice] (mkTransfer other alice admin 7.0 [aliceTok])) + setTime t3 + mustFailWith "'transfer.instrumentId.admin' is not equal to" (actAs admin) do + exerciseCmd rulesCid MyRules_ExpireTransferInstructions with + instructionCids = [fromInterfaceContractId @MyTransferInstruction instrCid] diff --git a/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1GuardTest.daml b/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1GuardTest.daml new file mode 100644 index 0000000..7df7df7 --- /dev/null +++ b/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1GuardTest.daml @@ -0,0 +1,399 @@ +-- | One test per guard in the default templates' workflows. Each test drives +-- a request to the guard and matches the guard's own message, so it fails if +-- the guard is removed even when a later check or a missing authorization +-- would also refuse the request. +module OpenZeppelin.TokenCIP112V1GuardTest where + +import DA.Assert ((===)) +import DA.Date (date, Month(Sep)) +import DA.Optional (optionalToList) +import DA.TextMap qualified as TextMap +import DA.Time (addRelTime, days, hours, minutes, time) +import Daml.Script + +import Splice.Api.Token.MetadataV1 +import Splice.Api.Token.HoldingV2 qualified as HoldingV2 +import Splice.Api.Token.AllocationV2 qualified as AllocationV2 +import Splice.Api.Token.AllocationInstructionV2 qualified as AllocationInstructionV2 +import Splice.Api.Token.TransferInstructionV2 qualified as TransferInstructionV2 +import Splice.TokenStandard.Utils (basicAccount, mintAccount, senderSide, receiverSide, nonIteratedAllocation) + +import OpenZeppelin.TokenCIP112WorkflowsV1.Holding (RegistryConfig(..)) +import OpenZeppelin.TokenCIP112WorkflowsV1.Transfer (TransferInstructionState(..)) +import OpenZeppelin.TokenCIP112V1.Holding +import OpenZeppelin.TokenCIP112V1.Registry +import OpenZeppelin.TokenCIP112V1.Transfer +import OpenZeppelin.TokenCIP112V1ForeignAllocationTest (mustFailWith) +import OpenZeppelin.TokenCIP112V1TestFixtures + +-- | Older than the registry's 90-day `maxTTL` at `t1`. +staleTime : Time +staleTime = time (date 2025 Sep 1) 0 0 0 + +-- | The message of every actor-set check. +actorsMismatch : Text +actorsMismatch = "'actors' does not have the same elements as one of" + +-- | A holding created directly with the admin's and the owner's authority. +holdingIn : Party -> HoldingV2.Account -> Text -> Decimal -> Optional HoldingV2.Lock -> Script (ContractId TokenHolding) +holdingIn admin account instrumentId amount lock = + submit (actAs (admin :: optionalToList account.owner)) do + createCmd TokenHolding with + holding = HoldingV2.HoldingView with + account + instrumentId = HoldingV2.InstrumentId with admin; id = instrumentId + amount + lock + meta = emptyMetadata + +lockedBy : [Party] -> Optional Time -> Optional HoldingV2.Lock +lockedBy holders expiresAt = Some HoldingV2.Lock with holders; expiresAt; expiresAfter = None; context = None + +-- | A second regular account owned by the same party. +savingsAccount : Party -> HoldingV2.Account +savingsAccount owner = HoldingV2.Account with owner = Some owner; provider = None; id = "savings" + +transferCmd + : Scenario -> [Party] -> TransferInstructionV2.Transfer + -> Commands TransferInstructionV2.TransferInstructionResult +transferCmd Scenario{..} actors transfer = + exerciseCmd (toInterfaceContractId @TransferInstructionV2.TransferFactory rulesCid) + TransferInstructionV2.TransferFactory_Transfer with transfer; actors; extraArgs = emptyExtraArgs + +allocateCmd + : Scenario -> [Party] -> AllocationV2.AllocationSpecification -> Time -> [ContractId TokenHolding] + -> Commands AllocationInstructionV2.AllocationInstructionResult +allocateCmd Scenario{..} actors spec requestedAt inputs = + exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) + AllocationInstructionV2.AllocationFactory_Allocate with + settlement + allocation = spec + requestedAt + inputHoldingCids = map (toInterfaceContractId @HoldingV2.Holding) inputs + extraArgs = emptyExtraArgs + actors + +settleCmd + : ContractId AllocationV2.Allocation -> [Party] -> [AllocationV2.TransferLegSide] + -> Commands AllocationV2.AllocationResult +settleCmd cid actors extraTransferLegSides = + exerciseCmd cid AllocationV2.Allocation_Settle with + actors + extraTransferLegSides + nextIterationFunding = None + extraArgs = emptyExtraArgs + +-- Holdings +----------- + +testOwnerUnlockRefusesUnlockedHolding : Script () +testOwnerUnlockRefusesUnlockedHolding = do + Scenario{..} <- setup + cid <- mint admin alice 10.0 + mustFailWith "holding is not locked" (actAs alice) do + exerciseCmd cid TokenHolding_OwnerUnlock + +-- | An indefinite lock never expires, so its owner can never release it. +testOwnerUnlockRefusesIndefiniteLock : Script () +testOwnerUnlockRefusesIndefiniteLock = do + Scenario{..} <- setup + cid <- holdingIn admin (basicAccount alice) "TOK" 10.0 (lockedBy [admin] None) + setTime t4 + mustFailWith "holding is locked indefinitely" (actAs alice) do + exerciseCmd cid TokenHolding_OwnerUnlock + +-- Transfer factory +------------------- + +-- | The actors must be exactly the sender's parties, or both sides' parties. +-- An extra actor is refused even when its authority would be harmless. +testTransferRefusesExtraActor : Script () +testTransferRefusesExtraActor = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + mustFailWith actorsMismatch (actAs [alice, admin] <> discloseMany [rulesDisclosure]) + (transferCmd s [alice, admin] (mkTransfer s alice bob 7.0 [input])) + +testTransferRefusesOtherAdmin : Script () +testTransferRefusesOtherAdmin = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + let transfer = mkTransfer s alice bob 7.0 [input] + mustFailWith "'transfer.instrumentId.admin' is not equal to" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (transfer with instrumentId = transfer.instrumentId with admin = bob)) + +testTransferRefusesZeroAmount : Script () +testTransferRefusesZeroAmount = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + mustFailWith "transfer must be well formed" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (mkTransfer s alice bob 0.0 [input])) + +-- | Special (mint and burn) accounts hold nothing, so they never take part +-- in a transfer; supply changes go through mint and burn. +testTransferRefusesSpecialAccount : Script () +testTransferRefusesSpecialAccount = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + let transfer = mkTransfer s alice bob 7.0 [input] + mustFailWith "transfer accounts must be regular accounts" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (transfer with receiver = mintAccount)) + +testTransferRefusesFutureRequestedAt : Script () +testTransferRefusesFutureRequestedAt = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + let transfer = mkTransfer s alice bob 7.0 [input] + mustFailWith "strictly before deadline 'transfer.requestedAt'" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (transfer with requestedAt = t1 `addRelTime` minutes 5)) + +testTransferRefusesWindowBeyondMaxTTL : Script () +testTransferRefusesWindowBeyondMaxTTL = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + let transfer = mkTransfer s alice bob 7.0 [input] + mustFailWith "transfer execution window exceeds the registry's maximum TTL" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (transfer with executeBefore = t1 `addRelTime` days 91)) + +testTransferRefusesStaleRequestedAt : Script () +testTransferRefusesStaleRequestedAt = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + let transfer = mkTransfer s alice bob 7.0 [input] + mustFailWith "transfer requestedAt is older than the registry's maximum TTL" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (transfer with requestedAt = staleTime)) + +testTransferRefusesNoInputs : Script () +testTransferRefusesNoInputs = do + s@Scenario{..} <- setup + mustFailWith "transfer requires input holdings to fund it" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (mkTransfer s alice bob 7.0 [])) + +testTransferRefusesMixedInstruments : Script () +testTransferRefusesMixedInstruments = do + s@Scenario{..} <- setup + tok <- mint admin alice 10.0 + usd <- holdingIn admin (basicAccount alice) "USD" 10.0 None + mustFailWith "input holdings must all match the transfer's instrument" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (mkTransfer s alice bob 7.0 [tok, usd])) + +-- | Funding must come from the sender's account, not another account of the +-- same owner. +testTransferRefusesInputFromOtherAccount : Script () +testTransferRefusesInputFromOtherAccount = do + s@Scenario{..} <- setup + input <- holdingIn admin (savingsAccount alice) "TOK" 10.0 None + mustFailWith "'inputHolding.account' is not equal to" (actAs alice <> discloseMany [rulesDisclosure]) + (transferCmd s [alice] (mkTransfer s alice bob 7.0 [input])) + +-- Transfer instructions +------------------------ + +pendingTransfer : Scenario -> Script (ContractId TransferInstructionV2.TransferInstruction) +pendingTransfer s@Scenario{..} = do + input <- mint admin alice 10.0 + result <- instructTransfer s [alice] (mkTransfer s alice bob 7.0 [input]) + pendingCid result + +testAcceptRefusesExtraActor : Script () +testAcceptRefusesExtraActor = do + s@Scenario{..} <- setup + instrCid <- pendingTransfer s + mustFailWith actorsMismatch (actAs [bob, admin]) do + exerciseCmd instrCid TransferInstructionV2.TransferInstruction_Accept with + actors = [bob, admin]; extraArgs = emptyExtraArgs + +testRejectRefusesExtraActor : Script () +testRejectRefusesExtraActor = do + s@Scenario{..} <- setup + instrCid <- pendingTransfer s + mustFailWith actorsMismatch (actAs [bob, admin]) do + exerciseCmd instrCid TransferInstructionV2.TransferInstruction_Reject with + actors = [bob, admin]; extraArgs = emptyExtraArgs + +testWithdrawRefusesExtraActor : Script () +testWithdrawRefusesExtraActor = do + s@Scenario{..} <- setup + instrCid <- pendingTransfer s + mustFailWith actorsMismatch (actAs [alice, admin]) do + exerciseCmd instrCid TransferInstructionV2.TransferInstruction_Withdraw with + actors = [alice, admin]; extraArgs = emptyExtraArgs + +-- | The factory always locks exactly the transfer amount, so only an +-- instruction the admin and the sender create directly can lock less. +-- Accepting it must not pay out more than is locked. +testAcceptRefusesUnderfundedLock : Script () +testAcceptRefusesUnderfundedLock = do + s@Scenario{..} <- setup + locked <- holdingIn admin (basicAccount alice) "TOK" 5.0 (lockedBy [admin, bob] (Some t4)) + instrCid <- submit (actAs [admin, alice]) do + createCmd TokenTransferInstruction with + state = TransferInstructionState with + transfer = mkTransfer s alice bob 7.0 [locked] + originalInputHoldingCids = [] + lockedHoldingCids = [toInterfaceContractId locked] + expiresAt = t2 + lockExpiresAt = t4 + mustFailWith "'locked funding for TOK' is less than 'transfer.amount'" (actAs bob) do + exerciseCmd (toInterfaceContractId @TransferInstructionV2.TransferInstruction instrCid) + TransferInstructionV2.TransferInstruction_Accept with actors = [bob]; extraArgs = emptyExtraArgs + +-- | Admin cleanup waits until the funding lock has expired, so the sender +-- can always recover the funds first. +testTransferAdminGCWaitsForLockExpiry : Script () +testTransferAdminGCWaitsForLockExpiry = do + s@Scenario{..} <- setup + instrCid <- pendingTransfer s + setTime t3 + mustFailWith "strictly before deadline 'lockExpiresAt'" (actAs admin) do + exerciseCmd (fromInterfaceContractId @TokenTransferInstruction instrCid) TokenTransferInstruction_AdminGC + +-- Allocation factory +--------------------- + +testAllocateRefusesExtraActor : Script () +testAllocateRefusesExtraActor = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + mustFailWith actorsMismatch (actAs [alice, admin] <> discloseMany [rulesDisclosure]) + (allocateCmd s [alice, admin] (mkAllocationSpec admin alice [senderSide legAliceToBob]) t0 [input]) + +testAllocateRefusesOtherAdmin : Script () +testAllocateRefusesOtherAdmin = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + mustFailWith "'allocation.admin' is not equal to" (actAs alice <> discloseMany [rulesDisclosure]) + (allocateCmd s [alice] (mkAllocationSpec bob alice [senderSide legAliceToBob]) t0 [input]) + +testAllocateRefusesNoLegsWithoutIteration : Script () +testAllocateRefusesNoLegsWithoutIteration = do + s@Scenario{..} <- setup + mustFailWith "allocation must authorize at least one transfer-leg side" (actAs alice <> discloseMany [rulesDisclosure]) + (allocateCmd s [alice] (mkAllocationSpec admin alice []) t0 []) + +testAllocateRefusesFutureRequestedAt : Script () +testAllocateRefusesFutureRequestedAt = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + mustFailWith "strictly before deadline 'requestedAt'" (actAs alice <> discloseMany [rulesDisclosure]) + (allocateCmd s [alice] (mkAllocationSpec admin alice [senderSide legAliceToBob]) (t1 `addRelTime` minutes 5) [input]) + +testAllocateRefusesPastDeadline : Script () +testAllocateRefusesPastDeadline = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + let spec = (mkAllocationSpec admin alice [senderSide legAliceToBob]) with settlementDeadline = Some t0 + mustFailWith "at or past deadline 'allocation.settlementDeadline'" (actAs alice <> discloseMany [rulesDisclosure]) + (allocateCmd s [alice] spec t0 [input]) + +testAllocateRefusesStaleRequestedAt : Script () +testAllocateRefusesStaleRequestedAt = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + mustFailWith "requestedAt is older than the registry's maximum TTL" (actAs alice <> discloseMany [rulesDisclosure]) + (allocateCmd s [alice] (mkAllocationSpec admin alice [senderSide legAliceToBob]) staleTime [input]) + +-- Allocations +-------------- + +-- | Settling outside the batch factory skips the exact-cover check, so it +-- needs the admin as well as the executors. An executor alone is refused. +testSettleRefusesExecutorWithoutAdmin : Script () +testSettleRefusesExecutorWithoutAdmin = do + s@Scenario{..} <- setup + bobAlloc <- completedCid =<< allocate s bob [receiverSide legAliceToBob] [] + mustFailWith actorsMismatch (actAs app) (settleCmd bobAlloc [app] []) + +testSettleRefusesAfterDeadline : Script () +testSettleRefusesAfterDeadline = do + s@Scenario{..} <- setup + bobAlloc <- completedCid =<< allocate s bob [receiverSide legAliceToBob] [] + setTime t3 + mustFailWith "at or past deadline 'allocation.settlementDeadline'" (actAs [admin, app]) (settleCmd bobAlloc [admin, app] []) + +-- | A settlement can never leave the authorizer with less than nothing: an +-- extra leg larger than the locked funds is refused. +testSettleRefusesNegativeTotal : Script () +testSettleRefusesNegativeTotal = do + s@Scenario{..} <- setup + input <- mint admin alice 5.0 + let spec = (mkAllocationSpec admin alice []) with nextIterationFunding = Some (TextMap.fromList [("TOK", 5.0)]) + aliceAlloc <- completedCid =<< allocateSpec s alice spec [input] + let extra = senderSide (mkTransferLeg "it-1" alice bob 8.0) + mustFailWith "'locked funds plus net credit for TOK' is less than 'zero'" (actAs [admin, app]) + (settleCmd aliceAlloc [admin, app] [extra]) + +testAllocationWithdrawRefusesExtraActor : Script () +testAllocationWithdrawRefusesExtraActor = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + aliceAlloc <- completedCid =<< allocate s alice [senderSide legAliceToBob] [input] + mustFailWith actorsMismatch (actAs [alice, admin]) do + exerciseCmd aliceAlloc AllocationV2.Allocation_Withdraw with + actors = [alice, admin]; extraArgs = emptyExtraArgs + +-- | A committed allocation stays available to its executors until the +-- settlement deadline; after it, the authorizer can withdraw. +testCommittedAllocationWithdrawWaitsForDeadline : Script () +testCommittedAllocationWithdrawWaitsForDeadline = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + let spec = (mkAllocationSpec admin alice [senderSide legAliceToBob]) with committed = True + aliceAlloc <- completedCid =<< allocateSpec s alice spec [input] + let withdraw = exerciseCmd aliceAlloc AllocationV2.Allocation_Withdraw with + actors = [alice]; extraArgs = emptyExtraArgs + mustFailWith "Cannot withdraw a committed allocation before its settlement deadline" (actAs alice) withdraw + setTime t3 + _ <- submit (actAs alice) withdraw + holdingAmounts alice >>= (=== [10.0]) + +-- Registry +----------- + +testSettleBatchRefusesExtraActor : Script () +testSettleBatchRefusesExtraActor = do + s@Scenario{..} <- setup + input <- mint admin alice 10.0 + aliceAlloc <- completedCid =<< allocate s alice [senderSide legAliceToBob] [input] + bobAlloc <- completedCid =<< allocate s bob [receiverSide legAliceToBob] [] + mustFailWith actorsMismatch (actAs [app, bob] <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [legAliceToBob] + allocations = map nonIteratedAllocation [aliceAlloc, bobAlloc] + actors = [app, bob] + extraArgs = emptyExtraArgs + +testMintRefusesSpecialAccount : Script () +testMintRefusesSpecialAccount = do + Scenario{..} <- setup + mustFailWith "mint target must be a regular account" (actAs admin <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_Mint with + account = mintAccount; instrumentId = "TOK"; amount = 10.0; reason = "mint" + +testBurnRefusesOtherAccount : Script () +testBurnRefusesOtherAccount = do + Scenario{..} <- setup + savings <- holdingIn admin (savingsAccount alice) "TOK" 10.0 None + mustFailWith "'holding.account' is not equal to" (actAs [admin, alice] <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_Burn with + holdingCid = toInterfaceContractId savings; account = basicAccount alice; reason = "burn" + +-- | The registry only expires its own instructions. Its admin can fetch +-- another registry's instruction when it is the receiver of that transfer. +testExpireTransferInstructionsRefusesOtherRegistry : Script () +testExpireTransferInstructionsRefusesOtherRegistry = do + s@Scenario{..} <- setup + otherAdmin <- allocateParty "otherAdmin" + otherRulesCid <- submit otherAdmin do + createCmd TokenRules with + config = RegistryConfig with admin = otherAdmin; maxTTL = days 90; lockGrace = hours 1 + Some otherDisclosure <- queryDisclosure @TokenRules otherAdmin otherRulesCid + let other = s with admin = otherAdmin; rulesCid = otherRulesCid; rulesDisclosure = otherDisclosure + input <- mint otherAdmin alice 10.0 + instrCid <- pendingCid =<< instructTransfer other [alice] (mkTransfer other alice admin 7.0 [input]) + setTime t3 + mustFailWith "'transfer.instrumentId.admin' is not equal to" (actAs admin) do + exerciseCmd rulesCid TokenRules_ExpireTransferInstructions with + instructionCids = [fromInterfaceContractId @TokenTransferInstruction instrCid]; observers = [] diff --git a/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml b/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml index 289431c..188d034 100644 --- a/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml +++ b/test/tokenCIP112-v1-test/daml/OpenZeppelin/TokenCIP112V1Test.daml @@ -27,6 +27,7 @@ import OpenZeppelin.TokenCIP112V1.Allocation import OpenZeppelin.TokenCIP112V1.Holding import OpenZeppelin.TokenCIP112V1.Registry import OpenZeppelin.TokenCIP112V1.Transfer +import OpenZeppelin.TokenCIP112V1ForeignAllocationTest (mustFailWith) import OpenZeppelin.TokenCIP112V1TestFixtures -- | Happy path: two-leg DvP with net funding. Alice sends 10 and receives 4, @@ -559,7 +560,7 @@ testCommittedRequiresDeadline = do let badSpec = (mkAllocationSpec admin alice [senderSide legAliceToBob]) with committed = True settlementDeadline = None - submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + mustFailWith "a committed allocation requires a settlement deadline" (actAs alice <> discloseMany [rulesDisclosure]) do exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) AllocationInstructionV2.AllocationFactory_Allocate with settlement @@ -706,7 +707,7 @@ testSpecialAuthorizerRefused = do meta = emptyMetadata -- `accountParties` resolves a special account to the admin, so the admin is -- the only plausible actor — and even the admin is refused. - submitMustFail (actAs admin <> discloseMany [rulesDisclosure]) do + mustFailWith "allocation authorizer must be a regular account" (actAs admin <> discloseMany [rulesDisclosure]) do exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) AllocationInstructionV2.AllocationFactory_Allocate with settlement @@ -816,7 +817,7 @@ testMintAndBurnEmitEvents = do map (.otherside) mintEvent.transferLegSides === [mintAccount] map (.amount) mintEvent.transferLegSides === [25.0] -- Minting a non-positive amount is refused. - submitMustFail (actAs admin <> actAs alice <> discloseMany [rulesDisclosure]) do + mustFailWith "mint amount must be positive" (actAs admin <> actAs alice <> discloseMany [rulesDisclosure]) do exerciseCmd rulesCid TokenRules_Mint with account = basicAccount alice instrumentId = "TOK" diff --git a/test/tokenCIP112-workflows-v1-test/daml/OpenZeppelin/TokenCIP112WorkflowsV1Test.daml b/test/tokenCIP112-workflows-v1-test/daml/OpenZeppelin/TokenCIP112WorkflowsV1Test.daml index 6ac3357..975c7d2 100644 --- a/test/tokenCIP112-workflows-v1-test/daml/OpenZeppelin/TokenCIP112WorkflowsV1Test.daml +++ b/test/tokenCIP112-workflows-v1-test/daml/OpenZeppelin/TokenCIP112WorkflowsV1Test.daml @@ -1,7 +1,9 @@ -- | Unit tests for the workflows package on its own: the pure predicates and -- bounds, the event-observer merge, and the two pinning builders, each run -- against a minimal local template it accepts and a foreign template it must --- refuse. The full workflows run under `test/tokenCIP112-v1` through the +-- refuse. The consumption, burn, and expiry bodies are run here too, for the +-- guards that only a consumer's own `HoldingOps` or allocation template can +-- reach. The full workflows run under `test/tokenCIP112-v1` through the -- default templates and under `examples/tokenCIP112/custom-token-test` -- through a consumer's templates. module OpenZeppelin.TokenCIP112WorkflowsV1Test where @@ -20,16 +22,18 @@ import Splice.Api.Token.MetadataV1 import Splice.Api.Token.HoldingV2 qualified as HoldingV2 import Splice.Api.Token.AllocationV2 qualified as AllocationV2 import Splice.Api.Token.TransferInstructionV2 qualified as TransferInstructionV2 -import Splice.TokenStandard.Utils (accountParties, basicAccount, maxTime) +import Splice.TokenStandard.Utils (accountParties, basicAccount, maxTime, mintAccount, senderSide) import OpenZeppelin.TokenCIP112WorkflowsV1.Holding import OpenZeppelin.TokenCIP112WorkflowsV1.Transfer import OpenZeppelin.TokenCIP112WorkflowsV1.Allocation +import OpenZeppelin.TokenCIP112WorkflowsV1.Registry -t0, t1, t2 : Time +t0, t1, t2, t3 : Time t0 = time (date 2026 Jan 1) 0 0 0 t1 = time (date 2026 Jan 1) 0 10 0 t2 = time (date 2026 Jan 1) 0 20 0 +t3 = time (date 2026 Jan 1) 0 30 0 -- Local templates ------------------ @@ -104,6 +108,35 @@ template Harness with controller actors do pinAllocationTo @UnitAllocation cid + nonconsuming choice Harness_ConsumeLocked : HoldingV2.HoldingView + with cid : ContractId HoldingV2.Holding; expectedAccount : HoldingV2.Account; actors : [Party] + controller actors + do consumeLockedHolding unitOps admin expectedAccount cid + + nonconsuming choice Harness_ConsumeUnlocked : HoldingV2.HoldingView + with cid : ContractId HoldingV2.Holding; expectedAccount : HoldingV2.Account; actors : [Party] + controller actors + do consumeUnlockedHolding unitOps admin expectedAccount cid + + nonconsuming choice Harness_Burn : () + with cid : ContractId HoldingV2.Holding; account : HoldingV2.Account; actors : [Party] + controller actors + do burnImpl unitOps admin cid account "burn" + + nonconsuming choice Harness_ExpireAllocations : () + with cancelArgs : [(ContractId AllocationV2.Allocation, AllocationV2.Allocation_Cancel)]; actors : [Party] + controller actors + do expireAllocationsImpl (pinAllocationTo @UnitAllocation) admin cancelArgs + +-- | The operations the harness runs the bodies with. Events are not under +-- test here, so emission does nothing. +unitOps : HoldingOps +unitOps = HoldingOps with + createHolding = \v -> toInterfaceContractId <$> create UnitHolding with holding = v + consumeHolding = consumeByArchive @UnitHolding + withEventLog = \_ -> pure () + eventObservers = const [] + basicOwner : HoldingV2.HoldingView -> Party basicOwner v = case v.account.owner of Some p -> p @@ -163,26 +196,30 @@ testBuilderRefusesForeignHolding = do Some _ <- queryContractId attacker foreignCid pure () +-- | The view of an allocation by `alice` under `admin`, expiring at `t2`. +unitAllocationView : Party -> Party -> AllocationV2.AllocationView +unitAllocationView admin alice = AllocationV2.AllocationView with + originalAllocationCid = None + settlement = AllocationV2.SettlementInfo with executors = [admin]; id = "s"; cid = None; meta = emptyMetadata + allocation = AllocationV2.AllocationSpecification with + admin + authorizer = basicAccount alice + transferLegSides = [] + settlementDeadline = Some t2 + nextIterationFunding = Some TextMap.empty + committed = False + meta = emptyMetadata + holdingCids = [] + createdAt = t1 + numIterations = 0 + expiresAt = Some t2 + availableActions = Map.empty + meta = emptyMetadata + testPinAllocation : Script () testPinAllocation = do Fixture{..} <- setup - let v = AllocationV2.AllocationView with - originalAllocationCid = None - settlement = AllocationV2.SettlementInfo with executors = [admin]; id = "s"; cid = None; meta = emptyMetadata - allocation = AllocationV2.AllocationSpecification with - admin - authorizer = basicAccount alice - transferLegSides = [] - settlementDeadline = Some t2 - nextIterationFunding = Some TextMap.empty - committed = False - meta = emptyMetadata - holdingCids = [] - createdAt = t1 - numIterations = 0 - expiresAt = Some t2 - availableActions = Map.empty - meta = emptyMetadata + let v = unitAllocationView admin alice genuine <- submit admin do createCmd UnitAllocation with claimedView = v; admin pinned <- submit admin do exerciseCmd harnessCid Harness_PinAllocation with @@ -241,6 +278,9 @@ testTransferInstructionStatePredicate = do expiresAt = t2 lockExpiresAt = t2 `addRelTime` hours 1 isValidTransferInstructionState s === True + isValidTransferInstructionState (s with transfer = transfer with amount = 0.0) === False + isValidTransferInstructionState (s with transfer = transfer with sender = mintAccount) === False + isValidTransferInstructionState (s with transfer = transfer with receiver = mintAccount) === False isValidTransferInstructionState (s with lockedHoldingCids = []) === False isValidTransferInstructionState (s with lockExpiresAt = t2) === False -- The view advertises each side's account parties as the actor set. @@ -248,6 +288,51 @@ testTransferInstructionStatePredicate = do Map.lookup TransferInstructionV2.TIA_Accept v.availableActions === Some [[bob]] Map.lookup TransferInstructionV2.TIA_Withdraw v.availableActions === Some [[alice]] +testAllocationStatePredicate : Script () +testAllocationStatePredicate = do + admin <- allocateParty "admin" + alice <- allocateParty "alice" + bob <- allocateParty "bob" + let leg = AllocationV2.TransferLeg with + transferLegId = "leg-1" + sender = basicAccount alice + receiver = basicAccount bob + amount = 5.0 + instrumentId = "TOK" + meta = emptyMetadata + settlement = AllocationV2.SettlementInfo with executors = [bob]; id = "s"; cid = None; meta = emptyMetadata + allocation = AllocationV2.AllocationSpecification with + admin + authorizer = basicAccount alice + transferLegSides = [senderSide leg] + settlementDeadline = Some t2 + nextIterationFunding = None + committed = False + meta = emptyMetadata + s = AllocationState with + originalAllocationCid = None + settlement + allocation + lockedHoldingCids = [] + requestedAt = t0 + createdAt = t1 + numIterations = 0 + expiresAt = t2 + lockExpiresAt = t2 `addRelTime` hours 1 + maxTTL = days 90 + lockGrace = hours 1 + isValidAllocationState s === True + isValidAllocationState (s with settlement = settlement with executors = []) === False + isValidAllocationState (s with allocation = allocation with transferLegSides = [senderSide leg with amount = 0.0]) === False + -- A special account may authorize legs, but holds nothing to reserve. + isValidAllocationState (s with allocation = allocation with authorizer = mintAccount) === True + isValidAllocationState (s with allocation = allocation with authorizer = mintAccount; nextIterationFunding = Some TextMap.empty) === False + isValidAllocationState (s with numIterations = -1) === False + isValidAllocationState (s with lockExpiresAt = t2) === False + isValidAllocationState (s with maxTTL = minutes 0) === False + isValidAllocationState (s with lockGrace = minutes 0) === False + isValidAllocationState (s with allocation = allocation with committed = True; settlementDeadline = None) === False + -- | Storage bound: capped by the deadline, saturating at `maxTime`. testComputeStorageExpiry : Script () testComputeStorageExpiry = do @@ -272,3 +357,127 @@ testEventObserversFor = do eventObservers = const [auditor, alice] eventObserversFor ops admin account === dedupSort (accountParties admin account <> [auditor]) eventObserversFor (ops with eventObservers = const []) admin account === dedupSort [alice, provider] + +-- Consumption, burn, and expiry bodies +--------------------------------------- + +-- | A `UnitHolding` signed by `admin` and `owner`, in `account`. +unitHolding : Party -> Party -> HoldingV2.Account -> Optional HoldingV2.Lock -> Script (ContractId HoldingV2.Holding) +unitHolding admin owner account lock = do + cid <- submit (actAs [admin, owner]) do + createCmd UnitHolding with holding = mkHoldingView admin account "TOK" 5.0 lock + pure (toInterfaceContractId cid) + +lockUntil : Party -> Optional Time -> HoldingV2.Lock +lockUntil holder expiresAt = HoldingV2.Lock with holders = [holder]; expiresAt; expiresAfter = None; context = None + +savingsAccount : Party -> HoldingV2.Account +savingsAccount owner = HoldingV2.Account with owner = Some owner; provider = None; id = "savings" + +-- | The default templates need the instrument admin's authority to consume a +-- holding, so another admin's holding fails authorization first. A consumer +-- whose `consumeHolding` needs less authority relies on this check. +testConsumeLockedRefusesOtherAdmin : Script () +testConsumeLockedRefusesOtherAdmin = do + Fixture{..} <- setup + otherAdmin <- allocateParty "otherAdmin" + cid <- unitHolding otherAdmin alice (basicAccount alice) (Some (lockUntil otherAdmin (Some t2))) + mustFailWith "'inputHolding.instrumentId.admin' is not equal to" (actAs [admin, otherAdmin]) $ + exerciseCmd harnessCid Harness_ConsumeLocked with + cid; expectedAccount = basicAccount alice; actors = [admin, otherAdmin] + +-- | The same parties can hold in several accounts; funding must come from +-- the expected one. +testConsumeLockedRefusesOtherAccount : Script () +testConsumeLockedRefusesOtherAccount = do + Fixture{..} <- setup + cid <- unitHolding admin alice (savingsAccount alice) (Some (lockUntil admin (Some t2))) + mustFailWith "'inputHolding.account' is not equal to" (actAs admin) $ + exerciseCmd harnessCid Harness_ConsumeLocked with + cid; expectedAccount = basicAccount alice; actors = [admin] + +testConsumeLockedRefusesUnlockedHolding : Script () +testConsumeLockedRefusesUnlockedHolding = do + Fixture{..} <- setup + cid <- unitHolding admin alice (basicAccount alice) None + mustFailWith "input holding must be locked" (actAs admin) $ + exerciseCmd harnessCid Harness_ConsumeLocked with + cid; expectedAccount = basicAccount alice; actors = [admin] + +testConsumeUnlockedRefusesOtherAdmin : Script () +testConsumeUnlockedRefusesOtherAdmin = do + Fixture{..} <- setup + otherAdmin <- allocateParty "otherAdmin" + cid <- unitHolding otherAdmin alice (basicAccount alice) None + mustFailWith "'inputHolding.instrumentId.admin' is not equal to" (actAs [admin, otherAdmin]) $ + exerciseCmd harnessCid Harness_ConsumeUnlocked with + cid; expectedAccount = basicAccount alice; actors = [admin, otherAdmin] + +testConsumeUnlockedRefusesOtherAccount : Script () +testConsumeUnlockedRefusesOtherAccount = do + Fixture{..} <- setup + cid <- unitHolding admin alice (savingsAccount alice) None + mustFailWith "'inputHolding.account' is not equal to" (actAs admin) $ + exerciseCmd harnessCid Harness_ConsumeUnlocked with + cid; expectedAccount = basicAccount alice; actors = [admin] + +-- | An indefinite lock never expires, so the holding can never fund a new +-- workflow. +testConsumeUnlockedRefusesIndefiniteLock : Script () +testConsumeUnlockedRefusesIndefiniteLock = do + Fixture{..} <- setup + cid <- unitHolding admin alice (basicAccount alice) (Some (lockUntil admin None)) + mustFailWith "input holding is locked indefinitely" (actAs admin) $ + exerciseCmd harnessCid Harness_ConsumeUnlocked with + cid; expectedAccount = basicAccount alice; actors = [admin] + +testBurnRefusesOtherAdmin : Script () +testBurnRefusesOtherAdmin = do + Fixture{..} <- setup + otherAdmin <- allocateParty "otherAdmin" + cid <- unitHolding otherAdmin alice (basicAccount alice) None + mustFailWith "'holding.instrumentId.admin' is not equal to" (actAs [admin, otherAdmin]) $ + exerciseCmd harnessCid Harness_Burn with + cid; account = basicAccount alice; actors = [admin, otherAdmin] + +-- | Batched expiry re-checks each allocation itself rather than trusting the +-- allocation's cancel body, so each refusal below happens before +-- `UnitAllocation`'s cancel body, which always fails, could run. +expireUnit : Fixture -> AllocationV2.AllocationView -> [Party] -> Script (Commands ()) +expireUnit Fixture{..} v cancelActors = do + cid <- submit admin do createCmd UnitAllocation with claimedView = v; admin + pure $ exerciseCmd harnessCid Harness_ExpireAllocations with + cancelArgs = + [ ( toInterfaceContractId @AllocationV2.Allocation cid + , AllocationV2.Allocation_Cancel with + actors = cancelActors + extraArgs = ExtraArgs with context = emptyChoiceContext; meta = emptyMetadata ) ] + actors = [admin] + +testExpireAllocationsRefusesOtherCancelActors : Script () +testExpireAllocationsRefusesOtherCancelActors = do + f@Fixture{..} <- setup + setTime t3 + cmd <- expireUnit f (unitAllocationView admin alice) [admin, alice] + mustFailWith "'cancelArg.actors' is not equal to" (actAs admin) cmd + +testExpireAllocationsRefusesOtherAdmin : Script () +testExpireAllocationsRefusesOtherAdmin = do + f@Fixture{..} <- setup + setTime t3 + let v = unitAllocationView admin alice + cmd <- expireUnit f (v with allocation = v.allocation with admin = alice) [admin] + mustFailWith "'allocation.admin' is not equal to" (actAs admin) cmd + +testExpireAllocationsRefusesNoExpiry : Script () +testExpireAllocationsRefusesNoExpiry = do + f@Fixture{..} <- setup + setTime t3 + cmd <- expireUnit f ((unitAllocationView admin alice) with expiresAt = None) [admin] + mustFailWith "cannot expire an allocation without an expiry time" (actAs admin) cmd + +testExpireAllocationsRefusesLiveAllocation : Script () +testExpireAllocationsRefusesLiveAllocation = do + f@Fixture{..} <- setup + cmd <- expireUnit f (unitAllocationView admin alice) [admin] + mustFailWith "strictly before deadline 'allocation.expiresAt'" (actAs admin) cmd From c833aa9995cbca0a4057e36ee1a114b444c20c72 Mon Sep 17 00:00:00 2001 From: 0xNeshi Date: Thu, 8 Oct 2026 13:54:59 +0200 Subject: [PATCH 9/9] remove duplicate checkactors check in settlebatchimpl --- .../daml/OpenZeppelin/TokenCIP112WorkflowsV1/Registry.daml | 1 - 1 file changed, 1 deletion(-) diff --git a/packages/token/tokenCIP112-workflows-v1/daml/OpenZeppelin/TokenCIP112WorkflowsV1/Registry.daml b/packages/token/tokenCIP112-workflows-v1/daml/OpenZeppelin/TokenCIP112WorkflowsV1/Registry.daml index 65444f3..54164c4 100644 --- a/packages/token/tokenCIP112-workflows-v1/daml/OpenZeppelin/TokenCIP112WorkflowsV1/Registry.daml +++ b/packages/token/tokenCIP112-workflows-v1/daml/OpenZeppelin/TokenCIP112WorkflowsV1/Registry.daml @@ -26,7 +26,6 @@ settleBatchImpl -> AllocationV2.SettlementFactory_SettleBatch -> Update AllocationV2.SettlementFactory_SettleBatchResult settleBatchImpl pin admin self arg = do - checkActors arg.actors [arg.settlement.executors] require "a settlement batch must cover at least one transfer leg" (not (null arg.transferLegs)) let perAllocationExtraArgs _allocView _settleArg = pure ExtraArgs with