diff --git a/.gitignore b/.gitignore index e521f7c..60a62fe 100644 --- a/.gitignore +++ b/.gitignore @@ -15,7 +15,7 @@ Thumbs.db # Local agent and editor state .codex/ CLAUDE.local.md -.claude/settings.local.json +.claude/ .cursor/ .vscode/ .aider* @@ -26,3 +26,9 @@ CLAUDE.local.md .daml/ .cache/ .cache/identity-hook-upgrade-sandbox/ + +# Local splice checkout used to build the vendored token-standard DARs +splice/ + +# Extracted DAR contents for local browsing (regenerate by unzipping the DARs) +dars/token-standard/sources/ diff --git a/dars/manifest.yaml b/dars/manifest.yaml index c57febe..d74bf08 100644 --- a/dars/manifest.yaml +++ b/dars/manifest.yaml @@ -19,3 +19,111 @@ artifacts: source-commit: 69a810a1c90f1d0b182858c536d80b56f3acc31d source: https://github.com/OpenZeppelin/canton-contracts/tree/69a810a1c90f1d0b182858c536d80b56f3acc31d/packages/security/pausable-v1 license: MIT + # Token Standard V2 (CIP-0112) DARs, built locally from the splice checkout + # with two patches (sdk-version 3.5.2 -> 3.5.1, `-current` -> versioned DAR + # names); see dars/token-standard/PROVENANCE.md. Devnet-stage upstream: no + # released artifacts exist yet. + - package: splice-api-token-metadata-v1 + version: 1.0.0 + file: dars/token-standard/splice-api-token-metadata-v1-1.0.0.dar + main-package-id: b7ff3ac68c5f8d8de84277f6f850a7bbf1c562fa0e6e328be693b2e9d5bb6ee6 + sha256: ebb19c0dd8988677e01b523a90b84ad0390248757829b7ee9afd171b9d88b139 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-metadata-v1 + license: Apache-2.0 + - package: splice-api-token-holding-v1 + version: 1.0.0 + file: dars/token-standard/splice-api-token-holding-v1-1.0.0.dar + main-package-id: e386af17982207d49c443a8f6fb3b24217fd32ed7be994bc58159d4933a5b1a7 + sha256: 81e811d98b6264b4beaead8eb7ea249e0dd78ff64644795fe15d9396a4bb6b73 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-holding-v1 + license: Apache-2.0 + - package: splice-api-token-holding-v2 + version: 1.0.0 + file: dars/token-standard/splice-api-token-holding-v2-1.0.0.dar + main-package-id: dcf74571dd11e678637924e9f10a61a15727801c83c0f21d3218656b7e6039f8 + sha256: 1773772d230ae7331dc24b0055db91e65943e1beb879436b52288365f156868f + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-holding-v2 + license: Apache-2.0 + - package: splice-api-token-transfer-events-v2 + version: 1.0.0 + file: dars/token-standard/splice-api-token-transfer-events-v2-1.0.0.dar + main-package-id: 718b5bd2da888fc5221c9c887ac8aa8288aa7258f3d31fdc5ee01237435ef90d + sha256: 5f56e219fcf9010790c2cab3379985189f9dfc5d6940886bee02c0b7ac78c6e0 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-transfer-events-v2 + license: Apache-2.0 + - package: splice-api-token-allocation-v1 + version: 1.0.0 + file: dars/token-standard/splice-api-token-allocation-v1-1.0.0.dar + main-package-id: 20e6103654a72afc4276b66ea9b0482d3f0f1d84ad7eb8d1e47ce33e75a71f5d + sha256: 51cb3bc0dee44966b47a5bdebff94ede7df453b14ac3e4fa1d8e08cd1a920217 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-allocation-v1 + license: Apache-2.0 + - package: splice-api-token-allocation-v2 + version: 1.0.0 + file: dars/token-standard/splice-api-token-allocation-v2-1.0.0.dar + main-package-id: e5b7ba48c44c972ea670a983647c544516841e0d9d893d86bdf17a025f4c8b4e + sha256: 29d894589f8760be73e5800d4fc137d0d6b4ae574bbd1c871ada57f7781172b4 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-allocation-v2 + license: Apache-2.0 + - package: splice-api-token-transfer-instruction-v1 + version: 1.0.0 + file: dars/token-standard/splice-api-token-transfer-instruction-v1-1.0.0.dar + main-package-id: f1aa741ce669d3c33cdafd97de32789562815ff696cddba1ced9d16cac564732 + sha256: 4c7da23cc6de90f1fbc4505f7b0b65b002be7340eba6fef4ac776ccd94b1c081 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-transfer-instruction-v1 + license: Apache-2.0 + - package: splice-api-token-transfer-instruction-v2 + version: 1.0.0 + file: dars/token-standard/splice-api-token-transfer-instruction-v2-1.0.0.dar + main-package-id: 39be3518d462914e4db7d9c613b5ad2e7ef7f885a85ec15a30a57130de5a0801 + sha256: bb29b3c88adb40b37711f2d01aaa1238b3cd738d75d0eefb7c762ffb0f294747 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-transfer-instruction-v2 + license: Apache-2.0 + - package: splice-api-token-allocation-instruction-v1 + version: 1.0.0 + file: dars/token-standard/splice-api-token-allocation-instruction-v1-1.0.0.dar + main-package-id: a68b2f08f4d0c2d2b7ace4921f5a5f924db4e12047b793878eccaeff9e3d72fd + sha256: 88b1106d103b6c36f5009a603ef401c23f9d465e9bff5fe1c3458d1fd89b3dd7 + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-allocation-instruction-v1 + license: Apache-2.0 + - package: splice-api-token-allocation-instruction-v2 + version: 1.0.0 + file: dars/token-standard/splice-api-token-allocation-instruction-v2-1.0.0.dar + main-package-id: 1bc26b40a65ee49c51eefc09a4684443f270f740cbd25a2b8ebd44defde3db26 + sha256: 8a154c50eccd053c94d0f893f0506aabf7ac95754b0af8d6d9eac1e88df9f25c + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-allocation-instruction-v2 + license: Apache-2.0 + - package: splice-api-token-allocation-request-v1 + version: 1.0.0 + file: dars/token-standard/splice-api-token-allocation-request-v1-1.0.0.dar + main-package-id: 2d8b325a36b76019e9a8385ddf01a3436b617f7bfa54286cd071729806a0b2a4 + sha256: 41fa716e3e2b035a29182a8896b874294e2a07c414c72f763dffe864634cfa6b + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-allocation-request-v1 + license: Apache-2.0 + - package: splice-api-token-allocation-request-v2 + version: 1.0.0 + file: dars/token-standard/splice-api-token-allocation-request-v2-1.0.0.dar + main-package-id: 31a14f210c80643948afa6cb0097fb3058323a68d5646f4815e07ccabe34550a + sha256: 6a0b15708c33a6249b76614e7f73d3e1bd054cb1e219e2a8e91e8a3155e4666d + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-api-token-allocation-request-v2 + license: Apache-2.0 + - package: splice-token-standard-utils + version: 2.0.0 + file: dars/token-standard/splice-token-standard-utils-2.0.0.dar + main-package-id: 59fb226dc6dc896f15c89d6399d20241760328f84f9da6e11a83ee0c2d0b7108 + sha256: 2985466cd8f55460ecc4cb6486e018017818d745273fe398a9b68a5acc8a34fc + source-commit: 69b43eb761e38695052c983715aa855c8cb207fc + source: https://github.com/hyperledger-labs/splice/tree/69b43eb761e38695052c983715aa855c8cb207fc/token-standard/splice-token-standard-utils + license: Apache-2.0 diff --git a/dars/token-standard/PROVENANCE.md b/dars/token-standard/PROVENANCE.md new file mode 100644 index 0000000..bac9b92 --- /dev/null +++ b/dars/token-standard/PROVENANCE.md @@ -0,0 +1,20 @@ +# Token Standard DAR provenance + +Built from the local `splice/` checkout (hyperledger-labs/splice, `main`) at commit +`69b43eb761e38695052c983715aa855c8cb207fc`, packages under `token-standard/`. + +Two local patches were applied before building (source unchanged otherwise): + +- `sdk-version: 3.5.2` -> `3.5.1` in each `daml.yaml` (3.5.2 is not distributed; + 3.5.1 is the closest dpm-sdk available locally). Built with `dpm build`. + All packages target LF 2.1. +- data-dependency DAR names `-current.dar` -> `-1.0.0.dar` (the splice CI renames + package versions to `current`; a plain build emits the versioned name). + +Token Standard V2 (CIP-0112) is devnet-stage upstream. When upstream cuts a +release, replace these DARs with the released artifacts and re-validate; package +ids will change. + +To rebuild: copy the 13 package directories to a scratch area, apply the two +patches above, and `dpm build` them in dependency order (metadata-v1 first, +`splice-token-standard-utils` last). diff --git a/dars/token-standard/splice-api-token-allocation-instruction-v1-1.0.0.dar b/dars/token-standard/splice-api-token-allocation-instruction-v1-1.0.0.dar new file mode 100644 index 0000000..e143cbe Binary files /dev/null and b/dars/token-standard/splice-api-token-allocation-instruction-v1-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-allocation-instruction-v2-1.0.0.dar b/dars/token-standard/splice-api-token-allocation-instruction-v2-1.0.0.dar new file mode 100644 index 0000000..64bc8ab Binary files /dev/null and b/dars/token-standard/splice-api-token-allocation-instruction-v2-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-allocation-request-v1-1.0.0.dar b/dars/token-standard/splice-api-token-allocation-request-v1-1.0.0.dar new file mode 100644 index 0000000..5f43e5e Binary files /dev/null and b/dars/token-standard/splice-api-token-allocation-request-v1-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-allocation-request-v2-1.0.0.dar b/dars/token-standard/splice-api-token-allocation-request-v2-1.0.0.dar new file mode 100644 index 0000000..d6c77aa Binary files /dev/null and b/dars/token-standard/splice-api-token-allocation-request-v2-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-allocation-v1-1.0.0.dar b/dars/token-standard/splice-api-token-allocation-v1-1.0.0.dar new file mode 100644 index 0000000..5b42190 Binary files /dev/null and b/dars/token-standard/splice-api-token-allocation-v1-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-allocation-v2-1.0.0.dar b/dars/token-standard/splice-api-token-allocation-v2-1.0.0.dar new file mode 100644 index 0000000..26bce4b Binary files /dev/null and b/dars/token-standard/splice-api-token-allocation-v2-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-holding-v1-1.0.0.dar b/dars/token-standard/splice-api-token-holding-v1-1.0.0.dar new file mode 100644 index 0000000..dec8be1 Binary files /dev/null and b/dars/token-standard/splice-api-token-holding-v1-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-holding-v2-1.0.0.dar b/dars/token-standard/splice-api-token-holding-v2-1.0.0.dar new file mode 100644 index 0000000..ebb4888 Binary files /dev/null and b/dars/token-standard/splice-api-token-holding-v2-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-metadata-v1-1.0.0.dar b/dars/token-standard/splice-api-token-metadata-v1-1.0.0.dar new file mode 100644 index 0000000..8730a77 Binary files /dev/null and b/dars/token-standard/splice-api-token-metadata-v1-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-transfer-events-v2-1.0.0.dar b/dars/token-standard/splice-api-token-transfer-events-v2-1.0.0.dar new file mode 100644 index 0000000..e61408d Binary files /dev/null and b/dars/token-standard/splice-api-token-transfer-events-v2-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-transfer-instruction-v1-1.0.0.dar b/dars/token-standard/splice-api-token-transfer-instruction-v1-1.0.0.dar new file mode 100644 index 0000000..84874f5 Binary files /dev/null and b/dars/token-standard/splice-api-token-transfer-instruction-v1-1.0.0.dar differ diff --git a/dars/token-standard/splice-api-token-transfer-instruction-v2-1.0.0.dar b/dars/token-standard/splice-api-token-transfer-instruction-v2-1.0.0.dar new file mode 100644 index 0000000..8dbeae8 Binary files /dev/null and b/dars/token-standard/splice-api-token-transfer-instruction-v2-1.0.0.dar differ diff --git a/dars/token-standard/splice-token-standard-utils-2.0.0.dar b/dars/token-standard/splice-token-standard-utils-2.0.0.dar new file mode 100644 index 0000000..e10fa74 Binary files /dev/null and b/dars/token-standard/splice-token-standard-utils-2.0.0.dar differ diff --git a/experiments/settlement/README.md b/experiments/settlement/README.md index 1614bee..60ffb12 100644 --- a/experiments/settlement/README.md +++ b/experiments/settlement/README.md @@ -6,6 +6,7 @@ privacy-aware application flows on Canton. | Path | Purpose | |---|---| | [`cip-0112/`](cip-0112/) | Experimental allocation, settlement, attestation, event, and seizure lifecycle | +| [`cip-0112-v2/`](cip-0112-v2/) | Token Standard V2-conformant settlement package built against the vendored upstream DARs ([`dars/token-standard/`](../../dars/token-standard/)); pins dpm-sdk 3.5.1 and carries its own co-located tests | | [`exemplar/`](exemplar/) | Regulated-settlement consumer composing Access Control, Pausable, and the settlement package | | [`fixtures/token-standard-v2/`](fixtures/token-standard-v2/) | Narrow local model of Token Standard V2 types used by the experiment | | [`test/`](test/) | Isolated Daml Script tests for the settlement package | diff --git a/experiments/settlement/cip-0112-v2/daml.yaml b/experiments/settlement/cip-0112-v2/daml.yaml new file mode 100644 index 0000000..9f227f4 --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml.yaml @@ -0,0 +1,34 @@ +sdk-version: 3.4.11 +name: openzeppelin-experimental-cip112-settlement-v2 +source: daml +version: 0.1.0 +dependencies: + - daml-prim + - daml-stdlib +data-dependencies: + # Vendored Token Standard V2 (CIP-0112) DARs; see dars/token-standard/PROVENANCE.md. + # The V2 interfaces are NOT part of any Daml SDK: they are plain Daml packages + # from the splice repo, compiled with dpm-sdk 3.5.1. They are consumed here + # cross-SDK from the repo's 3.4.11 baseline, which works because both sides + # target Daml-LF 2.1. + # Paths are relative to this daml.yaml (repo convention): builds have no + # repo-root anchor, and env-var interpolation would require per-machine setup. + - ../../../dars/token-standard/splice-api-token-metadata-v1-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-holding-v1-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-holding-v2-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-transfer-events-v2-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-allocation-v1-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-allocation-v2-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-transfer-instruction-v1-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-transfer-instruction-v2-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-allocation-instruction-v1-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-allocation-instruction-v2-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-allocation-request-v1-1.0.0.dar + - ../../../dars/token-standard/splice-api-token-allocation-request-v2-1.0.0.dar + - ../../../dars/token-standard/splice-token-standard-utils-2.0.0.dar +build-options: + # Pin the emitted Daml-LF to 2.1: it matches the vendored API DARs, the + # upstream splice packages (which target 2.1 even on newer SDKs), and the + # Canton 3.4.11 runtime baseline. Contract keys exist in no stable LF + # (2.1/2.2 reject them; only the experimental 2.dev compiles them). + - --target=2.1 diff --git a/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Allocation.daml b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Allocation.daml new file mode 100644 index 0000000..09ece6c --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Allocation.daml @@ -0,0 +1,467 @@ +-- | Allocation template implementing the Token Standard V2 `Allocation` +-- interface, with the package's D2 in-flight-seizure extension as +-- template-level choices. +module OpenZeppelin.Experimental.SettlementV2.Allocation where + +import DA.Action (when) +import DA.Assert (assertDeadlineExceeded, assertWithinDeadline) +import DA.Foldable (forA_) +import DA.List (dedupSort) +import DA.Map qualified as Map +import DA.Optional (fromOptional, isNone, isSome) +import DA.TextMap qualified as TextMap +import DA.Time (RelTime, addRelTime) + +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.TransferEventsV2 qualified as TransferEventsV2 +import Splice.TokenStandard.Utils + +import OpenZeppelin.Experimental.SettlementV2.Base +import OpenZeppelin.Experimental.SettlementV2.D1 +import OpenZeppelin.Experimental.SettlementV2.Holding + +-- | Per-allocation proof that the settlement factory ran its exact-cover +-- validation for this settlement and this authorizer's leg set. +-- +-- `Allocation_Settle` is a plain interface choice whose actor set is admin plus +-- executors — the same parties who drive a batch — so without this proof they +-- could settle allocations one at a time, bypassing both the cover check (and +-- thereby minting or burning value) and the D1 attestation gate. The factory +-- mints one of these per allocation and hands it over through the choice +-- context; the settle body consumes it. +-- +-- It carries only data the allocation's own stakeholders already have, so +-- fetching it does not divulge sibling allocations. +template BatchSettlementAuthorization with + admin : Party + settlement : AllocationV2.SettlementInfo + authorizer : HoldingV2.Account + transferLegSides : [AllocationV2.TransferLegSide] + complianceReference : Optional Text + -- ^ `Some` when the registry verified a D1 attestation for this batch; + -- this is the attestation's own reference, not an executor-supplied + -- string. + where + signatory admin + +-- | Admin-issued D2 sweep authority: the assignee may sweep seized locked +-- holdings, optionally scoped to one instrument and one seizure case, and +-- always bounded in time so a forgotten capability does not stay live. +template BurnerCapability with + admin : Party + assignee : Party + instrumentScope : Optional HoldingV2.InstrumentId + caseScope : Optional Text + -- ^ When set, this capability may only sweep a seizure whose case + -- reference matches, so one grant cannot be reused across cases. + expiresAt : Time + where + signatory admin + observer assignee + +-- | A ready-to-settle allocation backed by locked holdings. Iterated +-- settlement is unsupported: `nextIterationFunding` must be `None`, enforced +-- structurally so unsupported allocations cannot be created. +template TokenAllocation with + originalAllocationCid : Optional (ContractId AllocationV2.Allocation) + settlement : AllocationV2.SettlementInfo + allocation : AllocationV2.AllocationSpecification + lockedHoldingCids : [ContractId TokenHolding] + requestedAt : Time + -- ^ The wallet-supplied request time, retained so stale or replayed + -- allocate requests remain diagnosable after the fact. + createdAt : Time + expiresAt : Time + lockExpiresAt : Time + -- ^ When the funding lock expires. Strictly after `expiresAt`, so there + -- is always a window in which the admin's expiry path is guaranteed to + -- succeed before the authorizer can re-spend the funding. + d1ComplianceHook : Optional D1ComplianceHook + d2SeizureHook : Optional D2SeizureHook + maxSeizureExtension : RelTime + -- ^ Registry policy cap, stamped at creation: how far past the deadline a + -- seizure window may reach. Taking this from the choice argument would + -- leave the admin free to freeze funds forever. + requiredAttesterRegistryCid : Optional (ContractId TrustedAttesterRegistry) + -- ^ When set, a lawful-process sweep must present a `SeizureOrder` signed + -- by a party in this registry. + where + signatory allocation.admin, accountParties allocation.admin allocation.authorizer + observer settlement.executors + ensure isValidSettlementInfoV2 settlement + && isValidAllocationSpecificationV2 (const True) allocation + && isNone allocation.nextIterationFunding + && expiresAt < lockExpiresAt + -- A committed allocation with no settlement deadline can never be + -- withdrawn (the standard's own `ensureWithdrawIsAllowed` fails closed), + -- so refuse to create that shape at all. + && (not allocation.committed || isSome allocation.settlementDeadline) + + interface instance AllocationV2.Allocation for TokenAllocation where + view = AllocationV2.AllocationView with + originalAllocationCid + settlement + allocation + holdingCids = map (toInterfaceContractId @HoldingV2.Holding) lockedHoldingCids + createdAt + numIterations = 0 + expiresAt = Some expiresAt + availableActions = allocationAvailableActions this + meta = d2StatusMeta d2SeizureHook + + -- The contract observers (executors) see every lifecycle exercise + -- regardless of which actor subset invoked it. + allocation_settleExtraObservers _ = observer this + allocation_cancelExtraObservers _ = observer this + allocation_withdrawExtraObservers _ = observer this + + allocation_settleImpl self arg = do + archiveAndCheckActors self arg.actors [allocation.admin :: settlement.executors] + -- Re-checked here even when driven by the settlement factory: this + -- choice is also directly callable by admin plus executors. + forA_ allocation.settlementDeadline (assertWithinDeadline "allocation.settlementDeadline") + requireNoActiveD2Seizure d2SeizureHook + -- The factory's cover check and D1 gate are only enforceable if this + -- choice refuses to run without the factory's proof. + auth <- requireBatchAuthorization this arg.extraArgs.context + requireD1Reference d1ComplianceHook auth.complianceReference + validateNextIterationArgs "Allocation_Settle" False + arg.extraTransferLegSides arg.nextIterationFunding + settleAllocation this + + allocation_withdrawImpl self arg = do + archiveAndCheckActors self arg.actors [accountParties allocation.admin allocation.authorizer] + requireNoActiveD2Seizure d2SeizureHook + ensureWithdrawIsAllowed allocation + holdings <- unlockAndLog this "allocation withdrawn" + pure AllocationV2.AllocationResult with + output = AllocationV2.AllocationResult_Withdrawn + authorizerHoldingCids = holdings + meta = emptyMetadata + + allocation_cancelImpl self arg = do + requireNoActiveD2Seizure d2SeizureHook + -- Executors may cancel any time; the admin only once `expiresAt` has + -- passed (checked by the default implementation). + allocationV2_cancelDefaultImpl (toInterface this) self arg $ do + holdings <- unlockAndLog this "allocation cancelled" + pure (holdings, emptyMetadata) + + -- D2 extension: admin freezes the allocation pending seizure. Every + -- seizure carries an explicit lapse point (`seizureHook.windowEnd`); it + -- must lie in the future — a lapsed window would be releasable in the same + -- instant and freeze nothing — and within the registry's maximum extension + -- past the deadline. A window reaching past the settlement deadline is + -- only sweepable via the lawful-process choice. + choice TokenAllocation_MarkD2Seizure : ContractId TokenAllocation + with seizureHook : D2SeizureHook + controller allocation.admin + do + require "allocation is already under D2 seizure" (isNone d2SeizureHook) + requireDistinctCustodian allocation.admin seizureHook + -- A seizure is an in-flight measure, so it cannot be opened on an + -- allocation already past its deadline. + forA_ allocation.settlementDeadline (assertWithinDeadline "allocation.settlementDeadline") + assertWithinDeadline "seizureHook.windowEnd" seizureHook.windowEnd + let capBase = fromOptional expiresAt allocation.settlementDeadline + require "seizure window exceeds the registry's maximum extension" + (seizureHook.windowEnd <= capBase `addRelTime` maxSeizureExtension) + create this with + d2SeizureHook = Some seizureHook + originalAllocationCid = Some (allocationChainRoot this self) + + -- Admin releases a seizure that will not be swept; the normal lifecycle + -- resumes. Without this, an unswept mark would strand the locked funds. + choice TokenAllocation_UnmarkD2Seizure : ContractId TokenAllocation + controller allocation.admin + do + _ <- requireD2Seizure d2SeizureHook + create this with + d2SeizureHook = None + originalAllocationCid = Some (allocationChainRoot this self) + + -- Any stakeholder may release a seizure whose window has lapsed, so an + -- abandoned mark cannot strand the funds pending admin action. The window + -- is mandatory on the hook, so the lapse point always exists. + choice TokenAllocation_ReleaseLapsedD2Seizure : ContractId TokenAllocation + with actor : Party + -- ^ Any single stakeholder may act; a controller list would be a + -- conjunction requiring all of them, which defeats the purpose. + controller actor + do + require "actor must be a stakeholder of the allocation" + (actor `elem` allocationStakeholders this) + hook <- requireD2Seizure d2SeizureHook + assertDeadlineExceeded "seizureHook.windowEnd" hook.windowEnd + create this with + d2SeizureHook = None + originalAllocationCid = Some (allocationChainRoot this self) + + -- Sweep seized locked holdings to the preset custodian destination. The + -- burner must present an admin-issued capability naming them; destination + -- account parties co-sign because they become signatories of the created + -- holdings. Must land within both the settlement deadline and the seizure + -- window; only the lawful-process sweep may act past the deadline. + choice TokenAllocation_SweepD2Seizure : TextMap.TextMap [ContractId HoldingV2.Holding] + with + burner : Party + burnerCapCid : ContractId BurnerCapability + controller d2SweepControllers allocation.admin d2SeizureHook burner + do + hook <- requireD2Seizure d2SeizureHook + forA_ allocation.settlementDeadline (assertWithinDeadline "allocation.settlementDeadline") + assertWithinDeadline "seizureHook.windowEnd" hook.windowEnd + sweepToCustodian this hook burner burnerCapCid hook.seizureCaseRef + + -- Sweep under a lawful-process order signed by a non-admin authority in the + -- registry's trusted set; honours the seizure window alone, so it is the + -- only path allowed to seize past the settlement deadline. + choice TokenAllocation_SweepD2WithLawfulProcess : TextMap.TextMap [ContractId HoldingV2.Holding] + with + burner : Party + burnerCapCid : ContractId BurnerCapability + seizureOrderCid : ContractId SeizureOrder + controller d2SweepControllers allocation.admin d2SeizureHook burner + do + hook <- requireD2Seizure d2SeizureHook + assertWithinDeadline "seizureHook.windowEnd" hook.windowEnd + -- The order is the anchor: a free-text reference chosen by the admin + -- proved nothing about lawful process. + requireSeizureOrder requiredAttesterRegistryCid seizureOrderCid + allocation.admin allocation.authorizer hook.custodianDestination + sweepToCustodian this hook burner burnerCapCid hook.seizureCaseRef + + -- | Last-resort admin cleanup for an allocation whose funding was already + -- reclaimed elsewhere (the authorizer re-spent it as an expired-lock input, + -- or self-unlocked it), which makes every fund-returning path fail on the + -- archived holding. Only available once the funding lock has expired, by + -- which time the authorizer can always recover the holding themselves via + -- `TokenHolding_OwnerUnlock`, so this can never strand funds. + choice TokenAllocation_AdminGC : () + controller allocation.admin + do assertDeadlineExceeded "allocation lockExpiresAt" lockExpiresAt + + +-- View helpers +--------------- + +-- | Every party with a stake in the allocation: admin, the authorizer's account +-- parties, and the executors. +allocationStakeholders : TokenAllocation -> [Party] +allocationStakeholders this = dedupSort $ + this.allocation.admin + :: (accountParties this.allocation.admin this.allocation.authorizer <> this.settlement.executors) + +-- | Actions wallets may take, reported to exactly match what the choice bodies +-- accept. The standard's default helper advertises withdraw for the account +-- principal alone, but withdrawing re-creates the holding, whose signatories +-- include every account party — so the joint set is what the implementation +-- requires and therefore what must be advertised. +allocationAvailableActions + : TokenAllocation -> Map.Map AllocationV2.AllocationAction [[Party]] +allocationAvailableActions this + -- While a seizure is active, settle, withdraw and cancel all fail. Reporting + -- them would send wallets into guaranteed-failing submissions. + | isSome this.d2SeizureHook = Map.empty + | otherwise = Map.fromList $ + [ (AllocationV2.AA_Cancel, [dedupSort this.settlement.executors]) + , (AllocationV2.AA_Settle, [dedupSort (this.allocation.admin :: this.settlement.executors)]) + ] <> + [ (AllocationV2.AA_Withdraw, [accountParties this.allocation.admin this.allocation.authorizer]) + | not this.allocation.committed || isSome this.allocation.settlementDeadline + ] + + +-- Settlement internals +----------------------- + +-- | Read and consume the factory's per-allocation authorization, checking it +-- covers exactly this allocation's settlement, authorizer and leg set. +requireBatchAuthorization + : TokenAllocation -> ChoiceContext -> Update BatchSettlementAuthorization +requireBatchAuthorization this context = do + authCid <- case TextMap.lookup batchAuthorizationContextKey context.values of + Some (AV_ContractId anyCid) -> + pure (fromAnyContractId anyCid : ContractId BatchSettlementAuthorization) + Some _ -> fail "batch authorization context value must be a contract id" + None -> fail + "Allocation_Settle requires the settlement factory's batch authorization; \ + \settle through SettlementFactory_SettleBatch" + auth <- fetch authCid + archive authCid + require' ("authorization.admin", auth.admin) isEqualR ("allocation.admin", this.allocation.admin) + require' ("authorization.settlement", auth.settlement) isEqualR ("allocation.settlement", this.settlement) + require' ("authorization.authorizer", auth.authorizer) + isEqualR ("allocation.authorizer", this.allocation.authorizer) + require' ("authorization.transferLegSides", dedupSort auth.transferLegSides) + isEqualR ("allocation.transferLegSides", dedupSort this.allocation.transferLegSides) + pure auth + +-- | Net settlement of one allocation: consume the locked funds, add the +-- authorizer's net credit per instrument, require every total to be +-- non-negative (an under-funded sender fails closed), and pay out the +-- positive totals as fresh unlocked holdings. +settleAllocation : TokenAllocation -> Update AllocationV2.AllocationResult +settleAllocation this = do + let admin = this.allocation.admin + authorizer = this.allocation.authorizer + lockedAmounts <- debitHoldings (fetchAndArchiveLockedHolding admin authorizer) this.lockedHoldingCids + let netAmounts = netAllocationCreditAmounts authorizer this.allocation.transferLegSides + payoutAmounts = textMapUnionWith (+) lockedAmounts netAmounts + payouts <- forA (TextMap.toList payoutAmounts) $ \(instrumentId, amount) -> do + require' ("locked funds plus net credit for " <> instrumentId, amount) + isGreaterOrEqualR ("zero", 0.0) + if amount > 0.0 + then do + cid <- createTokenHolding admin authorizer instrumentId amount None + pure [(instrumentId, [toInterfaceContractId @HoldingV2.Holding cid])] + else pure [] + let payoutCids = TextMap.fromListWithR (++) (concat payouts) + emitHoldingsChange admin authorizer this.settlement.executors + (map toInterfaceContractId this.lockedHoldingCids) + (concat (textMapValues payoutCids)) + (map toEventLegSide this.allocation.transferLegSides) + "allocation settled" + pure AllocationV2.AllocationResult with + output = AllocationV2.AllocationResult_Settled with nextIterationAllocationCid = None + authorizerHoldingCids = payoutCids + meta = emptyMetadata + +-- | Release the locked holdings to the authorizer and log the change. +unlockAndLog : TokenAllocation -> Text -> Update (TextMap.TextMap [ContractId HoldingV2.Holding]) +unlockAndLog this reason = do + let admin = this.allocation.admin + holdings <- unlockHoldings admin this.allocation.authorizer this.lockedHoldingCids + emitHoldingsChange admin this.allocation.authorizer this.settlement.executors + (map toInterfaceContractId this.lockedHoldingCids) + (concat (textMapValues holdings)) + [] + reason + pure holdings + +-- | The first allocation contract of this lifecycle, for wallet correlation +-- across state changes. +allocationChainRoot : TokenAllocation -> ContractId TokenAllocation -> ContractId AllocationV2.Allocation +allocationChainRoot this self = + fromOptional (toInterfaceContractId @AllocationV2.Allocation self) this.originalAllocationCid + +toEventLegSide : AllocationV2.TransferLegSide -> TransferEventsV2.TransferLegSide +toEventLegSide s = TransferEventsV2.TransferLegSide with + transferLegId = s.transferLegId + side = case s.side of + AllocationV2.SenderSide -> TransferEventsV2.SenderSide + AllocationV2.ReceiverSide -> TransferEventsV2.ReceiverSide + otherside = s.otherside + amount = s.amount + instrumentId = s.instrumentId + meta = s.meta + + +-- D1/D2 guards +--------------- + +requireNoActiveD2Seizure : Optional D2SeizureHook -> Update () +requireNoActiveD2Seizure hook = + require "allocation is under an active D2 in-flight seizure" (isNone hook) + +requireD2Seizure : Optional D2SeizureHook -> Update D2SeizureHook +requireD2Seizure hook = case hook of + None -> fail "no active D2 in-flight seizure on this allocation" + Some h -> pure h + +-- | A seizure whose custodian destination resolves to the admin itself would +-- leave the admin as the only required authorizer of the sweep (the +-- destination's parties are what force a second signature), turning D2 into +-- unilateral confiscation. +requireDistinctCustodian : Party -> D2SeizureHook -> Update () +requireDistinctCustodian admin hook = do + require "custodian destination must be a regular account" + (isSome hook.custodianDestination.owner) + require "custodian destination must not be the admin's own account" + (accountPrincipal admin hook.custodianDestination /= admin) + +-- | When the registry stamps a D1 hook requiring a per-settlement reference, +-- the batch authorization must carry the verified attestation's reference. It +-- is taken from the attestation rather than from executor-supplied choice +-- metadata, which the executors could fill with anything. +requireD1Reference : Optional D1ComplianceHook -> Optional Text -> Update () +requireD1Reference hook complianceReference = forA_ hook $ \h -> + when h.requiresPerSettlementReference $ + case complianceReference of + Some ref | ref /= "" -> pure () + _ -> fail "D1 compliance reference required from a verified attestation" + + +-- D2 sweep internals +--------------------- + +-- | Sweep controllers: the burner plus the custodian destination's account +-- parties (excluding the admin, who already signs via the allocation). The +-- destination parties' authority covers only the creation of their holdings; +-- seizure authority itself is the BurnerCapability. With no hook the set is the +-- admin alone, so a caller cannot name itself into a controller position on a +-- choice that will fail anyway. +d2SweepControllers : Party -> Optional D2SeizureHook -> Party -> [Party] +d2SweepControllers admin hook burner = case hook of + None -> [admin] + Some h -> burner :: filter (/= admin) (accountParties admin h.custodianDestination) + +fetchBurnerCapability : Party -> Party -> Text -> ContractId BurnerCapability -> Update BurnerCapability +fetchBurnerCapability burner expectedAdmin caseRef capCid = do + cap <- fetch capCid + require' ("burnerCapability.admin", cap.admin) isEqualR ("allocation.admin", expectedAdmin) + require' ("burnerCapability.assignee", cap.assignee) isEqualR ("burner", burner) + assertWithinDeadline "burnerCapability.expiresAt" cap.expiresAt + forA_ cap.caseScope $ \scope -> + require' ("burnerCapability.caseScope", scope) isEqualR ("seizure caseRef", caseRef) + pure cap + +sweepToCustodian + : TokenAllocation -> D2SeizureHook -> Party -> ContractId BurnerCapability -> Text + -> Update (TextMap.TextMap [ContractId HoldingV2.Holding]) +sweepToCustodian this hook burner burnerCapCid caseRef = do + let admin = this.allocation.admin + cap <- fetchBurnerCapability burner admin caseRef burnerCapCid + requireDistinctCustodian admin hook + swept <- forA (zip [0 .. length this.lockedHoldingCids - 1] this.lockedHoldingCids) $ \(i, cid) -> do + h <- fetchAndArchiveLockedHoldingHeldBy admin this.allocation.authorizer + (dedupSort (admin :: this.settlement.executors)) cid + require "burner capability scope must authorize the holding's instrument" + (burnerScopeAuthorizes cap.instrumentScope h.holding.instrumentId) + newCid <- createTokenHolding admin hook.custodianDestination h.holding.instrumentId.id h.holding.amount None + -- A sweep moves value between accounts, so each event must carry matching + -- legs: reporting it with an empty leg list would break the standard's + -- requirement that an account's net leg balance equal its holdings change. + let legId = ozNamespace <> "d2-sweep/" <> caseRef <> "/" <> show i + legSide side otherside = TransferEventsV2.TransferLegSide with + transferLegId = legId + side + otherside + amount = h.holding.amount + instrumentId = h.holding.instrumentId.id + meta = emptyMetadata + pure + ( (h.holding.instrumentId.id, [toInterfaceContractId @HoldingV2.Holding newCid]) + , ( legSide TransferEventsV2.SenderSide hook.custodianDestination + , legSide TransferEventsV2.ReceiverSide this.allocation.authorizer + ) + , toInterfaceContractId @HoldingV2.Holding newCid + ) + let custodianCids = TextMap.fromListWithR (++) (map (._1) swept) + senderLegs = map (\s -> s._2._1) swept + receiverLegs = map (\s -> s._2._2) swept + createdCids = map (._3) swept + -- Events are per-account: one for the authorizer's consumed holdings, one + -- for the custodian's created holdings. + emitHoldingsChange admin this.allocation.authorizer this.settlement.executors + (map toInterfaceContractId this.lockedHoldingCids) [] senderLegs "D2 in-flight seizure sweep" + emitHoldingsChange admin hook.custodianDestination this.settlement.executors + [] createdCids receiverLegs "D2 in-flight seizure sweep" + pure custodianCids + +burnerScopeAuthorizes : Optional HoldingV2.InstrumentId -> HoldingV2.InstrumentId -> Bool +burnerScopeAuthorizes scope instrumentId = case scope of + None -> True + Some s -> s == instrumentId diff --git a/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/AllocationRequest.daml b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/AllocationRequest.daml new file mode 100644 index 0000000..7ddc452 --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/AllocationRequest.daml @@ -0,0 +1,79 @@ +-- | App-side allocation request: a settlement app creates this contract +-- directly to ask a single authorizer to create allocations for a settlement. +-- Accept and reject consume the whole request, so a request speaks for exactly +-- one authorizer account; apps create one request per authorizer, as in the +-- splice reference trading app. The registry is not involved; accepting is a +-- signal, and creating the actual allocations is a separate step wallets may +-- batch into the same transaction. +module OpenZeppelin.Experimental.SettlementV2.AllocationRequest where + +import DA.List (dedupSort) +import DA.Map qualified as Map + +import Splice.Api.Token.MetadataV1 +import Splice.Api.Token.AllocationV2 qualified as AllocationV2 +import Splice.Api.Token.AllocationRequestV2 qualified as AllocationRequestV2 +import Splice.TokenStandard.Utils + +template TokenAllocationRequest with + settlement : AllocationV2.SettlementInfo + allocations : [AllocationV2.AllocationSpecification] + -- ^ The authorizer's legs; several allocations when they span multiple + -- instrument admins, but all with the same authorizer account. + requestedAt : Time + settleAt : Optional Time + where + signatory settlement.executors + -- The request signals the authorizer to allocate, so their account + -- parties must see it. + observer requestAuthorizerParties allocations + ensure isValidSettlementInfoV2 settlement + && not (null allocations) + -- Accept/reject archive the whole request, so it can only speak for one + -- authorizer: a request spanning authorizers would be consumed by + -- whoever acts first, leaving the others unable to respond. + && length (dedupSort (map (.authorizer) allocations)) == 1 + && all (isRegularAccount . (.authorizer)) allocations + -- Temporal coherence: a request must not ask for allocations whose + -- settlement deadline precedes the request itself or the expected + -- settlement time, which no authorizer could ever satisfy. + && optional True (requestedAt <=) settleAt + && all (optional True (\d -> requestedAt <= d && optional True (<= d) settleAt) + . (.settlementDeadline)) allocations + + interface instance AllocationRequestV2.AllocationRequest for TokenAllocationRequest where + view = AllocationRequestV2.AllocationRequestView with + originalRequestCid = None + settlement + allocations + requestedAt + settleAt + availableActions = Map.fromList + [ (AllocationRequestV2.ARA_Accept, requestActorSets allocations) + , (AllocationRequestV2.ARA_Reject, requestActorSets allocations) + ] + meta = emptyMetadata + + allocationRequest_acceptExtraObservers _ = observer this + allocationRequest_rejectExtraObservers _ = observer this + allocationRequest_withdrawExtraObservers _ = observer this + + allocationRequest_acceptImpl self arg = do + archiveAndCheckActors self arg.actors (requestActorSets allocations) + pure AllocationRequestV2.AllocationRequest_AcceptResult with meta = emptyMetadata + + allocationRequest_rejectImpl self arg = do + archiveAndCheckActors self arg.actors (requestActorSets allocations) + pure AllocationRequestV2.AllocationRequest_RejectResult with meta = emptyMetadata + + allocationRequest_withdrawImpl self arg = do + archiveAndCheckActors self arg.actors [settlement.executors] + pure AllocationRequestV2.AllocationRequest_WithdrawResult with meta = emptyMetadata + +-- | Account parties of the request's single authorizer. +requestAuthorizerParties : [AllocationV2.AllocationSpecification] -> [Party] +requestAuthorizerParties = dedupSort . concatMap (regularAccountParties . (.authorizer)) + +-- | Any single account party of the authorizer may accept or reject. +requestActorSets : [AllocationV2.AllocationSpecification] -> [[Party]] +requestActorSets allocations = [[p] | p <- requestAuthorizerParties allocations] diff --git a/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Base.daml b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Base.daml new file mode 100644 index 0000000..a446e32 --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Base.daml @@ -0,0 +1,127 @@ +-- | Shared basics for the CIP-0112 settlement package: D1/D2 extension hooks, +-- event-log host, and helpers used across modules. Interface packages are the +-- vendored Token Standard V2 DARs (see dars/token-standard/PROVENANCE.md). +module OpenZeppelin.Experimental.SettlementV2.Base where + +import DA.TextMap qualified as TextMap +import DA.Time (RelTime, addRelTime, subTime) + +import Splice.Api.Token.MetadataV1 -- TSv2 reuses MetadataV1, and does not declare a MetadataV2. +import Splice.Api.Token.HoldingV2 qualified as HoldingV2 +import Splice.Api.Token.TransferEventsV2 qualified as TransferEventsV2 +import Splice.TokenStandard.Utils + +-- | Namespace for this package's metadata and choice-context keys. +ozNamespace : Text +ozNamespace = "openzeppelin.com/" + +-- | D1 compliance hook: when present with +-- `requiresPerSettlementReference`, settlement must carry a compliance +-- reference in the choice metadata under `d1ReferenceMetaKey`. +data D1ComplianceHook = D1ComplianceHook with + hookRef : Text + requiresPerSettlementReference : Bool + deriving (Eq, Show) + +-- | D2 in-flight seizure hook: set by the admin on an allocation to freeze it +-- until swept to the custodian destination or unmarked. +data D2SeizureHook = D2SeizureHook with + seizureCaseRef : Text + custodianDestination : HoldingV2.Account + inFlightHandlingStatus : Text + windowEnd : Time + -- ^ When the seizure lapses: sweeps must land before it, and once it + -- passes any single stakeholder may release the mark. Mandatory, so no + -- seizure can exist without a definite lapse point — an optional window + -- combined with an absent settlement deadline used to leave the lapse + -- check vacuous, making the freeze releasable the instant it was placed. + deriving (Eq, Show) + +d1ReferenceMetaKey : Text +d1ReferenceMetaKey = ozNamespace <> "d1-compliance-reference" + +d1AttestationContextKey : Text +d1AttestationContextKey = ozNamespace <> "d1-attestation" + +-- | Choice-context key under which the settlement factory hands each +-- per-allocation settle a proof that the batch cover check ran. Direct +-- `Allocation_Settle` calls cannot forge it: the proof contract is created by +-- the factory and is signed by the admin. +batchAuthorizationContextKey : Text +batchAuthorizationContextKey = ozNamespace <> "batch-settlement-authorization" + +d2StatusMetaKey : Text +d2StatusMetaKey = ozNamespace <> "d2-status" + +-- | Opaque marker for an active D2 seizure. The view is visible to the +-- seizure's subject and to every executor, so it carries no case data: the +-- case reference, custodian destination, and handling status stay on the +-- allocation payload, readable only by its stakeholders' admin-side tooling. +d2HeldStatus : Text +d2HeldStatus = "held" + +-- | An active D2 seizure is surfaced to wallets through view metadata: the +-- interface view record is fixed, so namespaced metadata is the only +-- extension channel. +d2StatusMeta : Optional D2SeizureHook -> Metadata +d2StatusMeta hook = case hook of + None -> emptyMetadata + Some _ -> Metadata with values = TextMap.fromList [(d2StatusMetaKey, d2HeldStatus)] + +-- | Event-log host. `EventLog_HoldingsChange` is an interface choice, so an +-- emission needs a contract to exercise it on; this host is created and +-- archived within the emitting transaction. The event data lives in the +-- exercise node, which its observers see regardless of the host's archival. +template TokenEventLog with + admin : Party + where + signatory admin + + interface instance TransferEventsV2.EventLog for TokenEventLog where + view = TransferEventsV2.EventLogView with admin; meta = emptyMetadata + eventLog_holdingsChangeImpl = eventLog_holdingsChangeDefaultImpl admin + +-- | Run an action with a temporary event-log host. Requires `admin` authority: +-- every caller in this package emits from a choice on a contract that has the +-- admin as signatory. +withTempEventLog : Party -> (ContractId TransferEventsV2.EventLog -> Update a) -> Update a +withTempEventLog admin f = do + cid <- create TokenEventLog with admin + result <- f (toInterfaceContractId cid) + archive cid + pure result + +-- | Emit a holdings-change event. `logHoldingsChange` suppresses events that +-- are empty or on special (mint/burn) accounts. +emitHoldingsChange + : Party + -> HoldingV2.Account + -> [Party] + -> [ContractId HoldingV2.Holding] + -> [ContractId HoldingV2.Holding] + -> [TransferEventsV2.TransferLegSide] + -> Text + -> Update () +emitHoldingsChange admin account executors inputs outputs legSides reason = + withTempEventLog admin $ \eventLogCid -> + logHoldingsChange eventLogCid TransferEventsV2.EventLog_HoldingsChange with + admin + account + inputHoldingCids = inputs + outputHoldingCids = outputs + transferLegSides = legSides + observers = accountParties admin account <> executors + extraArgs = ExtraArgs with + context = emptyChoiceContext + meta = reasonToMeta reason emptyMetadata + +-- | Storage bound for a pending contract (allocation or transfer instruction): +-- at most `maxTTL` from now, capped by the workflow deadline, saturating at +-- `maxTime` instead of overflowing. +computeStorageExpiry : RelTime -> Time -> Optional Time -> Time +computeStorageExpiry maxTTL now deadline = + optional identity min deadline candidate + where + candidate + | maxTime `subTime` now <= maxTTL = maxTime + | otherwise = now `addRelTime` maxTTL diff --git a/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/D1.daml b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/D1.daml new file mode 100644 index 0000000..bd4a799 --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/D1.daml @@ -0,0 +1,168 @@ +-- | D1 typed node-compliance attestation: a trusted node signs an attestation +-- covering one settlement and exactly its transfer legs; batch settlement +-- verifies and consumes it. Also hosts the D2 seizure order, the non-admin +-- authority artifact the lawful-process sweep must present. +-- +-- The attestation binds the legs' full economic content (accounts, amounts, +-- instruments), not just their ids: the executors choose the ids, so an +-- id-only binding would let them re-point an attestation at a different trade. +module OpenZeppelin.Experimental.SettlementV2.D1 where + +import DA.Foldable (forA_) +import DA.List (dedupSort) +import DA.Time (RelTime, addRelTime) + +import Splice.Api.Token.HoldingV2 qualified as HoldingV2 +import Splice.Api.Token.AllocationV2 qualified as AllocationV2 +import Splice.TokenStandard.Utils + +-- | On-ledger trust anchor: the parties the admin accepts as compliance +-- attesters, and the claim kinds that count as a pass. Attesters are updated +-- in place so the cid pinned on the rules contract stays valid. +template TrustedAttesterRegistry with + admin : Party + attesters : [Party] + acceptedClaimKinds : [Text] + -- ^ A verified attestation must carry one of these; otherwise a + -- "sanctions-hit" attestation would pass the gate as readily as an + -- approval. + where + signatory admin + observer attesters + ensure not (null attesters) + && attesters == dedupSort attesters + && not (null acceptedClaimKinds) + && "" `notElem` acceptedClaimKinds + + -- | Rotate the trusted set without changing the contract id, so the + -- `requiredAttesterRegistryCid` pinned on `TokenRules` keeps + -- resolving. Archive-and-recreate would dangle that pin and force + -- re-creating the rules contract and re-distributing its disclosure. + choice TrustedAttesterRegistry_Update : ContractId TrustedAttesterRegistry + with + newAttesters : [Party] + newAcceptedClaimKinds : [Text] + controller admin + do create this with + attesters = dedupSort newAttesters + acceptedClaimKinds = newAcceptedClaimKinds + +-- | A signed compliance attestation. Its existence proves the attester signed +-- it; verification is a consuming choice, so one attestation authorizes +-- exactly one settlement of exactly one leg set. +template ComplianceAttestation with + attester : Party + attestationObservers : [Party] + settlementId : Text + authorizedExecutors : [Party] + -- ^ The executors this attestation is issued to. Also the verify + -- controller: deriving the controller from a choice argument would let + -- any observer name itself and burn the attestation. + claimKind : Text + complianceReference : Text + -- ^ The reference the per-allocation settle must carry, so the + -- registry-wide attestation and the per-allocation metadata are the + -- same fact rather than two unrelated strings. + issuedAt : Time + expiresAt : Time + boundTransferLegs : [AllocationV2.TransferLeg] + -- ^ The exact legs authorized: senders, receivers, amounts and + -- instruments, not merely leg ids. + where + signatory attester + observer dedupSort (attestationObservers <> authorizedExecutors) + ensure issuedAt < expiresAt + && not (null boundTransferLegs) + && not (null authorizedExecutors) + && claimKind /= "" + && complianceReference /= "" + + -- Controlled by the pre-authorized executors (signed off by the attester); + -- the settlement factory supplies that authority after checking its own + -- actors. + choice ComplianceAttestation_Verify : Text + with + settlement : AllocationV2.SettlementInfo + transferLegs : [AllocationV2.TransferLeg] + registryCid : ContractId TrustedAttesterRegistry + factoryAdmin : Party + maxValidity : RelTime + controller authorizedExecutors + do + registry <- fetch registryCid + -- A caller-supplied registry whose admin is not the settling factory's + -- admin is rejected: trust is rooted in the factory admin's registry. + require' ("registry.admin", registry.admin) isEqualR ("factoryAdmin", factoryAdmin) + require "attestation signer must be in the trusted-attester registry" + (attester `elem` registry.attesters) + require "attestation claim kind must be accepted by the registry" + (claimKind `elem` registry.acceptedClaimKinds) + require' ("attestation.settlementId", settlementId) isEqualR ("settlement.id", settlement.id) + -- Pin the executors, so an attestation issued to one app cannot be + -- spent by another. + require' ("attestation.authorizedExecutors", dedupSort authorizedExecutors) + isEqualR ("settlement.executors", dedupSort settlement.executors) + -- Exact content binding: same legs, same order-independent set, with + -- amounts, accounts and instruments all covered by TransferLeg's Eq. + require' ("attestation.boundTransferLegs", dedupSort boundTransferLegs) + isEqualR ("settlement transfer legs", dedupSort transferLegs) + -- Attester-chosen windows are bounded by registry policy so a single + -- attestation cannot be indefinitely re-usable in principle. + require "attestation validity window exceeds the registry maximum" + (expiresAt <= issuedAt `addRelTime` maxValidity) + now <- getTime + require "attestation is not yet valid" (now >= issuedAt) + require "attestation has expired" (now <= expiresAt) + pure complianceReference + +-- | Non-admin authority for a D2 lawful-process sweep. The admin cannot sign +-- this: without it, `lawfulProcessRef` was an arbitrary admin-chosen string +-- anchored to nothing. +template SeizureOrder with + authority : Party + admin : Party + caseRef : Text + subjectAccount : HoldingV2.Account + custodianDestination : HoldingV2.Account + expiresAt : Time + where + signatory authority + observer admin + ensure caseRef /= "" + + -- | Consumed by the sweep, so one order authorizes one seizure. + choice SeizureOrder_Verify : Text + with + registryCid : ContractId TrustedAttesterRegistry + expectedAdmin : Party + expectedSubject : HoldingV2.Account + expectedCustodian : HoldingV2.Account + controller admin + do + registry <- fetch registryCid + require' ("registry.admin", registry.admin) isEqualR ("expectedAdmin", expectedAdmin) + require "seizure authority must be in the trusted registry" + (authority `elem` registry.attesters) + require' ("order.admin", admin) isEqualR ("expectedAdmin", expectedAdmin) + require' ("order.subjectAccount", subjectAccount) isEqualR ("allocation authorizer", expectedSubject) + require' ("order.custodianDestination", custodianDestination) + isEqualR ("hook.custodianDestination", expectedCustodian) + now <- getTime + require "seizure order has expired" (now <= expiresAt) + pure caseRef + +-- | Verify a seizure order when the registry requires one; `None` means the +-- registry is not configured for attested seizure. +requireSeizureOrder + : Optional (ContractId TrustedAttesterRegistry) + -> ContractId SeizureOrder + -> Party -> HoldingV2.Account -> HoldingV2.Account + -> Update () +requireSeizureOrder registryCidOpt orderCid admin subject custodian = + forA_ registryCidOpt $ \registryCid -> do + _ <- exercise orderCid SeizureOrder_Verify with + registryCid + expectedAdmin = admin + expectedSubject = subject + expectedCustodian = custodian + pure () diff --git a/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Holding.daml b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Holding.daml new file mode 100644 index 0000000..f131e28 --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Holding.daml @@ -0,0 +1,128 @@ +-- | Holding template for the CIP-0112 settlement package. +module OpenZeppelin.Experimental.SettlementV2.Holding where + +import DA.Assert (assertDeadlineExceeded) +import DA.Foldable (forA_) +import DA.List (dedupSort) +import DA.Optional (isNone, isSome) +import DA.TextMap qualified as TextMap + +import Splice.Api.Token.MetadataV1 +import Splice.Api.Token.HoldingV2 qualified as HoldingV2 +import Splice.TokenStandard.Utils + +-- | A holding is maintained jointly by the instrument admin and the account +-- parties. Lock holders observe the contract so they can settle or release the +-- locked funds. Regular accounts only: special (ownerless) accounts never hold. +template TokenHolding with + holding : HoldingV2.HoldingView + where + signatory holding.instrumentId.admin, accountParties holding.instrumentId.admin holding.account + observer lockHolders holding.lock + ensure holding.amount > 0.0 + && isSome holding.account.owner + -- `expiresAfter` would make the effective lock expiry the earlier of the + -- two bounds (HoldingV2.Lock), which this package's expiry checks do not + -- model. Reject it at creation rather than mis-handle it later. + && optional True (isNone . (.expiresAfter)) holding.lock + + -- | Reclaim a holding whose lock has expired, without routing it through a + -- transfer or allocation. Without this, a locked holding whose referencing + -- workflow contract was garbage-collected would be unrecoverable, since + -- nothing else can clear a lock. + choice TokenHolding_OwnerUnlock : ContractId TokenHolding + controller accountParties holding.instrumentId.admin holding.account + do + lock <- case holding.lock of + None -> fail "holding is not locked" + Some l -> pure l + case lock.expiresAt of + None -> fail "holding is locked indefinitely and cannot be unlocked by its owner" + Some expiresAt -> assertDeadlineExceeded "lock expiresAt" expiresAt + create this with holding = holding with lock = None + + interface instance HoldingV2.Holding for TokenHolding where + view = holding + +lockHolders : Optional HoldingV2.Lock -> [Party] +lockHolders lock = case lock of + None -> [] + Some l -> l.holders + +createTokenHolding + : Party -> HoldingV2.Account -> Text -> Decimal -> Optional HoldingV2.Lock + -> Update (ContractId TokenHolding) +createTokenHolding admin account instrumentId amount lock = + create TokenHolding with + holding = HoldingV2.HoldingView with + account + instrumentId = HoldingV2.InstrumentId with admin; id = instrumentId + amount + lock + meta = emptyMetadata + +-- | Consume a locked input holding after validating its identity. +fetchAndArchiveLockedHolding + : Party -> HoldingV2.Account -> ContractId TokenHolding -> Update TokenHolding +fetchAndArchiveLockedHolding admin expectedAccount cid = do + h <- fetch cid + require' ("inputHolding.instrumentId.admin", h.holding.instrumentId.admin) isEqualR ("admin", admin) + require' ("inputHolding.account", h.holding.account) isEqualR ("expectedAccount", expectedAccount) + require "input holding must be locked" (isSome h.holding.lock) + archive cid + pure h + +-- | As `fetchAndArchiveLockedHolding`, but also pins the lock's holder set, so +-- a holding locked for some other workflow cannot be consumed here. Used where +-- the caller knows exactly which holders its own lock carries. +fetchAndArchiveLockedHoldingHeldBy + : Party -> HoldingV2.Account -> [Party] -> ContractId TokenHolding -> Update TokenHolding +fetchAndArchiveLockedHoldingHeldBy admin expectedAccount expectedHolders cid = do + h <- fetch cid + require' ("inputHolding.instrumentId.admin", h.holding.instrumentId.admin) isEqualR ("admin", admin) + require' ("inputHolding.account", h.holding.account) isEqualR ("expectedAccount", expectedAccount) + case h.holding.lock of + None -> fail "input holding must be locked" + Some lock -> require' ("inputHolding.lock.holders", dedupSort lock.holders) + isEqualR ("expectedHolders", dedupSort expectedHolders) + archive cid + pure h + +-- | Consume an unlocked input holding after validating its identity. A holding +-- whose lock has expired is accepted, giving a combined unlock-and-use; +-- unexpired or indefinite locks are rejected. +fetchAndArchiveUnlockedHolding + : Party -> HoldingV2.Account -> ContractId TokenHolding -> Update TokenHolding +fetchAndArchiveUnlockedHolding admin expectedAccount cid = do + h <- fetch cid + require' ("inputHolding.instrumentId.admin", h.holding.instrumentId.admin) isEqualR ("admin", admin) + require' ("inputHolding.account", h.holding.account) isEqualR ("expectedAccount", expectedAccount) + forA_ h.holding.lock $ \lock -> case lock.expiresAt of + None -> fail "input holding is locked indefinitely and cannot fund an allocation" + Some expiresAt -> assertDeadlineExceeded "input holding lock expiresAt" expiresAt + archive cid + pure h + +-- | Consume input holdings and tally the value they carried per instrument id. +debitHoldings + : (ContractId TokenHolding -> Update TokenHolding) + -> [ContractId TokenHolding] + -> Update (TextMap.TextMap Decimal) +debitHoldings fetchAndArchive cids = do + amounts <- forA cids $ \cid -> do + h <- fetchAndArchive cid + pure (h.holding.instrumentId.id, h.holding.amount) + pure (TextMap.fromListWithR (+) amounts) + +-- | Release locked holdings back to their account, returning the new unlocked +-- holdings keyed by instrument id (the result-map shape of the standard's +-- allocation choices). +unlockHoldings + : Party -> HoldingV2.Account -> [ContractId TokenHolding] + -> Update (TextMap.TextMap [ContractId HoldingV2.Holding]) +unlockHoldings admin expectedAccount cids = do + unlocked <- forA cids $ \cid -> do + h <- fetchAndArchiveLockedHolding admin expectedAccount cid + newCid <- create h with holding = h.holding with lock = None + pure (h.holding.instrumentId.id, [toInterfaceContractId @HoldingV2.Holding newCid]) + pure (TextMap.fromListWithR (++) unlocked) diff --git a/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Registry.daml b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Registry.daml new file mode 100644 index 0000000..70eae6a --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Registry.daml @@ -0,0 +1,336 @@ +-- | The registry rules contract: transfer factory, allocation factory, +-- settlement factory, and event log on a single long-lived admin contract, +-- plus admin expiry of stale allocations. +module OpenZeppelin.Experimental.SettlementV2.Registry where + +import DA.Assert (assertDeadlineExceeded, assertWithinDeadline) +import DA.Foldable (forA_) +import DA.List (dedupSort) +import DA.Optional (isNone, isSome) +import DA.TextMap qualified as TextMap +import DA.Time (RelTime, addRelTime, subTime, convertMicrosecondsToRelTime) + +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.TransferEventsV2 qualified as TransferEventsV2 +import Splice.Api.Token.TransferInstructionV2 qualified as TransferInstructionV2 +import Splice.TokenStandard.Utils + +import OpenZeppelin.Experimental.SettlementV2.Base +import OpenZeppelin.Experimental.SettlementV2.Holding +import OpenZeppelin.Experimental.SettlementV2.Allocation +import OpenZeppelin.Experimental.SettlementV2.D1 +import OpenZeppelin.Experimental.SettlementV2.Transfer + +template TokenRules with + admin : Party + maxTTL : RelTime + -- ^ Upper bound on how long an allocation or transfer instruction may + -- occupy storage. Workflow deadlines beyond this are rejected outright + -- rather than truncated, so a contract's `expiresAt` always equals its + -- workflow deadline and the admin can never expire a live allocation. + lockGrace : RelTime + -- ^ How long a funding lock outlives its workflow contract's `expiresAt`. + -- This is the window in which the admin's expiry path is guaranteed to + -- succeed: without it, the authorizer could re-spend the funding the + -- instant the deadline passed and leave an unremovable shell behind. + maxSeizureExtension : RelTime + -- ^ How far past the settlement deadline a D2 seizure window may reach. + requiredAttesterRegistryCid : Optional (ContractId TrustedAttesterRegistry) + -- ^ When set, every batch settlement must present a valid D1 compliance + -- attestation, rooted in this registry, via the choice context, and a D2 + -- lawful-process sweep must present a `SeizureOrder` signed by a party in + -- the same registry. + maxAttestationValidity : RelTime + -- ^ Cap on an attestation's own validity window, so an attester cannot + -- issue an effectively permanent pass. + d1ComplianceHook : Optional D1ComplianceHook + -- ^ Registry-wide D1 hook stamped onto every allocation created through + -- the factory. + allowedExecutors : Optional [Party] + -- ^ When set, only these parties may appear in `settlement.executors`. + -- Leaving it `None` keeps the registry open, which also lets anyone make + -- an arbitrary party an allocation observer and lock holder by naming + -- them executor — set it in deployments where that matters. + where + signatory admin + ensure maxTTL > noTime + && lockGrace > noTime + && maxSeizureExtension >= noTime + && maxAttestationValidity > noTime + && optional True (\ps -> not (null ps) && ps == dedupSort ps) allowedExecutors + + interface instance TransferEventsV2.EventLog for TokenRules where + view = TransferEventsV2.EventLogView with admin; meta = emptyMetadata + eventLog_holdingsChangeImpl = eventLog_holdingsChangeDefaultImpl admin + + interface instance AllocationV2.SettlementFactory for TokenRules where + view = AllocationV2.SettlementFactoryView with admin; meta = emptyMetadata + + settlementFactory_publicFetchImpl = publicFetchDefaultImpl this + + -- No extra observers: batch participants must not learn about the other + -- allocations being settled. + settlementFactory_settleBatchExtraObservers _ = [] + + settlementFactory_settleBatchImpl self arg = do + checkActors arg.actors [arg.settlement.executors] + require "a settlement batch must cover at least one transfer leg" + (not (null arg.transferLegs)) + requireAllowedExecutors this arg.settlement.executors + complianceReference <- requireD1Attestation this arg + -- Each per-allocation settle is handed a freshly minted, admin-signed + -- proof that this batch's cover check ran and, when D1 is configured, + -- that an attestation was verified. `Allocation_Settle` refuses to run + -- without it, which is what makes the cover check and the D1 gate + -- unavoidable rather than merely conventional. + -- + -- The batch context (attestation plumbing) is redacted from what the + -- authorizers witness; the proof carries only their own leg set. + let authorizeAllocation allocView _settleArg = do + authCid <- create BatchSettlementAuthorization with + admin + settlement = arg.settlement + authorizer = allocView.allocation.authorizer + transferLegSides = allocView.allocation.transferLegSides + complianceReference + pure ExtraArgs with + context = ChoiceContext with + values = TextMap.fromList + [(batchAuthorizationContextKey, AV_ContractId (toAnyContractId authCid))] + meta = arg.extraArgs.meta + settlementFactoryV2_settleBatchDefaultImpl authorizeAllocation admin self arg + + interface instance AllocationInstructionV2.AllocationFactory for TokenRules where + view = AllocationInstructionV2.AllocationFactoryView with admin; meta = emptyMetadata + + allocationFactory_publicFetchImpl = publicFetchDefaultImpl this + allocationFactory_allocateExtraObservers = allocationFactoryV2_privateAsset_allocateExtraObserversDefaultImpl + allocationFactory_allocateImpl _self arg = allocateImpl this arg + + interface instance TransferInstructionV2.TransferFactory for TokenRules where + view = TransferInstructionV2.TransferFactoryView with admin; meta = emptyMetadata + + transferFactory_publicFetchImpl = publicFetchDefaultImpl this + transferFactory_transferExtraObservers = transferFactoryV2_privateAsset_transferExtraObserversDefaultImpl + transferFactory_transferImpl _self arg = transferImpl admin maxTTL lockGrace arg + + -- Batched admin expiry of stale allocations through the standard cancel + -- choice. Actors, admin, and expiry are re-verified per allocation here, + -- independently of the cancel implementation, so this entry point cannot + -- be turned into cancellation of live allocations. + nonconsuming choice TokenRules_ExpireAllocations : () + with + cancelArgs : [(ContractId AllocationV2.Allocation, AllocationV2.Allocation_Cancel)] + observers : [Party] + -- ^ Additional parties to witness the expiries, so off-ledger + -- automation can track them. + observer observers + controller admin + do + forA_ cancelArgs $ \(allocCid, cancelArg) -> do + requireMatchExpected ("cancelArg.actors", cancelArg.actors) [admin] + alloc <- fetch allocCid + let v = view alloc + requireMatchExpected ("allocation.admin", v.allocation.admin) admin + case v.expiresAt of + None -> fail "cannot expire an allocation without an expiry time" + Some t -> assertDeadlineExceeded "allocation.expiresAt" t + _ <- exercise allocCid cancelArg + pure () + + -- | Issue holdings into an account, emitting the standard mint event so + -- supply changes are visible to token-standard history parsers. Without an + -- evented path, holdings could only appear via a raw `create TokenHolding`, + -- which explains no balance change to any wallet. + nonconsuming choice TokenRules_Mint : ContractId TokenHolding + with + account : HoldingV2.Account + instrumentId : Text + amount : Decimal + reason : Text + controller admin :: accountParties admin account + do + require "mint amount must be positive" (amount > 0.0) + require "mint target must be a regular account" (isSome account.owner) + holdingCid <- createTokenHolding admin account instrumentId amount None + withTempEventLog admin $ \eventLogCid -> + logMint eventLogCid account amount + (HoldingV2.InstrumentId with admin; id = instrumentId) + (reasonToMeta reason emptyMetadata) + [toInterfaceContractId @HoldingV2.Holding holdingCid] + pure holdingCid + + -- | Burn a holding, emitting the standard burn event. The account is a + -- choice argument because the controller set has to be known before the + -- holding can be fetched; it is then checked against the holding itself. + nonconsuming choice TokenRules_Burn : () + with + holdingCid : ContractId TokenHolding + account : HoldingV2.Account + reason : Text + controller admin :: accountParties admin account + do + h <- fetch holdingCid + requireMatchExpected ("holding.instrumentId.admin", h.holding.instrumentId.admin) admin + requireMatchExpected ("holding.account", h.holding.account) account + require "cannot burn a locked holding" (isNone h.holding.lock) + archive holdingCid + withTempEventLog admin $ \eventLogCid -> + logBurn eventLogCid h.holding.account h.holding.amount h.holding.instrumentId + (reasonToMeta reason emptyMetadata) + [toInterfaceContractId @HoldingV2.Holding holdingCid] + + -- Batched admin expiry of stale transfer instructions, the transfer-side + -- counterpart of TokenRules_ExpireAllocations. + nonconsuming choice TokenRules_ExpireTransferInstructions : () + with + instructionCids : [ContractId TokenTransferInstruction] + observers : [Party] + observer observers + controller admin + do + forA_ instructionCids $ \cid -> do + instr <- fetch cid + requireMatchExpected ("transfer.instrumentId.admin", instr.transfer.instrumentId.admin) admin + _ <- exercise cid TokenTransferInstruction_Expire + pure () + +noTime : RelTime +noTime = convertMicrosecondsToRelTime 0 + +-- | Reject settlements whose executors are outside the configured allowlist. +requireAllowedExecutors : TokenRules -> [Party] -> Update () +requireAllowedExecutors rules executors = forA_ rules.allowedExecutors $ \allowed -> + require "settlement executors must all be on the registry's allowlist" + (all (`elem` allowed) executors) + + +-- Allocation creation +---------------------- + +-- | Synchronous allocation creation: validate, lock net funding, return the +-- completed allocation and any change. No pending instruction state exists in +-- this registry because allocation needs no approval beyond the authorizer's +-- account parties. +allocateImpl + : TokenRules + -> AllocationInstructionV2.AllocationFactory_Allocate + -> Update AllocationInstructionV2.AllocationInstructionResult +allocateImpl rules arg = do + let admin = rules.admin + allocation = arg.allocation + authorizer = allocation.authorizer + checkActors arg.actors [accountParties admin authorizer] + requireMatchExpected ("allocation.admin", allocation.admin) admin + requireAllowedExecutors rules arg.settlement.executors + require "iterated settlement is not supported by this registry" + (isNone allocation.nextIterationFunding) + require "allocation must authorize at least one transfer-leg side" + (not (null allocation.transferLegSides)) + -- A committed allocation with no deadline could never be withdrawn, so refuse + -- it here as well as structurally on the template. + require "a committed allocation requires a settlement deadline" + (not allocation.committed || isSome allocation.settlementDeadline) + assertDeadlineExceeded "requestedAt" arg.requestedAt + forA_ allocation.settlementDeadline (assertWithinDeadline "allocation.settlementDeadline") + + now <- getTime + -- Bound the workflow rather than truncating the storage expiry below the + -- agreed deadline: a truncated expiry would let the admin cancel a live — + -- possibly committed — allocation before its deadline. + forA_ allocation.settlementDeadline $ \deadline -> + require "settlement deadline exceeds the registry's maximum TTL" + (deadline <= now `addRelTime` rules.maxTTL) + require "requestedAt is older than the registry's maximum TTL" + (now `subTime` arg.requestedAt <= rules.maxTTL) + + -- Net funding: only the negative part of the authorizer's net credit needs + -- to be locked; a receiver-only allocation locks nothing. + let expiresAt = computeStorageExpiry rules.maxTTL now allocation.settlementDeadline + lockExpiresAt = expiresAt `addRelTime` rules.lockGrace + netAmounts = netAllocationCreditAmounts authorizer allocation.transferLegSides + requiredAmounts = fmap (\net -> max 0.0 (negate net)) netAmounts + -- The lock always has a finite expiry, and it outlives the allocation's + -- own expiry so the admin's expiry path has a guaranteed window. + lock = HoldingV2.Lock with + holders = dedupSort (admin :: arg.settlement.executors) + expiresAt = Some lockExpiresAt + expiresAfter = None + context = Some ("allocation for settlement " <> arg.settlement.id) + + inputAmounts <- debitHoldings (fetchAndArchiveUnlockedHolding admin authorizer) + (map fromInterfaceContractId arg.inputHoldingCids) + + lockedAndChange <- forA (TextMap.toList (textMapMergeWithDefault (0.0, 0.0) inputAmounts requiredAmounts)) $ + \(instrumentId, (inputAmount, requiredAmount)) -> do + require' ("funding for " <> instrumentId, inputAmount) + isGreaterOrEqualR ("required lock amount", requiredAmount) + lockedCids <- + if requiredAmount > 0.0 + then (:: []) <$> createTokenHolding admin authorizer instrumentId requiredAmount (Some lock) + else pure [] + changeCids <- + if inputAmount - requiredAmount > 0.0 + then do + cid <- createTokenHolding admin authorizer instrumentId (inputAmount - requiredAmount) None + pure [(instrumentId, [toInterfaceContractId @HoldingV2.Holding cid])] + else pure [] + pure (lockedCids, changeCids) + + let lockedHoldingCids = concatMap fst lockedAndChange + authorizerChangeCids = TextMap.fromListWithR (++) (concatMap snd lockedAndChange) + + allocationCid <- create TokenAllocation with + originalAllocationCid = None + settlement = arg.settlement + allocation + lockedHoldingCids + requestedAt = arg.requestedAt + createdAt = now + expiresAt + lockExpiresAt + d1ComplianceHook = rules.d1ComplianceHook + d2SeizureHook = None + maxSeizureExtension = rules.maxSeizureExtension + requiredAttesterRegistryCid = rules.requiredAttesterRegistryCid + + emitHoldingsChange admin authorizer arg.settlement.executors + arg.inputHoldingCids + (map toInterfaceContractId lockedHoldingCids <> concat (textMapValues authorizerChangeCids)) + [] + "lock holdings for allocation" + + pure AllocationInstructionV2.AllocationInstructionResult with + output = AllocationInstructionV2.AllocationInstructionResult_Completed with + allocationCid = toInterfaceContractId allocationCid + authorizerChangeCids + meta = emptyMetadata + + +-- D1 gate +---------- + +-- | When the registry requires attestation, read the attestation contract id +-- from the choice context and verify it (a consuming exercise: one attestation +-- authorizes one settlement of exactly this leg set, rooted in the registry +-- pinned on this contract). Returns the attestation's own compliance +-- reference, which is then carried to each allocation's settle. +requireD1Attestation + : TokenRules -> AllocationV2.SettlementFactory_SettleBatch -> Update (Optional Text) +requireD1Attestation rules arg = case rules.requiredAttesterRegistryCid of + None -> pure None + Some registryCid -> do + attCid <- case TextMap.lookup d1AttestationContextKey arg.extraArgs.context.values of + Some (AV_ContractId anyCid) -> pure (fromAnyContractId anyCid : ContractId ComplianceAttestation) + Some _ -> fail "D1 attestation context value must be a contract id" + None -> fail "this factory requires a D1 compliance attestation in the choice context" + reference <- exercise attCid ComplianceAttestation_Verify with + settlement = arg.settlement + transferLegs = arg.transferLegs + registryCid + factoryAdmin = rules.admin + maxValidity = rules.maxAttestationValidity + pure (Some reference) diff --git a/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Transfer.daml b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Transfer.daml new file mode 100644 index 0000000..46a7cfc --- /dev/null +++ b/experiments/settlement/cip-0112-v2/daml/OpenZeppelin/Experimental/SettlementV2/Transfer.daml @@ -0,0 +1,249 @@ +-- | Transfer instruction template implementing the Token Standard V2 +-- `TransferInstruction` interface: a transfer offer funded by holdings locked +-- at instruction time, completed in one step when the factory actors already +-- cover both accounts. Accept, reject, and withdraw are all terminal, so no +-- state-update chain exists and `originalInstructionCid` is always `None`. +module OpenZeppelin.Experimental.SettlementV2.Transfer where + +import DA.Assert (assertDeadlineExceeded, assertWithinDeadline) +import DA.List (dedupSort) +import DA.Map qualified as Map +import DA.Optional (fromOptional) +import DA.TextMap qualified as TextMap +import DA.Time (RelTime, addRelTime, subTime) + +import Splice.Api.Token.HoldingV2 qualified as HoldingV2 +import Splice.Api.Token.TransferInstructionV2 qualified as TransferInstructionV2 +import Splice.TokenStandard.Utils + +import OpenZeppelin.Experimental.SettlementV2.Base +import OpenZeppelin.Experimental.SettlementV2.Holding + +template TokenTransferInstruction with + transfer : TransferInstructionV2.Transfer + -- ^ The transfer as instructed, with `inputHoldingCids` rewritten to the + -- live locked funding so wallets reading the standard view can find the + -- holding actually backing the offer. The originally supplied inputs are + -- already archived and are recorded in `originalInputHoldingCids`. + originalInputHoldingCids : [ContractId HoldingV2.Holding] + lockedHoldingCids : [ContractId TokenHolding] + expiresAt : Time + lockExpiresAt : Time + -- ^ When the funding lock expires. Strictly after `expiresAt`, so the + -- admin's expiry path always has a window in which it is guaranteed to + -- succeed before the sender can re-spend the funding. + where + signatory transfer.instrumentId.admin, senderParties transfer + observer receiverParties transfer + ensure isValidTransferV2 transfer + && isRegularAccount transfer.sender + && isRegularAccount transfer.receiver + && not (null lockedHoldingCids) + && expiresAt < lockExpiresAt + + interface instance TransferInstructionV2.TransferInstruction for TokenTransferInstruction where + view = TransferInstructionV2.TransferInstructionView with + originalInstructionCid = None + transfer + expiresAt = Some expiresAt + -- Joint actor sets: paying out needs all receiver account parties + -- (they sign the created holding); returning funds needs all sender + -- account parties. + availableActions = Map.fromList + [ (TransferInstructionV2.TIA_Accept, [receiverParties transfer]) + , (TransferInstructionV2.TIA_Reject, [receiverParties transfer]) + , (TransferInstructionV2.TIA_Withdraw, [senderParties transfer]) + ] + meta = transfer.meta + + transferInstruction_acceptExtraObservers _ = observer this + transferInstruction_rejectExtraObservers _ = observer this + transferInstruction_withdrawExtraObservers _ = observer this + + transferInstruction_acceptImpl self arg = do + archiveAndCheckActors self arg.actors [receiverParties transfer] + assertWithinDeadline "transfer.executeBefore" transfer.executeBefore + let admin = transfer.instrumentId.admin + lockedAmounts <- debitHoldings (fetchAndArchiveLockedHolding admin transfer.sender) lockedHoldingCids + require' ("locked funding for " <> transfer.instrumentId.id, + fromOptional 0.0 (TextMap.lookup transfer.instrumentId.id lockedAmounts)) + isGreaterOrEqualR ("transfer.amount", transfer.amount) + -- Return every unit of locked funding that is not the transferred + -- amount, including any balance in a different instrument. Silently + -- archiving it would be a burn. + senderChangeCids <- returnLockedSurplus transfer lockedAmounts + receiverHoldingCids <- payReceiver transfer + (map (toInterfaceContractId @HoldingV2.Holding) lockedHoldingCids) senderChangeCids + pure TransferInstructionV2.TransferInstructionResult with + output = TransferInstructionV2.TransferInstructionResult_Completed with receiverHoldingCids + senderChangeCids + meta = transfer.meta + + transferInstruction_rejectImpl self arg = do + archiveAndCheckActors self arg.actors [receiverParties transfer] + returnFundsToSender this "transfer rejected" + + transferInstruction_withdrawImpl self arg = do + archiveAndCheckActors self arg.actors [senderParties transfer] + returnFundsToSender this "transfer withdrawn" + + -- Admin expiry of a stale instruction, mirroring allocation expiry: the + -- storage bound has passed and the locked funds return to the sender. Runs + -- in the window between `expiresAt` and `lockExpiresAt`, where the funding + -- is guaranteed to still be locked. + choice TokenTransferInstruction_Expire : TransferInstructionV2.TransferInstructionResult + controller transfer.instrumentId.admin + do + assertDeadlineExceeded "expiresAt" expiresAt + returnFundsToSender this "transfer instruction expired" + + -- | Last-resort admin cleanup for an instruction whose funding was already + -- reclaimed (re-spent as an expired-lock input, or self-unlocked), which + -- makes every fund-returning path fail on the archived holding. Only + -- available once the lock has expired, by which point the sender can always + -- recover the holding via `TokenHolding_OwnerUnlock`, so it cannot strand + -- funds. + choice TokenTransferInstruction_AdminGC : () + controller transfer.instrumentId.admin + do assertDeadlineExceeded "lockExpiresAt" lockExpiresAt + +-- | Factory implementation shared by `TokenRules`: validate, debit the +-- sender's inputs, and either complete in one step (the actors already cover +-- the receiver's account) or lock the transfer amount and create a pending +-- instruction. Change from the inputs is returned unlocked either way. +transferImpl + : Party -> RelTime -> RelTime + -> TransferInstructionV2.TransferFactory_Transfer + -> Update TransferInstructionV2.TransferInstructionResult +transferImpl admin maxTTL lockGrace arg = do + let transfer = arg.transfer + senders = dedupSort (senderParties transfer) + receivers = dedupSort (receiverParties transfer) + bothSides = dedupSort (senderParties transfer <> receiverParties transfer) + actors = dedupSort arg.actors + -- The sender's account parties jointly initiate (they co-sign the debit); + -- including the receiver's account parties completes the transfer in one step. + checkActors arg.actors [senders, bothSides] + requireMatchExpected ("transfer.instrumentId.admin", transfer.instrumentId.admin) admin + require "transfer must be well formed" (isValidTransferV2 transfer) + require "transfer accounts must be regular accounts" + (isRegularAccount transfer.sender && isRegularAccount transfer.receiver) + assertDeadlineExceeded "transfer.requestedAt" transfer.requestedAt + assertWithinDeadline "transfer.executeBefore" transfer.executeBefore + -- Bound how long a pending instruction may occupy storage, as the standard + -- invites registries to do, instead of silently truncating the lock's life + -- below the agreed execution window. + now <- getTime + require "transfer execution window exceeds the registry's maximum TTL" + (transfer.executeBefore <= now `addRelTime` maxTTL) + require "transfer requestedAt is older than the registry's maximum TTL" + (now `subTime` transfer.requestedAt <= maxTTL) + + inputAmounts <- debitHoldings (fetchAndArchiveUnlockedHolding admin transfer.sender) + (map fromInterfaceContractId transfer.inputHoldingCids) + funded <- case TextMap.toList inputAmounts of + [(instrumentId, amount)] | instrumentId == transfer.instrumentId.id -> pure amount + [] -> fail "transfer requires input holdings to fund it" + _ -> fail "input holdings must all match the transfer's instrument" + require' ("funding for " <> transfer.instrumentId.id, funded) + isGreaterOrEqualR ("transfer.amount", transfer.amount) + senderChangeCids <- + if funded > transfer.amount + then do + cid <- createTokenHolding admin transfer.sender transfer.instrumentId.id (funded - transfer.amount) None + pure [toInterfaceContractId @HoldingV2.Holding cid] + else pure [] + + -- Single-step whenever the actors already cover the receiver's account — + -- including a self-transfer, where the receiver's parties are the sender's. + if all (`elem` actors) receivers + then do + receiverHoldingCids <- payReceiver transfer transfer.inputHoldingCids senderChangeCids + pure TransferInstructionV2.TransferInstructionResult with + output = TransferInstructionV2.TransferInstructionResult_Completed with receiverHoldingCids + senderChangeCids + meta = transfer.meta + else do + -- The receiver's account parties are lock holders so they can read the + -- locked funding when accepting or rejecting (mirrors executors on + -- allocation locks). The lock outlives the instruction's own expiry, so + -- the admin's expiry path always runs before the funding is re-spendable. + let instructionExpiresAt = transfer.executeBefore + lockExpiresAt = instructionExpiresAt `addRelTime` lockGrace + lock = HoldingV2.Lock with + holders = dedupSort (admin :: receiverParties transfer) + expiresAt = Some lockExpiresAt + expiresAfter = None + context = Some ("pending transfer to " <> show transfer.receiver.owner) + lockedCid <- createTokenHolding admin transfer.sender transfer.instrumentId.id transfer.amount (Some lock) + instructionCid <- create TokenTransferInstruction with + transfer = transfer with + inputHoldingCids = [toInterfaceContractId @HoldingV2.Holding lockedCid] + originalInputHoldingCids = transfer.inputHoldingCids + lockedHoldingCids = [lockedCid] + expiresAt = instructionExpiresAt + lockExpiresAt + emitHoldingsChange admin transfer.sender [] + transfer.inputHoldingCids + (toInterfaceContractId lockedCid :: senderChangeCids) + [] + "lock holdings for transfer" + pure TransferInstructionV2.TransferInstructionResult with + output = TransferInstructionV2.TransferInstructionResult_Pending with + transferInstructionCid = toInterfaceContractId instructionCid + senderChangeCids + meta = transfer.meta + +-- | Pay out any locked funding beyond the transferred amount, per instrument, +-- so accepting can never destroy value. +returnLockedSurplus + : TransferInstructionV2.Transfer -> TextMap.TextMap Decimal + -> Update [ContractId HoldingV2.Holding] +returnLockedSurplus transfer lockedAmounts = do + let admin = transfer.instrumentId.admin + changes <- forA (TextMap.toList lockedAmounts) $ \(instrumentId, amount) -> do + let surplus = + if instrumentId == transfer.instrumentId.id then amount - transfer.amount else amount + if surplus > 0.0 + then do + cid <- createTokenHolding admin transfer.sender instrumentId surplus None + pure [toInterfaceContractId @HoldingV2.Holding cid] + else pure [] + pure (concat changes) + +-- | Create the receiver's holding and log the transfer event. `inputCids` are +-- the holdings consumed to fund it (original inputs in the one-step path, the +-- locked funding on accept). +payReceiver + : TransferInstructionV2.Transfer -> [ContractId HoldingV2.Holding] -> [ContractId HoldingV2.Holding] + -> Update [ContractId HoldingV2.Holding] +payReceiver transfer inputCids senderChangeCids = do + let admin = transfer.instrumentId.admin + receiverCid <- createTokenHolding admin transfer.receiver transfer.instrumentId.id transfer.amount None + let receiverHoldingCids = [toInterfaceContractId @HoldingV2.Holding receiverCid] + withTempEventLog admin $ \eventLogCid -> + logTransfer eventLogCid (transfer with inputHoldingCids = inputCids) + senderChangeCids receiverHoldingCids + pure receiverHoldingCids + +-- | Release the locked funding to the sender and log the change. +returnFundsToSender : TokenTransferInstruction -> Text -> Update TransferInstructionV2.TransferInstructionResult +returnFundsToSender this reason = do + let admin = this.transfer.instrumentId.admin + holdings <- unlockHoldings admin this.transfer.sender this.lockedHoldingCids + let senderChangeCids = concat (textMapValues holdings) + emitHoldingsChange admin this.transfer.sender [] + (map toInterfaceContractId this.lockedHoldingCids) + senderChangeCids + [] + reason + pure TransferInstructionV2.TransferInstructionResult with + output = TransferInstructionV2.TransferInstructionResult_Failed + senderChangeCids + meta = this.transfer.meta + +senderParties : TransferInstructionV2.Transfer -> [Party] +senderParties transfer = accountParties transfer.instrumentId.admin transfer.sender + +receiverParties : TransferInstructionV2.Transfer -> [Party] +receiverParties transfer = accountParties transfer.instrumentId.admin transfer.receiver diff --git a/experiments/settlement/cip-0112-v2/test/daml.yaml b/experiments/settlement/cip-0112-v2/test/daml.yaml new file mode 100644 index 0000000..430285f --- /dev/null +++ b/experiments/settlement/cip-0112-v2/test/daml.yaml @@ -0,0 +1,28 @@ +sdk-version: 3.4.11 +name: openzeppelin-experimental-cip112-settlement-v2-test +source: daml +version: 0.0.0 +dependencies: + - daml-prim + - daml-stdlib + - daml-script +data-dependencies: + # The package under test, plus the vendored Token Standard V2 DARs its + # interfaces come from. Paths are relative to this daml.yaml. + - ../.daml/dist/openzeppelin-experimental-cip112-settlement-v2-0.1.0.dar + - ../../../../dars/token-standard/splice-api-token-metadata-v1-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-holding-v1-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-holding-v2-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-transfer-events-v2-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-allocation-v1-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-allocation-v2-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-transfer-instruction-v1-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-transfer-instruction-v2-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-allocation-instruction-v1-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-allocation-instruction-v2-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-allocation-request-v1-1.0.0.dar + - ../../../../dars/token-standard/splice-api-token-allocation-request-v2-1.0.0.dar + - ../../../../dars/token-standard/splice-token-standard-utils-2.0.0.dar +build-options: + # Match the package under test and the vendored API DARs. + - --target=2.1 diff --git a/experiments/settlement/cip-0112-v2/test/daml/OpenZeppelin/Test/Cip112SettlementV2.daml b/experiments/settlement/cip-0112-v2/test/daml/OpenZeppelin/Test/Cip112SettlementV2.daml new file mode 100644 index 0000000..a2119b3 --- /dev/null +++ b/experiments/settlement/cip-0112-v2/test/daml/OpenZeppelin/Test/Cip112SettlementV2.daml @@ -0,0 +1,1349 @@ +-- | Tests for the Token Standard V2 conformant settlement package +-- (experiments/settlement/cip-0112-v2), driven through the standard interfaces. +-- +-- Scenario names prefixed `testFix…` are regressions pinning findings from +-- post-core/basic-review.md; each names the finding it covers. +module OpenZeppelin.Test.Cip112SettlementV2 where + +import DA.Assert ((===), (=/=)) +import DA.Date (date, Month(Jan)) +import DA.Foldable (forA_) +import DA.List (sort) +import DA.Time (days, hours, minutes, time) +import Daml.Script + +import DA.Map qualified as Map +import DA.Optional (isNone, isSome) +import DA.TextMap qualified as TextMap + +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.AllocationRequestV2 qualified as AllocationRequestV2 +import Splice.Api.Token.TransferInstructionV2 qualified as TransferInstructionV2 +import Splice.TokenStandard.Utils (basicAccount, senderSide, receiverSide, nonIteratedAllocation, toAnyContractId) + +import OpenZeppelin.Experimental.SettlementV2.Allocation +import OpenZeppelin.Experimental.SettlementV2.AllocationRequest +import OpenZeppelin.Experimental.SettlementV2.Base +import OpenZeppelin.Experimental.SettlementV2.D1 +import OpenZeppelin.Experimental.SettlementV2.Holding +import OpenZeppelin.Experimental.SettlementV2.Registry +import OpenZeppelin.Experimental.SettlementV2.Transfer + +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 + +data Scenario = Scenario with + admin : Party + app : Party + alice : Party + bob : Party + custodian : Party + attester : Party + rulesCid : ContractId TokenRules + rulesDisclosure : Disclosure + settlement : AllocationV2.SettlementInfo + legAliceToBob : AllocationV2.TransferLeg + legBobToAlice : AllocationV2.TransferLeg + +emptyExtraArgs : ExtraArgs +emptyExtraArgs = ExtraArgs with context = emptyChoiceContext; meta = emptyMetadata + +mkTransferLeg : Text -> Party -> Party -> Decimal -> AllocationV2.TransferLeg +mkTransferLeg legId sender receiver amount = AllocationV2.TransferLeg with + transferLegId = legId + sender = basicAccount sender + receiver = basicAccount receiver + amount + instrumentId = "TOK" + meta = emptyMetadata + +mkAllocationSpec : Party -> Party -> [AllocationV2.TransferLegSide] -> AllocationV2.AllocationSpecification +mkAllocationSpec admin authorizer sides = AllocationV2.AllocationSpecification with + admin + authorizer = basicAccount authorizer + transferLegSides = sides + settlementDeadline = Some t2 + nextIterationFunding = None + committed = False + meta = emptyMetadata + +mint : Party -> Party -> Decimal -> Script (ContractId TokenHolding) +mint admin owner amount = + submit (actAs admin <> actAs owner) do + createCmd TokenHolding with + holding = HoldingV2.HoldingView with + account = basicAccount owner + instrumentId = HoldingV2.InstrumentId with admin; id = "TOK" + amount + lock = None + meta = emptyMetadata + +allocate + : Scenario -> Party -> [AllocationV2.TransferLegSide] -> [ContractId TokenHolding] + -> Script AllocationInstructionV2.AllocationInstructionResult +allocate s authorizer sides inputs = allocateSpec s authorizer (mkAllocationSpec s.admin authorizer sides) inputs + +allocateSpec + : Scenario -> Party -> AllocationV2.AllocationSpecification -> [ContractId TokenHolding] + -> Script AllocationInstructionV2.AllocationInstructionResult +allocateSpec Scenario{..} authorizer spec inputs = + submit (actAs authorizer <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) + AllocationInstructionV2.AllocationFactory_Allocate with + settlement + allocation = spec + requestedAt = t0 + inputHoldingCids = map (toInterfaceContractId @HoldingV2.Holding) inputs + extraArgs = emptyExtraArgs + actors = [authorizer] + +completedCid + : AllocationInstructionV2.AllocationInstructionResult + -> Script (ContractId AllocationV2.Allocation) +completedCid result = case result.output of + AllocationInstructionV2.AllocationInstructionResult_Completed cid -> pure cid + other -> abort ("expected completed allocation, got: " <> show other) + +-- | Settle a batch through the factory, which is the only path that mints the +-- per-allocation authorization proof. +settleBatch + : Scenario -> [AllocationV2.TransferLeg] -> [ContractId AllocationV2.Allocation] -> ExtraArgs + -> Script AllocationV2.SettlementFactory_SettleBatchResult +settleBatch Scenario{..} legs allocs extraArgs = + submit (actAs app <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = legs + allocations = map nonIteratedAllocation allocs + actors = [app] + extraArgs + +holdingAmounts : Party -> Script [Decimal] +holdingAmounts owner = do + holdings <- query @TokenHolding owner + pure (sort [h.holding.amount | (_, h) <- holdings, h.holding.account.owner == Some owner]) + +setupWith : Optional (ContractId TrustedAttesterRegistry) -> Optional D1ComplianceHook -> Script Scenario +setupWith requiredAttesterRegistryCid d1ComplianceHook = do + admin <- allocateParty "admin" + app <- allocateParty "app" + alice <- allocateParty "alice" + bob <- allocateParty "bob" + custodian <- allocateParty "custodian" + attester <- allocateParty "attester" + setTime t1 + rulesCid <- submit admin do + createCmd TokenRules with + admin + maxTTL = days 90 + lockGrace = hours 1 + maxSeizureExtension = days 30 + requiredAttesterRegistryCid + maxAttestationValidity = days 7 + d1ComplianceHook + allowedExecutors = None + Some rulesDisclosure <- queryDisclosure @TokenRules admin rulesCid + let settlement = AllocationV2.SettlementInfo with + executors = [app] + id = "settlement-1" + cid = None + meta = emptyMetadata + pure Scenario with + admin; app; alice; bob; custodian; attester; rulesCid; rulesDisclosure + settlement + legAliceToBob = mkTransferLeg "leg-1" alice bob 10.0 + legBobToAlice = mkTransferLeg "leg-2" bob alice 4.0 + +setup : Script Scenario +setup = setupWith None None + +-- | Happy path: two-leg DvP with net funding. Alice sends 10 and receives 4, +-- so only 6 is locked; Bob nets +6 and locks nothing. After settlement Alice +-- holds her 4.0 change and Bob holds 6.0. +testNetSettlementHappyPath : Script () +testNetSettlementHappyPath = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + + aliceResult <- allocate s alice [senderSide legAliceToBob, receiverSide legBobToAlice] [aliceInput] + aliceAllocCid <- completedCid aliceResult + -- Net funding: 6.0 locked, 4.0 returned as change. + aliceHoldings <- query @TokenHolding alice + sort [h.holding.amount | (_, h) <- aliceHoldings] === [4.0, 6.0] + + bobResult <- allocate s bob [receiverSide legAliceToBob, senderSide legBobToAlice] [] + bobAllocCid <- completedCid bobResult + + _ <- settleBatch s [legAliceToBob, legBobToAlice] [aliceAllocCid, bobAllocCid] emptyExtraArgs + + aliceAfter <- holdingAmounts alice + aliceAfter === [4.0] + bobAfter <- holdingAmounts bob + bobAfter === [6.0] + +-- | Conservation: a sender whose inputs do not cover the net debit fails +-- closed at allocation time. +testUnderfundedSenderFails : Script () +testUnderfundedSenderFails = do + s@Scenario{..} <- setup + smallInput <- mint admin alice 5.0 + submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) + AllocationInstructionV2.AllocationFactory_Allocate with + settlement + allocation = mkAllocationSpec admin alice [senderSide legAliceToBob] + requestedAt = t0 + inputHoldingCids = [toInterfaceContractId @HoldingV2.Holding smallInput] + extraArgs = emptyExtraArgs + actors = [alice] + +-- | Exact cover: a batch that presents the legs but is missing the +-- counterparty's allocation is rejected. +testMissingAuthorizationFails : Script () +testMissingAuthorizationFails = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob, receiverSide legBobToAlice] [aliceInput] + aliceAllocCid <- completedCid aliceResult + submitMustFail (actAs app <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [legAliceToBob, legBobToAlice] + allocations = [nonIteratedAllocation aliceAllocCid] + actors = [app] + extraArgs = emptyExtraArgs + +-- | Exact cover, other direction: a batch carrying an allocation whose legs are +-- not in the presented leg set is rejected. +testSuperfluousAuthorizationFails : Script () +testSuperfluousAuthorizationFails = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob, receiverSide legBobToAlice] [aliceInput] + aliceAllocCid <- completedCid aliceResult + bobResult <- allocate s bob [receiverSide legAliceToBob, senderSide legBobToAlice] [] + bobAllocCid <- completedCid bobResult + -- Present only leg-1 while the allocations authorize both legs. + submitMustFail (actAs app <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [legAliceToBob] + allocations = [nonIteratedAllocation aliceAllocCid, nonIteratedAllocation bobAllocCid] + actors = [app] + extraArgs = emptyExtraArgs + +-- | Withdraw: the authorizer releases an uncommitted allocation and gets the +-- locked funds back. +testWithdrawReleasesFunds : Script () +testWithdrawReleasesFunds = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + _ <- submit (actAs alice) do + exerciseCmd aliceAllocCid AllocationV2.Allocation_Withdraw with + actors = [alice] + extraArgs = emptyExtraArgs + aliceAfter <- holdingAmounts alice + aliceAfter === [10.0] + +-- | Executor cancel returns funds; admin cancel is refused while the allocation +-- is live and accepted once its expiry has passed. +testCancelPaths : Script () +testCancelPaths = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + -- Admin cannot cancel a live allocation. + submitMustFail (actAs admin) do + exerciseCmd aliceAllocCid AllocationV2.Allocation_Cancel with + actors = [admin] + extraArgs = emptyExtraArgs + -- Executors may cancel at any time. + _ <- submit (actAs app) do + exerciseCmd aliceAllocCid AllocationV2.Allocation_Cancel with + actors = [app] + extraArgs = emptyExtraArgs + aliceAfter <- holdingAmounts alice + aliceAfter === [10.0] + + -- Admin batch expiry after the deadline, via the rules contract. + input2 <- mint admin bob 5.0 + bobResult <- allocateSpec s bob (mkAllocationSpec admin bob [senderSide (mkTransferLeg "leg-9" bob alice 5.0)]) [input2] + bobAllocCid <- completedCid bobResult + setTime t3 + _ <- submit (actAs admin <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_ExpireAllocations with + cancelArgs = + [ (bobAllocCid, AllocationV2.Allocation_Cancel with actors = [admin]; extraArgs = emptyExtraArgs) ] + observers = [] + bobAfter <- holdingAmounts bob + bobAfter === [5.0] + +-- | Allocation requests: one request per authorizer. Alice accepts hers +-- batched with the allocation creation, Bob rejects his, and the app +-- withdraws a re-issued one. A non-authorizer cannot accept. +testAllocationRequestLifecycle : Script () +testAllocationRequestLifecycle = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + let aliceSides = [senderSide legAliceToBob, receiverSide legBobToAlice] + let bobSides = [receiverSide legAliceToBob, senderSide legBobToAlice] + aliceReqCid <- mkRequest s alice aliceSides + bobReqCid <- mkRequest s bob bobSides + + -- Wallets see who can act: any single account party of the authorizer. + Some aliceReqView <- queryInterfaceContractId @AllocationRequestV2.AllocationRequest alice + (toInterfaceContractId aliceReqCid) + Map.lookup AllocationRequestV2.ARA_Accept aliceReqView.availableActions === Some [[alice]] + + -- The app is not the authorizer, so it cannot accept on Alice's behalf. + submitMustFail (actAs app) do + exerciseCmd (toInterfaceContractId @AllocationRequestV2.AllocationRequest aliceReqCid) + AllocationRequestV2.AllocationRequest_Accept with + actors = [app] + extraArgs = emptyExtraArgs + + -- Alice accepts and creates the requested allocation in one transaction. + let acceptCmd = exerciseCmd (toInterfaceContractId @AllocationRequestV2.AllocationRequest aliceReqCid) + AllocationRequestV2.AllocationRequest_Accept with + actors = [alice] + extraArgs = emptyExtraArgs + let allocateCmd = exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) + AllocationInstructionV2.AllocationFactory_Allocate with + settlement + allocation = mkAllocationSpec admin alice aliceSides + requestedAt = t0 + inputHoldingCids = [toInterfaceContractId @HoldingV2.Holding aliceInput] + extraArgs = emptyExtraArgs + actors = [alice] + aliceResult <- submit (actAs alice <> discloseMany [rulesDisclosure]) (acceptCmd *> allocateCmd) + _ <- completedCid aliceResult + aliceReqAfter <- queryContractId app aliceReqCid + aliceReqAfter === None + + -- Bob rejects his request, consuming it. + _ <- submit (actAs bob) do + exerciseCmd (toInterfaceContractId @AllocationRequestV2.AllocationRequest bobReqCid) + AllocationRequestV2.AllocationRequest_Reject with + actors = [bob] + extraArgs = emptyExtraArgs + bobReqAfter <- queryContractId app bobReqCid + bobReqAfter === None + + -- The executors jointly withdraw a request they no longer need. + bobReqCid2 <- mkRequest s bob bobSides + _ <- submit (actAs app) do + exerciseCmd (toInterfaceContractId @AllocationRequestV2.AllocationRequest bobReqCid2) + AllocationRequestV2.AllocationRequest_Withdraw with + actors = [app] + extraArgs = emptyExtraArgs + bobReq2After <- queryContractId app bobReqCid2 + bobReq2After === None + +mkRequest : Scenario -> Party -> [AllocationV2.TransferLegSide] -> Script (ContractId TokenAllocationRequest) +mkRequest Scenario{..} authorizer sides = + submit (actAs app) do + createCmd TokenAllocationRequest with + settlement + allocations = [mkAllocationSpec admin authorizer sides] + requestedAt = t0 + settleAt = Some t1 + +-- | A request spanning two authorizers is rejected at creation: accept/reject +-- consume the whole request, so it can only speak for one authorizer. +testMultiAuthorizerRequestRejected : Script () +testMultiAuthorizerRequestRejected = do + Scenario{..} <- setup + submitMustFail (actAs app) do + createCmd TokenAllocationRequest with + settlement + allocations = + [ mkAllocationSpec admin alice [senderSide legAliceToBob] + , mkAllocationSpec admin bob [senderSide legBobToAlice] + ] + requestedAt = t0 + settleAt = Some t1 + + +-- Transfer instructions +------------------------ + +mkTransfer : Scenario -> Party -> Party -> Decimal -> [ContractId TokenHolding] -> TransferInstructionV2.Transfer +mkTransfer Scenario{..} sender receiver amount inputs = TransferInstructionV2.Transfer with + sender = basicAccount sender + receiver = basicAccount receiver + amount + instrumentId = HoldingV2.InstrumentId with admin; id = "TOK" + requestedAt = t0 + executeBefore = t2 + inputHoldingCids = map (toInterfaceContractId @HoldingV2.Holding) inputs + meta = emptyMetadata + +instructTransfer + : Scenario -> [Party] -> TransferInstructionV2.Transfer + -> Script TransferInstructionV2.TransferInstructionResult +instructTransfer Scenario{..} actors transfer = + submit (actAs actors <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @TransferInstructionV2.TransferFactory rulesCid) + TransferInstructionV2.TransferFactory_Transfer with + transfer + actors + extraArgs = emptyExtraArgs + +pendingCid + : TransferInstructionV2.TransferInstructionResult + -> Script (ContractId TransferInstructionV2.TransferInstruction) +pendingCid result = case result.output of + TransferInstructionV2.TransferInstructionResult_Pending cid -> pure cid + other -> abort ("expected pending transfer instruction, got: " <> show other) + +completedHoldings + : TransferInstructionV2.TransferInstructionResult + -> Script [ContractId HoldingV2.Holding] +completedHoldings result = case result.output of + TransferInstructionV2.TransferInstructionResult_Completed cids -> pure cids + other -> abort ("expected completed transfer, got: " <> show other) + +assertNoLocks : Party -> Script () +assertNoLocks owner = do + holdings <- query @TokenHolding owner + all (\(_, h) -> isNone h.holding.lock) holdings === True + +-- | Two-step transfer: the sender instructs (locking the amount, change +-- returned), the receiver accepts and gets the holding. +testTransferTwoStep : Script () +testTransferTwoStep = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + result <- instructTransfer s [alice] (mkTransfer s alice bob 7.0 [aliceInput]) + instrCid <- pendingCid result + -- 3.0 change unlocked, 7.0 locked pending acceptance. + aliceMid <- holdingAmounts alice + aliceMid === [3.0, 7.0] + + -- Wallets see who can act on the pending instruction, and the view points at + -- the live locked funding rather than the consumed inputs. + Some instrView <- queryInterfaceContractId @TransferInstructionV2.TransferInstruction bob instrCid + Map.lookup TransferInstructionV2.TIA_Accept instrView.availableActions === Some [[bob]] + Map.lookup TransferInstructionV2.TIA_Withdraw instrView.availableActions === Some [[alice]] + instrView.transfer.inputHoldingCids =/= map (toInterfaceContractId @HoldingV2.Holding) [aliceInput] + + -- The admin can see the instruction but is not the receiver, so cannot accept. + submitMustFail (actAs admin) do + exerciseCmd instrCid TransferInstructionV2.TransferInstruction_Accept with + actors = [admin] + extraArgs = emptyExtraArgs + + _ <- submit (actAs bob) do + exerciseCmd instrCid TransferInstructionV2.TransferInstruction_Accept with + actors = [bob] + extraArgs = emptyExtraArgs + aliceAfter <- holdingAmounts alice + aliceAfter === [3.0] + bobAfter <- holdingAmounts bob + bobAfter === [7.0] + assertNoLocks alice + assertNoLocks bob + +-- | One-step transfer: actors covering both accounts complete immediately, +-- with no pending instruction and no lock. +testTransferOneStep : Script () +testTransferOneStep = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + result <- instructTransfer s [alice, bob] (mkTransfer s alice bob 7.0 [aliceInput]) + _ <- completedHoldings result + aliceAfter <- holdingAmounts alice + aliceAfter === [3.0] + bobAfter <- holdingAmounts bob + bobAfter === [7.0] + assertNoLocks alice + +-- | Reject and withdraw both return the locked funds to the sender. +testTransferRejectAndWithdraw : Script () +testTransferRejectAndWithdraw = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + rejected <- instructTransfer s [alice] (mkTransfer s alice bob 7.0 [aliceInput]) + rejectedCid <- pendingCid rejected + _ <- submit (actAs bob) do + exerciseCmd rejectedCid TransferInstructionV2.TransferInstruction_Reject with + actors = [bob] + extraArgs = emptyExtraArgs + assertNoLocks alice + + aliceHoldings <- query @TokenHolding alice + withdrawn <- instructTransfer s [alice] (mkTransfer s alice bob 7.0 (map fst aliceHoldings)) + withdrawnCid <- pendingCid withdrawn + _ <- submit (actAs alice) do + exerciseCmd withdrawnCid 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 + s@Scenario{..} <- setup + smallInput <- mint admin alice 5.0 + -- Underfunded: inputs do not cover the transfer amount. + submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @TransferInstructionV2.TransferFactory rulesCid) + TransferInstructionV2.TransferFactory_Transfer with + transfer = mkTransfer s alice bob 7.0 [smallInput] + actors = [alice] + extraArgs = emptyExtraArgs + -- executeBefore not in the future fails at the factory. + submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @TransferInstructionV2.TransferFactory rulesCid) + TransferInstructionV2.TransferFactory_Transfer with + transfer = (mkTransfer s alice bob 5.0 [smallInput]) with executeBefore = t1 + actors = [alice] + extraArgs = emptyExtraArgs + -- Accepting after executeBefore fails; the sender's lock has expired. + result <- instructTransfer s [alice] (mkTransfer s alice bob 5.0 [smallInput]) + instrCid <- pendingCid result + setTime t2 + submitMustFail (actAs bob) do + exerciseCmd instrCid TransferInstructionV2.TransferInstruction_Accept with + actors = [bob] + extraArgs = emptyExtraArgs + +-- | Admin expiry: only after the storage bound has passed, and the funds +-- return to the sender. +testTransferAdminExpiry : Script () +testTransferAdminExpiry = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + result <- instructTransfer s [alice] (mkTransfer s alice bob 7.0 [aliceInput]) + instrCid <- pendingCid result + let templateCid = fromInterfaceContractId @TokenTransferInstruction instrCid + -- Not yet expired: the admin cannot reclaim early. + submitMustFail (actAs admin) do + exerciseCmd templateCid TokenTransferInstruction_Expire + setTime t3 + -- Batched expiry through the rules contract, mirroring allocation expiry. + _ <- submit (actAs admin <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_ExpireTransferInstructions with + instructionCids = [templateCid] + observers = [] + assertNoLocks alice + aliceAfter <- holdingAmounts alice + sum aliceAfter === 10.0 + + +-- Regressions for review findings +--------------------------------- + +-- | HIGH-2 / adjudicated cover bypass: `Allocation_Settle` outside the batch +-- factory is refused, so admin+executors cannot mint by settling a lone +-- receiver-side allocation. +testFixDirectSettleRefused : Script () +testFixDirectSettleRefused = do + s@Scenario{..} <- setup + -- Bob's receiver-side-only allocation locks nothing; settling it alone would + -- have created 10 TOK from nothing. + bobResult <- allocate s bob [receiverSide legAliceToBob] [] + bobAllocCid <- completedCid bobResult + submitMustFail (actAs admin <> actAs app) do + exerciseCmd bobAllocCid AllocationV2.Allocation_Settle with + actors = [admin, app] + extraTransferLegSides = [] + nextIterationFunding = None + extraArgs = emptyExtraArgs + bobAfter <- holdingAmounts bob + bobAfter === [] + +-- | HIGH-3: a settlement deadline beyond the registry's maxTTL is rejected +-- outright, so `expiresAt` can never precede the deadline and the admin can +-- never expire a live allocation. +testFixDeadlineBoundedByMaxTTL : Script () +testFixDeadlineBoundedByMaxTTL = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + let farSpec = (mkAllocationSpec admin alice [senderSide legAliceToBob]) with + settlementDeadline = Some (time (date 2027 Jan 1) 0 0 0) + submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) + AllocationInstructionV2.AllocationFactory_Allocate with + settlement + allocation = farSpec + requestedAt = t0 + inputHoldingCids = [toInterfaceContractId @HoldingV2.Holding aliceInput] + extraArgs = emptyExtraArgs + actors = [alice] + +-- | MED-4: a committed allocation without a settlement deadline could never be +-- withdrawn, so creating one is refused. +testFixCommittedRequiresDeadline : Script () +testFixCommittedRequiresDeadline = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + let badSpec = (mkAllocationSpec admin alice [senderSide legAliceToBob]) with + committed = True + settlementDeadline = None + submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) + AllocationInstructionV2.AllocationFactory_Allocate with + settlement + allocation = badSpec + requestedAt = t0 + inputHoldingCids = [toInterfaceContractId @HoldingV2.Holding aliceInput] + extraArgs = emptyExtraArgs + actors = [alice] + +-- | MED-1: the funding lock outlives the instruction's own expiry, so the +-- admin's expiry path always has a window in which it is guaranteed to work, +-- and once the lock does expire the sender can self-recover. +testFixLockGraceAndOwnerUnlock : Script () +testFixLockGraceAndOwnerUnlock = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + result <- instructTransfer s [alice] (mkTransfer s alice bob 7.0 [aliceInput]) + instrCid <- pendingCid result + let templateCid = fromInterfaceContractId @TokenTransferInstruction instrCid + + -- Just past executeBefore: the lock has NOT yet expired, so the locked + -- holding cannot be re-spent as an input. + setTime t3 + lockedHoldings <- query @TokenHolding alice + let lockedCids = [cid | (cid, h) <- lockedHoldings, isSome h.holding.lock] + submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @TransferInstructionV2.TransferFactory rulesCid) + TransferInstructionV2.TransferFactory_Transfer with + transfer = (mkTransfer s alice bob 7.0 lockedCids) with + requestedAt = t3 + executeBefore = t4 + actors = [alice] + extraArgs = emptyExtraArgs + -- And the owner cannot unlock early either. + forA_ lockedCids $ \cid -> + submitMustFail (actAs alice <> actAs admin) do + exerciseCmd cid TokenHolding_OwnerUnlock + + -- After the grace window the owner can always self-recover, which is what + -- makes admin GC safe. + setTime t4 + forA_ lockedCids $ \cid -> + submit (actAs alice <> actAs admin) do + exerciseCmd cid TokenHolding_OwnerUnlock + assertNoLocks alice + aliceAfter <- holdingAmounts alice + sum aliceAfter === 10.0 + + -- The instruction shell now references an archived holding, so the normal + -- fund-returning paths fail — and admin GC is the escape hatch that keeps it + -- from being permanently unremovable. + submitMustFail (actAs admin) do + exerciseCmd templateCid TokenTransferInstruction_Expire + _ <- submit (actAs admin) do + exerciseCmd templateCid TokenTransferInstruction_AdminGC + gcd <- queryContractId admin templateCid + gcd === None + +-- | LOW-2: a lock carrying `expiresAfter` is rejected at creation, since the +-- package's expiry checks only model `expiresAt`. +testFixExpiresAfterRejected : Script () +testFixExpiresAfterRejected = do + Scenario{..} <- setup + submitMustFail (actAs admin <> actAs alice) do + createCmd TokenHolding with + holding = HoldingV2.HoldingView with + account = basicAccount alice + instrumentId = HoldingV2.InstrumentId with admin; id = "TOK" + amount = 5.0 + lock = Some HoldingV2.Lock with + holders = [admin] + expiresAt = None + expiresAfter = Some (hours 1) + context = None + meta = emptyMetadata + +-- | LOW-1: a self-transfer completes in one step rather than creating a pending +-- instruction the sender would have to accept from themselves. +testFixSelfTransferOneStep : Script () +testFixSelfTransferOneStep = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + result <- instructTransfer s [alice] (mkTransfer s alice alice 4.0 [aliceInput]) + _ <- completedHoldings result + aliceAfter <- holdingAmounts alice + sort aliceAfter === [4.0, 6.0] + assertNoLocks alice + +-- | MED-7: an empty batch is refused rather than succeeding as a no-op. +testFixEmptyBatchRefused : Script () +testFixEmptyBatchRefused = do + Scenario{..} <- setup + submitMustFail (actAs app <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [] + allocations = [] + actors = [app] + extraArgs = emptyExtraArgs + +-- | MED-5: the advertised withdraw actor set is exactly what the choice body +-- accepts (the authorizer's full account-party set), and every advertised +-- action disappears while a D2 seizure is active. +testFixAvailableActionsMatchImpl : Script () +testFixAvailableActionsMatchImpl = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + Some v <- queryInterfaceContractId @AllocationV2.Allocation alice aliceAllocCid + Map.lookup AllocationV2.AA_Withdraw v.availableActions === Some [[alice]] + Map.lookup AllocationV2.AA_Settle v.availableActions === Some [[admin, app]] + -- The seizure case reference is not exposed in the view; only an opaque + -- "held" marker once seized. + TextMap.lookup d2StatusMetaKey v.meta.values === None + + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + markedCid <- submit (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = D2SeizureHook with + seizureCaseRef = "case-secret" + custodianDestination = basicAccount custodian + inFlightHandlingStatus = "held" + windowEnd = t3 + Some sv <- queryInterfaceContractId @AllocationV2.Allocation alice (toInterfaceContractId markedCid) + Map.toList sv.availableActions === [] + TextMap.lookup d2StatusMetaKey sv.meta.values === Some d2HeldStatus + +-- | HIGH-4: the seizure custodian cannot be the admin's own account, so a +-- sweep always needs a second party's authority. +testFixSeizureCustodianMustBeDistinct : Script () +testFixSeizureCustodianMustBeDistinct = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + submitMustFail (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = D2SeizureHook with + seizureCaseRef = "case-1" + custodianDestination = basicAccount admin + inFlightHandlingStatus = "held" + windowEnd = t3 + +-- | HIGH-4: a seizure window beyond the registry's maximum extension is +-- refused, and a lapsed seizure can be released by any stakeholder so an +-- abandoned mark cannot strand funds. +testFixSeizureWindowBounded : Script () +testFixSeizureWindowBounded = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + hook = D2SeizureHook with + seizureCaseRef = "case-1" + custodianDestination = basicAccount custodian + inFlightHandlingStatus = "held" + windowEnd = t3 + -- Far-future window exceeds maxSeizureExtension (30 days from t2). + submitMustFail (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = hook with windowEnd = time (date 2027 Jan 1) 0 0 0 + -- An already-lapsed window is refused: it would freeze nothing. + submitMustFail (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = hook with windowEnd = t0 + -- A window inside policy is accepted. + markedCid <- submit (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = hook + -- While the window is open, the authorizer cannot release it. + submitMustFail (actAs alice) do + exerciseCmd markedCid TokenAllocation_ReleaseLapsedD2Seizure with actor = alice + -- A non-stakeholder cannot release it even after it lapses. + setTime t4 + submitMustFail (actAs custodian) do + exerciseCmd markedCid TokenAllocation_ReleaseLapsedD2Seizure with actor = custodian + -- Once lapsed, any single stakeholder can, and the allocation becomes + -- withdrawable again. + releasedCid <- submit (actAs alice) do + exerciseCmd markedCid TokenAllocation_ReleaseLapsedD2Seizure with actor = alice + _ <- submit (actAs alice) do + exerciseCmd (toInterfaceContractId @AllocationV2.Allocation releasedCid) + AllocationV2.Allocation_Withdraw with + actors = [alice] + extraArgs = emptyExtraArgs + aliceAfter <- holdingAmounts alice + aliceAfter === [10.0] + +-- | MED-2: a D2 sweep moves value between accounts, so it must report matched +-- transfer legs; the sweep itself conserves value and needs the custodian's +-- authority. +testFixSweepConservesAndReportsLegs : Script () +testFixSweepConservesAndReportsLegs = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + markedCid <- submit (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = D2SeizureHook with + seizureCaseRef = "case-1" + custodianDestination = basicAccount custodian + inFlightHandlingStatus = "held" + windowEnd = t3 + capCid <- submit admin do + createCmd BurnerCapability with + admin + assignee = admin + instrumentScope = None + caseScope = Some "case-1" + expiresAt = t3 + -- A capability scoped to a different case does not authorize this sweep. + wrongCaseCap <- submit admin do + createCmd BurnerCapability with + admin + assignee = admin + instrumentScope = None + caseScope = Some "case-other" + expiresAt = t3 + submitMustFail (actAs admin <> actAs custodian) do + exerciseCmd markedCid TokenAllocation_SweepD2Seizure with + burner = admin + burnerCapCid = wrongCaseCap + -- The custodian's authority is required: admin alone cannot sweep. + submitMustFail (actAs admin) do + exerciseCmd markedCid TokenAllocation_SweepD2Seizure with + burner = admin + burnerCapCid = capCid + _ <- submit (actAs admin <> actAs custodian) do + exerciseCmd markedCid TokenAllocation_SweepD2Seizure with + burner = admin + burnerCapCid = capCid + aliceAfter <- holdingAmounts alice + aliceAfter === [] + custodianAfter <- holdingAmounts custodian + custodianAfter === [10.0] + +-- | HIGH-4: a lawful-process sweep needs a SeizureOrder signed by a non-admin +-- authority in the trusted registry; a free-text reference is no longer enough. +testFixLawfulProcessNeedsOrder : Script () +testFixLawfulProcessNeedsOrder = do + admin <- allocateParty "admin" + app <- allocateParty "app" + alice <- allocateParty "alice" + bob <- allocateParty "bob" + custodian <- allocateParty "custodian" + attester <- allocateParty "attester" + setTime t1 + registryCid <- submit admin do + createCmd TrustedAttesterRegistry with + admin + attesters = [attester] + acceptedClaimKinds = ["kyc-ok"] + rulesCid <- submit admin do + createCmd TokenRules with + admin + maxTTL = days 90 + lockGrace = hours 1 + maxSeizureExtension = days 30 + requiredAttesterRegistryCid = Some registryCid + maxAttestationValidity = days 7 + d1ComplianceHook = None + allowedExecutors = None + Some rulesDisclosure <- queryDisclosure @TokenRules admin rulesCid + let settlement = AllocationV2.SettlementInfo with + executors = [app]; id = "settlement-1"; cid = None; meta = emptyMetadata + leg = mkTransferLeg "leg-1" alice bob 10.0 + s = Scenario with + admin; app; alice; bob; custodian; attester; rulesCid; rulesDisclosure + settlement + legAliceToBob = leg + legBobToAlice = mkTransferLeg "leg-2" bob alice 4.0 + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide leg] [aliceInput] + aliceAllocCid <- completedCid aliceResult + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + hook = D2SeizureHook with + seizureCaseRef = "case-1" + custodianDestination = basicAccount custodian + inFlightHandlingStatus = "held" + windowEnd = t3 + markedCid <- submit (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = hook + capCid <- submit admin do + createCmd BurnerCapability with + admin; assignee = admin; instrumentScope = None + caseScope = None; expiresAt = t3 + -- An order signed by the admin itself is not in the trusted attester set. + badOrderCid <- submit admin do + createCmd SeizureOrder with + authority = admin + admin + caseRef = "case-1" + subjectAccount = basicAccount alice + custodianDestination = basicAccount custodian + expiresAt = t3 + submitMustFail (actAs admin <> actAs custodian) do + exerciseCmd markedCid TokenAllocation_SweepD2WithLawfulProcess with + burner = admin + burnerCapCid = capCid + seizureOrderCid = badOrderCid + -- A properly signed order authorizes the sweep. + orderCid <- submit attester do + createCmd SeizureOrder with + authority = attester + admin + caseRef = "case-1" + subjectAccount = basicAccount alice + custodianDestination = basicAccount custodian + expiresAt = t3 + _ <- submit (actAs admin <> actAs custodian <> discloseMany [rulesDisclosure]) do + exerciseCmd markedCid TokenAllocation_SweepD2WithLawfulProcess with + burner = admin + burnerCapCid = capCid + seizureOrderCid = orderCid + custodianAfter <- holdingAmounts custodian + custodianAfter === [10.0] + +-- | D2 lapse-point regression: a seizure of an allocation with NO settlement +-- deadline still freezes. When the window was optional, a windowless mark on a +-- deadline-less allocation left the lapse check vacuous, so the seized party +-- could release it in the same instant and withdraw — the freeze was a no-op. +-- The window is now mandatory and must be in the future, so the freeze holds +-- until `windowEnd` and the anti-strand release works only after it. +testFixNoDeadlineSeizureStillFreezes : Script () +testFixNoDeadlineSeizureStillFreezes = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + let spec = (mkAllocationSpec admin alice [senderSide legAliceToBob]) with + settlementDeadline = None + aliceResult <- allocateSpec s alice spec [aliceInput] + aliceAllocCid <- completedCid aliceResult + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + hook = D2SeizureHook with + seizureCaseRef = "case-no-deadline" + custodianDestination = basicAccount custodian + inFlightHandlingStatus = "held" + windowEnd = t3 + -- An already-lapsed window cannot open the seizure. + submitMustFail (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = hook with windowEnd = t0 + markedCid <- submit (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with seizureHook = hook + -- While the window is open, the seized party can neither release the mark + -- nor withdraw around it. + submitMustFail (actAs alice) do + exerciseCmd markedCid TokenAllocation_ReleaseLapsedD2Seizure with actor = alice + submitMustFail (actAs alice) do + exerciseCmd (toInterfaceContractId @AllocationV2.Allocation markedCid) + AllocationV2.Allocation_Withdraw with + actors = [alice] + extraArgs = emptyExtraArgs + -- Once the window lapses, the anti-strand release opens up again. + setTime t4 + releasedCid <- submit (actAs alice) do + exerciseCmd markedCid TokenAllocation_ReleaseLapsedD2Seizure with actor = alice + _ <- submit (actAs alice) do + exerciseCmd (toInterfaceContractId @AllocationV2.Allocation releasedCid) + AllocationV2.Allocation_Withdraw with + actors = [alice] + extraArgs = emptyExtraArgs + aliceAfter <- holdingAmounts alice + aliceAfter === [10.0] + +-- | The admin can stand down an active seizure it will not sweep, restoring +-- the normal lifecycle immediately — no waiting for the window to lapse. +testD2UnmarkRestoresLifecycle : Script () +testD2UnmarkRestoresLifecycle = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + markedCid <- submit (actAs admin) do + exerciseCmd templateCid TokenAllocation_MarkD2Seizure with + seizureHook = D2SeizureHook with + seizureCaseRef = "case-1" + custodianDestination = basicAccount custodian + inFlightHandlingStatus = "held" + windowEnd = t3 + -- Only the admin can unmark; the seized party must wait for the lapse. + submitMustFail (actAs alice) do + exerciseCmd markedCid TokenAllocation_UnmarkD2Seizure + unmarkedCid <- submit (actAs admin) do + exerciseCmd markedCid TokenAllocation_UnmarkD2Seizure + _ <- submit (actAs alice) do + exerciseCmd (toInterfaceContractId @AllocationV2.Allocation unmarkedCid) + AllocationV2.Allocation_Withdraw with + actors = [alice] + extraArgs = emptyExtraArgs + aliceAfter <- holdingAmounts alice + aliceAfter === [10.0] + +-- | The allocation-side admin GC mirrors the transfer-side one: unavailable +-- while the funding lock is live, and once the lock has expired the shell can +-- be removed while the authorizer self-recovers the funding. +testAllocationAdminGC : Script () +testAllocationAdminGC = do + s@Scenario{..} <- setup + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob] [aliceInput] + aliceAllocCid <- completedCid aliceResult + let templateCid = fromInterfaceContractId @TokenAllocation aliceAllocCid + submitMustFail (actAs admin) do + exerciseCmd templateCid TokenAllocation_AdminGC + -- t4 is past lockExpiresAt (settlementDeadline t2 + lockGrace 1h). + setTime t4 + _ <- submit (actAs admin) do + exerciseCmd templateCid TokenAllocation_AdminGC + gcd <- queryContractId admin templateCid + gcd === None + lockedHoldings <- query @TokenHolding alice + forA_ [cid | (cid, h) <- lockedHoldings, isSome h.holding.lock] $ \cid -> + submit (actAs alice <> actAs admin) do + exerciseCmd cid TokenHolding_OwnerUnlock + aliceAfter <- holdingAmounts alice + aliceAfter === [10.0] + +-- | Every standalone housekeeping contract is archivable by its signatory, so +-- stale configuration and spent authorities do not accumulate on the ledger. +testHousekeepingArchives : Script () +testHousekeepingArchives = do + admin <- allocateParty "admin" + attester <- allocateParty "attester" + alice <- allocateParty "alice" + custodian <- allocateParty "custodian" + setTime t1 + rulesCid <- submit admin do + createCmd TokenRules with + admin + maxTTL = days 90 + lockGrace = hours 1 + maxSeizureExtension = days 30 + requiredAttesterRegistryCid = None + maxAttestationValidity = days 7 + d1ComplianceHook = None + allowedExecutors = None + registryCid <- submit admin do + createCmd TrustedAttesterRegistry with + admin + attesters = [attester] + acceptedClaimKinds = ["kyc-ok"] + capCid <- submit admin do + createCmd BurnerCapability with + admin + assignee = admin + instrumentScope = None + caseScope = None + expiresAt = t3 + attestationCid <- submit attester do + createCmd ComplianceAttestation with + attester + attestationObservers = [] + settlementId = "settlement-1" + authorizedExecutors = [admin] + claimKind = "kyc-ok" + complianceReference = "ref-1" + issuedAt = t1 + expiresAt = t3 + boundTransferLegs = [mkTransferLeg "leg-1" alice custodian 1.0] + orderCid <- submit attester do + createCmd SeizureOrder with + authority = attester + admin + caseRef = "case-1" + subjectAccount = basicAccount alice + custodianDestination = basicAccount custodian + expiresAt = t3 + submit admin do archiveCmd rulesCid + submit admin do archiveCmd registryCid + submit admin do archiveCmd capCid + submit attester do archiveCmd attestationCid + submit attester do archiveCmd orderCid + + +-- D1 compliance gate +--------------------- + +data D1Scenario = D1Scenario with + s : Scenario + registryCid : ContractId TrustedAttesterRegistry + registryDisclosure : Disclosure + +setupD1 : Script D1Scenario +setupD1 = do + admin <- allocateParty "admin" + app <- allocateParty "app" + alice <- allocateParty "alice" + bob <- allocateParty "bob" + custodian <- allocateParty "custodian" + attester <- allocateParty "attester" + setTime t1 + registryCid <- submit admin do + createCmd TrustedAttesterRegistry with + admin + attesters = [attester] + acceptedClaimKinds = ["kyc-ok"] + Some registryDisclosure <- queryDisclosure @TrustedAttesterRegistry admin registryCid + rulesCid <- submit admin do + createCmd TokenRules with + admin + maxTTL = days 90 + lockGrace = hours 1 + maxSeizureExtension = days 30 + requiredAttesterRegistryCid = Some registryCid + maxAttestationValidity = days 7 + d1ComplianceHook = Some D1ComplianceHook with + hookRef = "node-compliance-v1" + requiresPerSettlementReference = True + allowedExecutors = None + Some rulesDisclosure <- queryDisclosure @TokenRules admin rulesCid + let settlement = AllocationV2.SettlementInfo with + executors = [app]; id = "settlement-1"; cid = None; meta = emptyMetadata + pure D1Scenario with + registryCid + registryDisclosure + s = Scenario with + admin; app; alice; bob; custodian; attester; rulesCid; rulesDisclosure + settlement + legAliceToBob = mkTransferLeg "leg-1" alice bob 10.0 + legBobToAlice = mkTransferLeg "leg-2" bob alice 4.0 + +mkAttestation + : D1Scenario -> Text -> [AllocationV2.TransferLeg] -> [Party] -> Text + -> Script (ContractId ComplianceAttestation) +mkAttestation D1Scenario{s} settlementId legs authorizedExecutors claimKind = + submit s.attester do + createCmd ComplianceAttestation with + attester = s.attester + attestationObservers = [s.admin] + settlementId + authorizedExecutors + claimKind + complianceReference = "ref-" <> settlementId + issuedAt = t0 + expiresAt = t3 + boundTransferLegs = legs + +attestationContext : ContractId ComplianceAttestation -> ExtraArgs +attestationContext attCid = ExtraArgs with + context = ChoiceContext with + values = TextMap.fromList [(d1AttestationContextKey, AV_ContractId (toAnyContractId attCid))] + meta = emptyMetadata + +fundBothLegs : Scenario -> Script (ContractId AllocationV2.Allocation, ContractId AllocationV2.Allocation) +fundBothLegs s@Scenario{..} = do + aliceInput <- mint admin alice 10.0 + aliceResult <- allocate s alice [senderSide legAliceToBob, receiverSide legBobToAlice] [aliceInput] + aliceAllocCid <- completedCid aliceResult + bobResult <- allocate s bob [receiverSide legAliceToBob, senderSide legBobToAlice] [] + bobAllocCid <- completedCid bobResult + pure (aliceAllocCid, bobAllocCid) + +-- | HIGH-1/HIGH-2: a D1-gated registry settles only with a valid attestation, +-- and refuses one with no attestation at all. +testD1GateHappyPathAndMissingAttestation : Script () +testD1GateHappyPathAndMissingAttestation = do + d1@D1Scenario{s, registryDisclosure} <- setupD1 + let Scenario{..} = s + (aliceAllocCid, bobAllocCid) <- fundBothLegs s + -- No attestation in the context: refused. + submitMustFail (actAs app <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [legAliceToBob, legBobToAlice] + allocations = map nonIteratedAllocation [aliceAllocCid, bobAllocCid] + actors = [app] + extraArgs = emptyExtraArgs + -- With a content-matching attestation, settlement proceeds. + attCid <- mkAttestation d1 "settlement-1" [legAliceToBob, legBobToAlice] [app] "kyc-ok" + _ <- submit (actAs app <> discloseMany [rulesDisclosure, registryDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [legAliceToBob, legBobToAlice] + allocations = map nonIteratedAllocation [aliceAllocCid, bobAllocCid] + actors = [app] + extraArgs = attestationContext attCid + bobAfter <- holdingAmounts bob + bobAfter === [6.0] + +-- | HIGH-1: an attestation issued over one set of legs cannot be re-pointed at +-- a different trade that merely reuses the settlement id and leg ids. +testD1AttestationBindsLegContent : Script () +testD1AttestationBindsLegContent = do + d1@D1Scenario{s, registryDisclosure} <- setupD1 + let Scenario{..} = s + -- Attester signs off on a benign 1.0 trade over the same leg ids. + let benignLeg1 = mkTransferLeg "leg-1" alice bob 1.0 + benignLeg2 = mkTransferLeg "leg-2" bob alice 1.0 + attCid <- mkAttestation d1 "settlement-1" [benignLeg1, benignLeg2] [app] "kyc-ok" + (aliceAllocCid, bobAllocCid) <- fundBothLegs s + -- The real batch moves 10.0/4.0 under the same ids: rejected on content. + submitMustFail (actAs app <> discloseMany [rulesDisclosure, registryDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [legAliceToBob, legBobToAlice] + allocations = map nonIteratedAllocation [aliceAllocCid, bobAllocCid] + actors = [app] + extraArgs = attestationContext attCid + +-- | HIGH-1: a claim kind the registry does not accept fails the gate, so a +-- "sanctions-hit" attestation is not a pass. +testD1RejectsUnacceptedClaimKind : Script () +testD1RejectsUnacceptedClaimKind = do + d1@D1Scenario{s, registryDisclosure} <- setupD1 + let Scenario{..} = s + attCid <- mkAttestation d1 "settlement-1" [legAliceToBob, legBobToAlice] [app] "sanctions-hit" + (aliceAllocCid, bobAllocCid) <- fundBothLegs s + submitMustFail (actAs app <> discloseMany [rulesDisclosure, registryDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationV2.SettlementFactory rulesCid) + AllocationV2.SettlementFactory_SettleBatch with + settlement + transferLegs = [legAliceToBob, legBobToAlice] + allocations = map nonIteratedAllocation [aliceAllocCid, bobAllocCid] + actors = [app] + extraArgs = attestationContext attCid + +-- | MED-3: the attestation names the executors it was issued to, so an +-- observer cannot burn it by naming itself as the executor. +testD1AttestationNotBurnableByObserver : Script () +testD1AttestationNotBurnableByObserver = do + d1@D1Scenario{s, registryCid, registryDisclosure} <- setupD1 + let Scenario{..} = s + attCid <- mkAttestation d1 "settlement-1" [legAliceToBob, legBobToAlice] [app] "kyc-ok" + -- The admin is an attestation observer but not an authorized executor. + submitMustFail (actAs admin <> discloseMany [registryDisclosure]) do + exerciseCmd attCid ComplianceAttestation_Verify with + settlement = settlement with executors = [admin] + transferLegs = [legAliceToBob, legBobToAlice] + registryCid + factoryAdmin = admin + maxValidity = days 7 + -- The attestation is still there for the legitimate executor. + still <- queryContractId admin attCid + isSome still === True + +-- | LOW-4: attesters rotate in place, so the cid pinned on TokenRules +-- keeps resolving. +testD1RegistryUpdatesInPlace : Script () +testD1RegistryUpdatesInPlace = do + D1Scenario{s, registryCid} <- setupD1 + let Scenario{..} = s + newAttester <- allocateParty "attester2" + updatedCid <- submit admin do + exerciseCmd registryCid TrustedAttesterRegistry_Update with + newAttesters = [newAttester] + newAcceptedClaimKinds = ["kyc-ok", "enhanced-dd"] + -- A fresh contract id is returned, and an empty attester set is refused. + updatedCid =/= registryCid + submitMustFail admin do + exerciseCmd updatedCid TrustedAttesterRegistry_Update with + newAttesters = [] + newAcceptedClaimKinds = ["kyc-ok"] + +-- | Registry misconfiguration is refused: a non-positive maxTTL or lockGrace +-- would let the admin expire everything immediately. +testFixRulesConfigValidated : Script () +testFixRulesConfigValidated = do + admin <- allocateParty "admin" + setTime t1 + let base = TokenRules with + admin + maxTTL = days 90 + lockGrace = hours 1 + maxSeizureExtension = days 30 + requiredAttesterRegistryCid = None + maxAttestationValidity = days 7 + d1ComplianceHook = None + allowedExecutors = None + submitMustFail admin do createCmd base with maxTTL = minutes 0 + submitMustFail admin do createCmd base with lockGrace = minutes 0 + submitMustFail admin do createCmd base with allowedExecutors = Some [] + +-- | Capability gap: issuance now has an evented path, so supply changes are +-- visible to standard history parsers instead of appearing as bare creates. +testMintAndBurnEmitEvents : Script () +testMintAndBurnEmitEvents = do + Scenario{..} <- setup + holdingCid <- submit (actAs admin <> actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_Mint with + account = basicAccount alice + instrumentId = "TOK" + amount = 25.0 + reason = "initial issuance" + aliceAfter <- holdingAmounts alice + aliceAfter === [25.0] + -- Minting a non-positive amount is refused. + submitMustFail (actAs admin <> actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_Mint with + account = basicAccount alice + instrumentId = "TOK" + amount = 0.0 + reason = "bad" + -- Burning requires the account's authority and clears the holding. + submitMustFail (actAs admin <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_Burn with + holdingCid + account = basicAccount alice + reason = "redeem" + _ <- submit (actAs admin <> actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd rulesCid TokenRules_Burn with + holdingCid + account = basicAccount alice + reason = "redeem" + aliceFinal <- holdingAmounts alice + aliceFinal === [] + +-- | MED-6: when an allowlist is configured, an unlisted executor cannot pull +-- other parties into a settlement. +testFixExecutorAllowlist : Script () +testFixExecutorAllowlist = do + admin <- allocateParty "admin" + app <- allocateParty "app" + rogue <- allocateParty "rogue" + alice <- allocateParty "alice" + bob <- allocateParty "bob" + setTime t1 + rulesCid <- submit admin do + createCmd TokenRules with + admin + maxTTL = days 90 + lockGrace = hours 1 + maxSeizureExtension = days 30 + requiredAttesterRegistryCid = None + maxAttestationValidity = days 7 + d1ComplianceHook = None + allowedExecutors = Some [app] + Some rulesDisclosure <- queryDisclosure @TokenRules admin rulesCid + aliceInput <- mint admin alice 10.0 + let rogueSettlement = AllocationV2.SettlementInfo with + executors = [rogue]; id = "s-rogue"; cid = None; meta = emptyMetadata + submitMustFail (actAs alice <> discloseMany [rulesDisclosure]) do + exerciseCmd (toInterfaceContractId @AllocationInstructionV2.AllocationFactory rulesCid) + AllocationInstructionV2.AllocationFactory_Allocate with + settlement = rogueSettlement + allocation = mkAllocationSpec admin alice [senderSide (mkTransferLeg "leg-1" alice bob 10.0)] + requestedAt = t0 + inputHoldingCids = [toInterfaceContractId @HoldingV2.Holding aliceInput] + extraArgs = emptyExtraArgs + actors = [alice] diff --git a/multi-package.yaml b/multi-package.yaml index 8c76f64..f8fda31 100644 --- a/multi-package.yaml +++ b/multi-package.yaml @@ -18,4 +18,9 @@ packages: - experiments/settlement/cip-0112 - experiments/settlement/test - experiments/settlement/exemplar + # Builds against the vendored Token Standard V2 DARs (dars/token-standard/, + # compiled with dpm-sdk 3.5.1, LF 2.1), consumed cross-SDK from the 3.4.11 + # baseline. + - experiments/settlement/cip-0112-v2 + - experiments/settlement/cip-0112-v2/test - experiments/interoperability/cip-exemplar diff --git a/scripts/check.sh b/scripts/check.sh index add361b..f643b4c 100755 --- a/scripts/check.sh +++ b/scripts/check.sh @@ -82,7 +82,7 @@ while IFS= read -r manifest; do done <<< "$actual_manifests" if grep -R -n -E \ - --exclude-dir=.git --exclude-dir=.daml --exclude-dir=.cache --exclude-dir=.vscode \ + --exclude-dir=.git --exclude-dir=.daml --exclude-dir=.cache --exclude-dir=.vscode --exclude-dir=.claude \ --exclude='*.dar' --exclude='check.sh' \ '/Users/|/home/[^/]+/|/private/tmp/|/var/folders/|[A-Za-z]:\\Users\\' "$ROOT"; then fail "repository content contains a machine-specific home path" @@ -103,7 +103,7 @@ artifact_lines="$(awk ' manifest_artifacts="$(printf '%s\n' "$artifact_lines" | cut -f3 | sort)" vendored_artifacts="$( - find "$ROOT/dars/vendor" -maxdepth 1 -type f -name '*.dar' -print | + find "$ROOT/dars/vendor" "$ROOT/dars/token-standard" -maxdepth 1 -type f -name '*.dar' -print | sed "s#^$ROOT/##" | sort )" || fail "failed to discover vendored DARs" @@ -112,7 +112,7 @@ vendored_artifacts="$( while IFS=$'\t' read -r package version file package_id expected; do case "$file" in - dars/vendor/*.dar) ;; + dars/vendor/*.dar | dars/token-standard/*.dar) ;; *) fail "dars/manifest.yaml contains an unsafe artifact path: $file" ;; esac case "$file" in