From e7cc72425917f215e61c656195682a6c99d38027 Mon Sep 17 00:00:00 2001 From: "moritz.kiefer@digitalasset.com" Date: Mon, 29 Jun 2026 14:08:17 +0200 Subject: [PATCH 01/30] Dso Governance POC Current limitations: 1. The split between governance and operator votes is a placeholder. 2. The tests are a joke. Given that I think at this stage this is more about how we arrange stuff this hopefully doesn't detract from review too much. 3. There are some open questions on the migration. 4. We may want to move beneficiaries to a different place. Signed-off-by: moritz.kiefer@digitalasset.com --- .../sv/onboarding/sv1/SV1Initializer.scala | 3 + .../Scripts/DsoTestRewardAccountingV2.daml | 1 - .../daml/Splice/Scripts/DsoTestUtils.daml | 98 ++- .../Scripts/TestDecentralizedAutomation.daml | 6 +- .../daml/Splice/Scripts/TestGovernance.daml | 14 +- .../Scripts/TestGovernanceRefactor.daml | 83 ++ .../daml/Splice/Scripts/TestOnboarding.daml | 38 +- .../daml/Splice/Scripts/TestSvRewards.daml | 27 +- .../Scripts/TestSynchronizerMigration.daml | 4 +- .../daml/Splice/DSO/SvRightOwner.daml | 31 + .../daml/Splice/DSO/SvState.daml | 2 +- .../daml/Splice/DsoBootstrap.daml | 42 +- .../daml/Splice/DsoRules.daml | 768 +++++++++++++----- 13 files changed, 814 insertions(+), 303 deletions(-) create mode 100644 daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml create mode 100644 daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml diff --git a/apps/sv/src/main/scala/org/lfdecentralizedtrust/splice/sv/onboarding/sv1/SV1Initializer.scala b/apps/sv/src/main/scala/org/lfdecentralizedtrust/splice/sv/onboarding/sv1/SV1Initializer.scala index 77b46c1545..e5fe32571e 100644 --- a/apps/sv/src/main/scala/org/lfdecentralizedtrust/splice/sv/onboarding/sv1/SV1Initializer.scala +++ b/apps/sv/src/main/scala/org/lfdecentralizedtrust/splice/sv/onboarding/sv1/SV1Initializer.scala @@ -733,6 +733,9 @@ class SV1Initializer( .asJava, sv1Config.isDevNet, java.util.Optional.of(initialRound), + // FIXME: Make configurablze + java.util.Optional.empty(), + java.util.Optional.empty(), ).createAnd.exerciseDsoBootstrap_Bootstrap, ) .withDedup( diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestRewardAccountingV2.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestRewardAccountingV2.daml index 6a384648da..82b7f0dc5c 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestRewardAccountingV2.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestRewardAccountingV2.daml @@ -212,4 +212,3 @@ test_ArchiveDryRunRewardAccountingV2 = do -- check that no coupons were created [] <- query @RewardCouponV2 app.dso pure () - diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml index fefc74eef1..020ee35790 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml @@ -12,6 +12,7 @@ import qualified DA.Map as Map import DA.Optional (fromOptional) import qualified DA.Set as Set import qualified DA.Text as T +import qualified DA.TextMap as TextMap import Daml.Script import DA.Time @@ -33,34 +34,38 @@ import Splice.DsoBootstrap import Splice.DSO.AmuletPrice import Splice.DSO.DecentralizedSynchronizer import Splice.DSO.SvState +import Splice.DSO.SvRightOwner import Splice.Scripts.AnsRulesParameters -import Splice.Util -- | Multiplier for the SV weights, which are recorded in basis-points, i.e., 1/10000ths bpsMultiplier : Int bpsMultiplier = 10000 initMainNet : Script (AmuletApp, Party, (Party, Party, Party, Party)) -initMainNet = initDecentralizedSynchronizer False None +initMainNet = initDecentralizedSynchronizer False None True + + +initMainNetNoOnLedgerSvRightOwners : Script (AmuletApp, Party, (Party, Party, Party, Party)) +initMainNetNoOnLedgerSvRightOwners = initDecentralizedSynchronizer False None False initMainNetWithAmuletPrice : Decimal -> Script (AmuletApp, Party, (Party, Party, Party, Party)) -initMainNetWithAmuletPrice amuletPrice = initDecentralizedSynchronizerWithAmuletPrice False 0 amuletPrice None +initMainNetWithAmuletPrice amuletPrice = initDecentralizedSynchronizerWithAmuletPrice False 0 amuletPrice None True initDevNet : Script (AmuletApp, Party, (Party, Party, Party, Party)) -initDevNet = initDecentralizedSynchronizer True None +initDevNet = initDecentralizedSynchronizer True None True initDevNetWithAmuletConfig : AmuletConfig USD -> Script (AmuletApp, Party, (Party, Party, Party, Party)) -initDevNetWithAmuletConfig amuletConfig = initDecentralizedSynchronizer True (Some amuletConfig) +initDevNetWithAmuletConfig amuletConfig = initDecentralizedSynchronizer True (Some amuletConfig) True -initDecentralizedSynchronizer : Bool -> Optional (AmuletConfig USD) -> Script (AmuletApp, Party, (Party, Party, Party, Party)) -initDecentralizedSynchronizer isDevNet optAmuletConfig = initDecentralizedSynchronizerWithAmuletPrice isDevNet 0 1.0 optAmuletConfig +initDecentralizedSynchronizer : Bool -> Optional (AmuletConfig USD) -> Bool -> Script (AmuletApp, Party, (Party, Party, Party, Party)) +initDecentralizedSynchronizer isDevNet optAmuletConfig onLedgerSvRightOwners = initDecentralizedSynchronizerWithAmuletPrice isDevNet 0 1.0 optAmuletConfig onLedgerSvRightOwners -initDecentralizedSynchronizerWithNonZeroRound : Bool -> Int -> Script (AmuletApp, Party, (Party, Party, Party, Party)) -initDecentralizedSynchronizerWithNonZeroRound isDevNet initialRound = initDecentralizedSynchronizerWithAmuletPrice isDevNet initialRound 1.0 None +initDecentralizedSynchronizerWithNonZeroRound : Bool -> Int -> Bool -> Script (AmuletApp, Party, (Party, Party, Party, Party)) +initDecentralizedSynchronizerWithNonZeroRound isDevNet initialRound onLedgerSvRightOwners = initDecentralizedSynchronizerWithAmuletPrice isDevNet initialRound 1.0 None onLedgerSvRightOwners -initDecentralizedSynchronizerWithAmuletPrice : Bool -> Int -> Decimal -> Optional (AmuletConfig USD) -> Script (AmuletApp, Party, (Party, Party, Party, Party)) -initDecentralizedSynchronizerWithAmuletPrice isDevNet initialRound amuletPrice optAmuletConfig = do +initDecentralizedSynchronizerWithAmuletPrice : Bool -> Int -> Decimal -> Optional (AmuletConfig USD) -> Bool -> Script (AmuletApp, Party, (Party, Party, Party, Party)) +initDecentralizedSynchronizerWithAmuletPrice isDevNet initialRound amuletPrice optAmuletConfig onLedgerSvRightOwners = do [sv1, sv2, sv3, sv4] <- forA ["sv1", "sv2", "sv3", "sv4"] allocateParty dso <- allocateParty "dso-party" @@ -129,6 +134,8 @@ initDecentralizedSynchronizerWithAmuletPrice isDevNet initialRound amuletPrice o initialTrafficState = Map.empty isDevNet initialRound = Some initialRound + sv1RightOwnerName = if onLedgerSvRightOwners then Some "sv1" else None + sv1VoteWeight = if onLedgerSvRightOwners then Some 1 else None DsoBootstrap_Bootstrap dsoUserId <- validateUserId "dso-user" @@ -136,32 +143,43 @@ initDecentralizedSynchronizerWithAmuletPrice isDevNet initialRound amuletPrice o -- add more sv nodes forA_ (zip [sv2, sv3, sv4] ["sv2", "sv3", "sv4"]) $ \(svParty, svName) -> do + let rewardWeight = 3 * bpsMultiplier -- Simulate the new nodes being Tier 2 SV nodes [(dsoRulesCid, _)] <- query @DsoRules dso submit (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid $ DsoRules_OnboardValidator with sponsor = sv1 validator = svParty version = Some "0.1.0" contactPoint = Some (svName <> "@example.com") - (_, earliestOpenRound) <- head <$> getOpenRoundsSorted app - submit dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv with + (earliestOpenRoundCid, earliestOpenRound) <- head <$> getOpenRoundsSorted app + result <- submit dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv with newSvParty = svParty newSvName = svName - newSvRewardWeight = 3 * bpsMultiplier -- Simulate the new nodes being Tier 2 SV nodes + newSvRewardWeight = if onLedgerSvRightOwners then 0 else rewardWeight newSvParticipantId = svName <> "-participant-id" joinedAsOfRound = earliestOpenRound.round - + when onLedgerSvRightOwners $ do + instructionCid <- submit dso $ exerciseCmd result.newDsoRules $ DsoRules_AddSvRightOwner with + rightOwnerName = svName + info = SvRightOwnerInfo with + rightOwnerParty = svParty + voteWeight = 1 + rewardWeight = rewardWeight + rewardNodeOperatorName = svName + beneficiaries = [] + void $ submit (actAs sv1 <> readAs dso) $ exerciseCmd result.newDsoRules DsoRules_ExecuteAddSvRightOwnerInstruction with + instructionCid + openMiningRoundCid = earliestOpenRoundCid + svOperator = sv1 -- check that the SvStatusReports are present checkSvContractInvariants app pure (app, dso, (sv1, sv2, sv3, sv4)) -getSvInfoByParty : AmuletApp -> Party -> Script SvInfo +getSvInfoByParty : AmuletApp -> Party -> Script (Text, SvInfo) getSvInfoByParty app sv = do [(_, rules)] <- query @DsoRules app.dso - case Map.lookup sv rules.svs of - None -> fail $ "Not a sv: " <> show sv - Some info -> pure info + getSvInfoByOperatorParty sv rules generateUnclaimedReward : AmuletApp -> AmuletUser -> Script () generateUnclaimedReward app provider1 = do @@ -181,13 +199,13 @@ generateUnclaimedReward app provider1 = do dsoDelegateSubmits : AmuletApp -> (ContractId DsoRules -> Commands a) -> Script a dsoDelegateSubmits app mkCommands = do [(dsoRulesCid, dsoRules)] <- query @DsoRules app.dso - let sv = head (Map.keys dsoRules.svs) + let sv = head (operatorParties dsoRules) submit (actAs sv <> readAs app.dso) $ mkCommands dsoRulesCid dsoDelegateSubmitsMustFail : AmuletApp -> (ContractId DsoRules -> Commands a) -> Script () dsoDelegateSubmitsMustFail app mkCommands = do [(dsoRulesCid, dsoRules)] <- query @DsoRules app.dso - let sv = head (Map.keys dsoRules.svs) + let sv = head (operatorParties dsoRules) submitMustFail (actAs sv <> readAs app.dso) $ mkCommands dsoRulesCid svSubmits : AmuletApp -> Party -> (ContractId DsoRules -> Commands a) -> Script a @@ -228,7 +246,7 @@ runNextIssuanceD app amuletPrice appActivityRoundTotal = do svRewardCouponCids = map fst svRewards optValidatorFaucetCouponCids = Some (map fst validatorFaucetCoupons) optValidatorLivenessActivityRecordCids = Some (map fst validatorLivenessActivityRecords) - sv = Some (head (Map.keys dsoRules.svs)) + sv = Some (head (operatorParties dsoRules)) -- the closed round confirmAWC_MiningRound_Archive app @@ -255,7 +273,7 @@ runNextIssuanceD app amuletPrice appActivityRoundTotal = do middleRoundCid = r2Cid latestRoundCid = r3Cid amuletPriceVoteCids - sv = Some (head (Map.keys dsoRules.svs)) + sv = Some (head (operatorParties dsoRules)) let summarizingRoundCid = advanceResult.summarizingRound Some summarizingRound <- queryContractId app.dso summarizingRoundCid @@ -322,7 +340,7 @@ confirmAWC_MiningRound_Archive app = do confirmAndExecutionAction : AmuletApp -> ActionRequiringConfirmation -> Script () confirmAndExecutionAction app action = do [(dsoRulesCid, rules)] <- query @DsoRules app.dso - forA_ (Map.keys rules.svs) $ \sv -> do + forA_ (operatorParties rules) $ \sv -> do -- mallory does not act unless ("mallory" `T.isPrefixOf` partyToText sv) $ do submit (actAs sv <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_ConfirmAction with @@ -335,37 +353,37 @@ executeAllConfirmedActions : AmuletApp -> Script () executeAllConfirmedActions app = do [(amuletRulesCid, _)] <- query @AmuletRules app.dso [(dsoRulesCid, rules)] <- query @DsoRules app.dso - let s = summarizeDso rules -- query all confirmations visible to DSO party confirmations0 <- query @Confirmation app.dso -- execute the actions for which there are enough confirmations let executableConfirmations = filter (const True) -- (\cs -> s.requiredNumConfirmations <= length cs) $ groupEqualOn (\c -> c._2.action) confirmations0 + submitter = head (operatorParties rules) forA_ executableConfirmations $ \cs -> do - submit (actAs s.dsoDelegate <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_ExecuteConfirmedAction with + submit (actAs submitter <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_ExecuteConfirmedAction with action = (head cs)._2.action amuletRulesCid = Some amuletRulesCid confirmationCids = map fst cs - sv = Some s.dsoDelegate + sv = Some submitter executeAllDefinitiveVotes : AmuletApp -> Script () executeAllDefinitiveVotes app = do [(amuletRulesCid, _)] <- query @AmuletRules app.dso [(dsoRulesCid, rules)] <- query @DsoRules app.dso - let s = summarizeDso rules + let submitter = head (operatorParties rules) -- query all voting requests visible to DSO party now <- getTime requests <- query @VoteRequest app.dso forA_ requests $ \(requestCid, request) -> do - let activeSvs = Set.fromList $ map (.name) $ Map.values rules.svs + let activeSvs = Set.fromList (map fst $ TextMap.toList (getSvRightOwners rules)) let execute = request.voteBefore <= now || (activeSvs == Set.fromList (Map.keys request.votes)) when execute $ do - void $ submit (actAs s.dsoDelegate <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_CloseVoteRequest with + void $ submit (actAs submitter <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_CloseVoteRequest with requestCid amuletRulesCid = Some amuletRulesCid - sv = Some s.dsoDelegate + sv = Some submitter initiateAndCastVote : AmuletApp -> [Party] -> Optional Time -> ActionRequiringConfirmation -> Script (ContractId VoteRequest) initiateAndCastVote _ [] _ _ = error "initiateVote: require at least one party" @@ -447,27 +465,23 @@ checkSvRewardStates : AmuletApp -> Script () checkSvRewardStates app = do rewardStates <- query @SvRewardState app.dso [(_, dsoRules)] <- query @DsoRules app.dso - forA_ (Map.values dsoRules.svs) $ \info -> - require "Each onboarded andSV name has one SvRewardState contract" $ - any (\(_, rewardState) -> rewardState.svName == info.name) rewardStates - forA_ (Map.values dsoRules.offboardedSvs) $ \info -> - require "Each offboarded and SV name has one SvRewardState contract" $ - any (\(_, rewardState) -> rewardState.svName == info.name) rewardStates - let offAndOnboardedSvs = Set.fromList (map (\info -> info.name) (Map.values dsoRules.svs) <> map (\info -> info.name) (Map.values dsoRules.offboardedSvs)) - Set.fromList [state.svName | (_, state) <- rewardStates] === offAndOnboardedSvs - require "No duplicate SvRewardstate contracts" $ - length rewardStates == Set.size offAndOnboardedSvs + if onLedgerSvRightOwners dsoRules then + Set.fromList [state.svName | (_, state) <- rewardStates] === Set.fromList (map fst (TextMap.toList (getSvRightOwners dsoRules))) + else + Set.fromList [state.svName | (_, state) <- rewardStates] === Set.fromList (map (.name) (Map.values dsoRules.svs)) + -- | Check that there's exactly one status report per SV both off-boarded and onboarded. checkSvStatusReports : AmuletApp -> Script () checkSvStatusReports app = do [(_, dsoRules)] <- query @DsoRules app.dso - let svParties = Map.keys dsoRules.svs + let svParties = operatorParties dsoRules let offboardedParties = Map.keys dsoRules.offboardedSvs let expectedSvParties = Set.fromList $ svParties ++ offboardedParties reports <- query @SvStatusReport app.dso let reportingParties = Set.fromList $ [ report.sv | (_, report) <- reports ] reportingParties === expectedSvParties + pure () getSvNodeState : AmuletApp -> Party -> Script (ContractId SvNodeState, SvNodeState) getSvNodeState app sv = do diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestDecentralizedAutomation.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestDecentralizedAutomation.daml index cd33691534..0faec58037 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestDecentralizedAutomation.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestDecentralizedAutomation.daml @@ -176,7 +176,7 @@ testRequiredNumOfConfirmation = do [(amuletRulesCid, _)] <- query @AmuletRules dso [(dsoRulesCid, dsoRules)] <- query @DsoRules dso - Map.size dsoRules.svs === 4 + length (Map.toList dsoRules.svs) === 4 svX <- allocateParty "svX" @@ -185,7 +185,7 @@ testRequiredNumOfConfirmation = do dsoAction = SRARC_AddSv $ DsoRules_AddSv with newSvParty = svX newSvName = "svX" - newSvRewardWeight = 1 + newSvRewardWeight = 0 newSvParticipantId = "svX-participant-id" joinedAsOfRound = (Round 3) @@ -218,7 +218,7 @@ testRequiredNumOfConfirmation = do -- check that the `action` was executed [(_, dsoRules)] <- query @DsoRules dso - require "svX is a sv" (svX `Map.member` dsoRules.svs) + require "svX is a sv" (svX `elem` operatorParties dsoRules) pure () diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml index ca17a103b9..41b37751cb 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml @@ -387,7 +387,7 @@ testVoteRequestRejectionWithEffectivityAfterExpiration = do testRacingSvRemoval : Script () testRacingSvRemoval = do (app, dso, (sv1, sv2, sv3, sv4)) <- initMainNet - + [(dsoRulesCid, _)] <- query @DsoRules dso -- sv1 is not happy with sv2, and issues two removal requests at the same time! @@ -525,9 +525,8 @@ testRacingSvRemoval = do -- There are only two svs left, and sv3 is the new DSO delegate [(_, dsoRules)] <- query @DsoRules dso - Map.keys dsoRules.svs === [sv3, sv4] - dsoRules.dsoDelegate === sv3 - + operatorParties dsoRules === [sv3, sv4] + -- The story continues: sv3 tries to remove sv4 [(dsoRulesCid, _)] <- query @DsoRules dso result4 <- submit (actAs sv3 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with @@ -587,7 +586,7 @@ testRacingSvRemoval = do -- check the SV's are gone [(_, dsoRules)] <- query @DsoRules dso - Map.keys dsoRules.svs === [sv3] + operatorParties dsoRules === [sv3] pure () @@ -892,7 +891,7 @@ testOffboardSvAndAmuletPriceVotes = do -- the voting process is only definitive after the timeout, so right now sv1 is still present [(_, dsoRules)] <- query @DsoRules dso - Map.keys (dsoRules.svs) === [sv1, sv2, sv3, sv4] + operatorParties dsoRules === [sv1, sv2, sv3, sv4] -- pass the default voting timeout passTime (dsoRules.config.voteRequestTimeout) @@ -900,9 +899,8 @@ testOffboardSvAndAmuletPriceVotes = do -- check that the sv was removed and the DSO delegate changed to sv2 [(dsoRulesCid, dsoRules)] <- query @DsoRules dso - Map.keys (dsoRules.svs) === [sv2, sv3, sv4] + operatorParties dsoRules === [sv2, sv3, sv4] Map.keys (dsoRules.offboardedSvs) === [sv1] - dsoRules.dsoDelegate === sv2 -- duplicate the AmuletPriceVote for sv2 to test duplicate removal amuletPriceVotes <- query @AmuletPriceVote dso diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml new file mode 100644 index 0000000000..17cdbe67ee --- /dev/null +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml @@ -0,0 +1,83 @@ +-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +-- SPDX-License-Identifier: Apache-2.0 + +module Splice.Scripts.TestGovernanceRefactor where + +import DA.Action +import DA.Assert +import DA.Foldable +import DA.List (sort) +import Daml.Script +import qualified DA.TextMap as TextMap +import qualified DA.Map as Map + +import Splice.DSO.SvRightOwner +import Splice.Issuance() + + +import Splice.DsoRules +import Splice.Scripts.DsoTestUtils +import Splice.Scripts.Util + + +testGovernanceRefactor : Script () +testGovernanceRefactor = do + (app, _, (sv1, sv2, sv3, sv4)) <- initMainNet + let nonOperatorName1 = "non-operator1" + let nonOperatorName2 = "non-operator2" + rightOwnerParty1 <- allocateParty "non-operator-governance1" + rightOwnerParty2 <- allocateParty "non-operator-governance2" + initiateAndAcceptVote app [sv1, sv2, sv3, sv4] $ ARC_DsoRules $ SRARC_DsoRules_AddSvRightOwner $ DsoRules_AddSvRightOwner nonOperatorName1 SvRightOwnerInfo with + rightOwnerParty = rightOwnerParty1 + voteWeight = 4 + rewardWeight = 1000 + rewardNodeOperatorName = "sv1" + beneficiaries = [] + executeAddSvRightOwnerInstructions sv1 app + [(_, dsoRules)] <- query @DsoRules app.dso + TextMap.size (getSvRightOwners dsoRules) === 5 + voteRequest <- initiateAndCastVote app [sv1, sv2, sv3, sv4] None $ ARC_DsoRules $ SRARC_DsoRules_AddSvRightOwner $ DsoRules_AddSvRightOwner nonOperatorName2 SvRightOwnerInfo with + rightOwnerParty = rightOwnerParty2 + voteWeight = 1 + rewardWeight = 1000 + rewardNodeOperatorName = "sv1" + beneficiaries = [] + + executeAllDefinitiveVotes app + + -- we have not yet reached the vote weight + Some _ <- queryContractId app.dso voteRequest + + castVote app rightOwnerParty1 voteRequest True + + executeAllDefinitiveVotes app + executeAddSvRightOwnerInstructions sv1 app + -- now we have reached the vote weight + None <- queryContractId app.dso voteRequest + [(_, dsoRules)] <- query @DsoRules app.dso + TextMap.size (getSvRightOwners dsoRules) === 6 + pure () + +testGovernanceRefactorMigration : Script () +testGovernanceRefactorMigration = do + (app, _, (sv1, _sv2, _sv3, _sv4)) <- initMainNetNoOnLedgerSvRightOwners + [(dsoRulesCid, dsoRules)] <- query @DsoRules app.dso + dsoRules.svRightOwners === None + submit (actAs sv1 <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_MigrateToOnLedgerSvRightOwners with + svOperator = sv1 + [(_, dsoRules)] <- query @DsoRules app.dso + sort (map fst $ TextMap.toList $ getSvRightOwners dsoRules) === sort (map (.name) (Map.values dsoRules.svs)) + TextMap.size (getSvRightOwners dsoRules) === 4 + pure () + + +executeAddSvRightOwnerInstructions : Party -> AmuletApp -> Script () +executeAddSvRightOwnerInstructions sv1 app = do + instructions <- query @AddSvRightOwnerInstruction app.dso + forA_ instructions $ \(instructionCid, _) -> do + [(dsoRulesCid, _)] <- query @DsoRules app.dso + (earliestOpenRoundCid, _) :: _ <- getOpenRoundsSorted app + void $ submit (actAs sv1 <> readAs app.dso) $ exerciseCmd dsoRulesCid $ DsoRules_ExecuteAddSvRightOwnerInstruction with + instructionCid = instructionCid + openMiningRoundCid = earliestOpenRoundCid + svOperator = sv1 \ No newline at end of file diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestOnboarding.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestOnboarding.daml index 9f95c56446..b44944889c 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestOnboarding.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestOnboarding.daml @@ -5,7 +5,6 @@ module Splice.Scripts.TestOnboarding where import DA.Assert import DA.Foldable (forA_) -import DA.Optional (fromSome) import qualified DA.Map as Map import Daml.Script import DA.Time @@ -144,7 +143,7 @@ testSvOnboarding = do newSvName = "svX" newParticipantId = "svX-participant-id" reason = "because" - newSvRewardWeight = 19 -- we use 19 as a dummy reward weight for testing + newSvRewardWeight = 0 -- weight is not used for on-ledger sv right owners executeAllConfirmedActions app -- svX is now a confirmed SV @@ -154,7 +153,7 @@ testSvOnboarding = do svName = "svX" svParticipantId = "svX-participant-id" reason = "because" - svRewardWeight = 19 + svRewardWeight = 0 -- weight is not used for on-ledger sv right owners dso expiresAt = svOnboardingConfirmed.expiresAt @@ -323,7 +322,7 @@ testSvOnboardingRequestArchiveWhenSvIsAlreadyAddedAsSV = do submit dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv with newSvParty = svX newSvName = "svX" - newSvRewardWeight = 19 + newSvRewardWeight = 0 -- weight is not used for on-ledger sv right owners newSvParticipantId = "svX-participant-id" joinedAsOfRound = (Round 3) @@ -352,7 +351,7 @@ testSvOnboardingConfirmedExpiry = do newSvParty = svX newSvName = "svX" newParticipantId = "svX-participant-id" - newSvRewardWeight = 19 + newSvRewardWeight = 0 -- sv weight is not used for on-ledger sv right owners reason = "because" executeAllConfirmedActions app @@ -375,6 +374,10 @@ testSvOnboardingConfirmedExpiry = do [(_, dsoRules)] <- query @DsoRules dso Map.keys (dsoRules.offboardedSvs) === [svX] +lookupSvOperatorParty : Text -> DsoRules -> Optional Party +lookupSvOperatorParty name dsoRules = + fmap fst (find (\(_, info) -> info.name == name) $ Map.toList dsoRules.svs) + testSvNameUniquenessNotInDevNet : Script () testSvNameUniquenessNotInDevNet = do @@ -383,7 +386,7 @@ testSvNameUniquenessNotInDevNet = do [(dsoRulesCid, dsoRules)] <- query @DsoRules dso - (fromSome (Map.lookup sv2 dsoRules.svs)).name === "sv2" + lookupSvOperatorParty "sv2" dsoRules === Some sv2 svX <- allocateParty "svX" submitMustFail dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv svX "sv2" 19 "sv2-participant-id" (Round 3) @@ -395,12 +398,12 @@ testSvOverwriteInDevNet = do [(dsoRulesCid, dsoRules)] <- query @DsoRules dso - (fromSome (Map.lookup sv1 dsoRules.svs)).name === "sv1" - (fromSome (Map.lookup sv2 dsoRules.svs)).name === "sv2" + lookupSvOperatorParty "sv1" dsoRules === Some sv1 + lookupSvOperatorParty "sv2" dsoRules === Some sv2 svX <- allocateParty "svX" -- overwriting existing sv successfully (using a new participant node) - submit dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv svX "sv2" 19 "svX-participant-id" (Round 3) + submit dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv svX "sv2" 0 "svX-participant-id" (Round 3) [(_, dsoRules)] <- query @DsoRules app.dso dsoRules.offboardedSvs === Map.fromList [(sv2, OffboardedSvInfo "sv2" "sv2-participant-id")] @@ -410,7 +413,7 @@ testSvOverwriteInDevNet = do [(dsoRulesCid, _)] <- query @DsoRules app.dso -- overwriting existing sv again - submit dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv svX2 "sv2" 19 "svX2-participant-id" (Round 3) + submit dso $ exerciseCmd dsoRulesCid $ DsoRules_AddSv svX2 "sv2" 0 "svX2-participant-id" (Round 3) [(_, dsoRules)] <- query @DsoRules app.dso dsoRules.offboardedSvs === Map.fromList @@ -429,7 +432,7 @@ testSvReonboarding = do [(_, dsoRules)] <- query @DsoRules dso - Map.keys dsoRules.svs === [sv1, sv2, sv3, sv4] + operatorParties dsoRules === [sv1, sv2, sv3, sv4] initiateAndAcceptVote app [sv1, sv2, sv3] $ ARC_DsoRules with @@ -439,14 +442,13 @@ testSvReonboarding = do executeAllDefinitiveVotes app [(_, dsoRules)] <- query @DsoRules dso - Map.keys dsoRules.svs === [sv1, sv2, sv3] + operatorParties dsoRules === [sv1, sv2, sv3] Map.keys dsoRules.offboardedSvs === [sv4] checkSvContractInvariants app -- reonboard sv4 let token = "mock-token" sv4New <- allocateParty "sv4New" - svSubmits app sv1 $ \cid -> exerciseCmd cid $ DsoRules_StartSvOnboarding "sv4" sv4New "sv4New-participant-id" token sv1 forA_ [sv1,sv2,sv3] $ \sv -> @@ -458,7 +460,8 @@ testSvReonboarding = do newSvName = "sv4" newParticipantId = "sv4New-participant-id" reason = "because the sv4 owner still has the right to operate a node" - newSvRewardWeight = 19 -- we use 19 as a dummy reward weight for testing + newSvRewardWeight = 0 -- sv weight is not used for on-ledger sv right owners + executeAllConfirmedActions app [(svOnboardingConfirmedCid, _)] <- query @SvOnboardingConfirmed dso @@ -466,7 +469,6 @@ testSvReonboarding = do [(amuletRulesCid, _)] <- query @AmuletRules dso [(dsoRulesCid, _)] <- query @DsoRules dso - submit (actAs sv4New <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_AddConfirmedSv with sv = sv4New svOnboardingConfirmedCid @@ -477,7 +479,7 @@ testSvReonboarding = do [(_, dsoRules)] <- query @DsoRules dso - Map.keys dsoRules.svs === [sv1, sv2, sv3, sv4New] + operatorParties dsoRules === [sv1, sv2, sv3, sv4New] -- sv4 remaines offboarded Map.keys dsoRules.offboardedSvs === [sv4] @@ -548,7 +550,7 @@ test_MergeValidatorLicense = do testBootstrapDevNetWithNonZeroRound : Script () testBootstrapDevNetWithNonZeroRound = do - (app, _, _) <- initDecentralizedSynchronizerWithNonZeroRound True 34 + (app, _, _) <- initDecentralizedSynchronizerWithNonZeroRound True 34 True [(_, earliestRound), (_, middleRound), (_, latestRound)] <- getActiveOpenRoundsSorted app.dso earliestRound.round === Round 34 middleRound.round === Round 35 @@ -557,7 +559,7 @@ testBootstrapDevNetWithNonZeroRound = do testBootstrapMainNetWithNonZeroRound : Script () testBootstrapMainNetWithNonZeroRound = do - (app, _, _) <- initDecentralizedSynchronizerWithNonZeroRound False 34 + (app, _, _) <- initDecentralizedSynchronizerWithNonZeroRound False 34 True [(_, earliestRound), (_, middleRound), (_, latestRound)] <- getActiveOpenRoundsSorted app.dso earliestRound.round === Round 34 middleRound.round === Round 35 diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSvRewards.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSvRewards.daml index 602fbb0eee..ec53ea9a1e 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSvRewards.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSvRewards.daml @@ -26,8 +26,8 @@ test_SvRewards_With_InitialRound_In_FirstIssuanceCurve = do let initialRound = 0 let expectedIssuancePerSvRewardCoupon = 4.6832923545 - - (app, dso, (sv1, sv2, sv3, sv4)) <- initDecentralizedSynchronizerWithNonZeroRound False initialRound + + (app, dso, (sv1, sv2, sv3, sv4)) <- initDecentralizedSynchronizerWithNonZeroRound False initialRound False -- extra party to represent beneficiary extraBeneficiary <- allocateParty "beneficiary" @@ -47,8 +47,8 @@ test_SvRewards_With_InitialRound_In_FirstIssuanceCurve = do require (show sv <> " balance: expected " <> show amount <> " == " <> show amulet.amount.initialAmount) (amulet.amount.initialAmount == amount) let getSvRewardWeightAndState sv = do - info <- getSvInfoByParty app sv - [(rewardStateCid, _)] <- queryFilter @SvRewardState dso (\s -> s.svName == info.name) + (name, info) <- getSvInfoByParty app sv + [(rewardStateCid, _)] <- queryFilter @SvRewardState dso (\s -> s.svName == name) pure (info.svRewardWeight, rewardStateCid) let receiveSvRewardCouponFails sv round rulesCid = do @@ -172,7 +172,7 @@ test_SvRewards_With_InitialRound_In_SecondIssuanceCurve = do let initialRound = 50000 let expectedIssuancePerSvRewardCoupon = 1.4049877064 - (app, dso, (sv1, sv2, sv3, sv4)) <- initDecentralizedSynchronizerWithNonZeroRound False initialRound + (app, dso, (sv1, sv2, sv3, sv4)) <- initDecentralizedSynchronizerWithNonZeroRound False initialRound False -- extra party to represent beneficiary extraBeneficiary <- allocateParty "beneficiary" @@ -192,8 +192,8 @@ test_SvRewards_With_InitialRound_In_SecondIssuanceCurve = do require (show sv <> " balance: expected " <> show amount <> " == " <> show amulet.amount.initialAmount) (amulet.amount.initialAmount == amount) let getSvRewardWeightAndState sv = do - info <- getSvInfoByParty app sv - [(rewardStateCid, _)] <- queryFilter @SvRewardState dso (\s -> s.svName == info.name) + (name, info) <- getSvInfoByParty app sv + [(rewardStateCid, _)] <- queryFilter @SvRewardState dso (\s -> s.svName == name) pure (info.svRewardWeight, rewardStateCid) let receiveSvRewardCouponFails sv round rulesCid = do @@ -329,11 +329,13 @@ test_SvRewardStateMerge = do submitMustFail (actAs sv1 <> readAs dso) $ exerciseCmd rulesCid (DsoRules_MergeSvRewardState "sv1" [sv1RewardStateCid3, sv2RewardStateCid1] (Some sv1)) pure () +-- FIXME: reenable +{- test_SvRewardUpdatedWeight : Script () test_SvRewardUpdatedWeight = do (app, dso, (sv1, sv2, sv3, sv4)) <- initMainNet - unchangedBefore <- getSvInfoByParty app sv1 - before <- getSvInfoByParty app sv2 + (_, unchangedBefore) <- getSvInfoByParty app sv1 + (beforeName, before) <- getSvInfoByParty app sv2 initiateAndAcceptVote app [sv1, sv2, sv3, sv4] $ ARC_DsoRules with @@ -341,16 +343,16 @@ test_SvRewardUpdatedWeight = do svParty = sv2 newRewardWeight = before.svRewardWeight + 1 - after <- getSvInfoByParty app sv2 + (_, after) <- getSvInfoByParty app sv2 after.svRewardWeight === before.svRewardWeight + 1 - unchangedAfter <- getSvInfoByParty app sv1 + (_, unchangedAfter) <- getSvInfoByParty app sv1 unchangedAfter.svRewardWeight === unchangedBefore.svRewardWeight -- check that coupons are claimed with the new weight [(rulesCid, _)] <- query @DsoRules app.dso [(roundCid, round), _, _] <- getActiveOpenRoundsSorted app.dso - [(rewardStateCid, _)] <- queryFilter @SvRewardState dso (\s -> s.svName == before.name) + [(rewardStateCid, _)] <- queryFilter @SvRewardState dso (\s -> s.svName == beforeName) -- collect reward coupon void $ submit (actAs sv2 <> readAs dso) $ exerciseCmd rulesCid DsoRules_ReceiveSvRewardCoupon with openRoundCid = roundCid @@ -360,3 +362,4 @@ test_SvRewardUpdatedWeight = do -- check that the coupon exists and has the right weight [(_, coupon)] <- queryFilter @SvRewardCoupon sv2 (\co -> co.round == round.round) coupon.weight === before.svRewardWeight + 1 +-} \ No newline at end of file diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSynchronizerMigration.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSynchronizerMigration.daml index 1e0d9a86ad..335960c2d4 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSynchronizerMigration.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestSynchronizerMigration.daml @@ -111,7 +111,7 @@ executeDsoRulesConfigChange : AmuletApp -> (DsoRulesConfig -> DsoRulesConfig) -> executeDsoRulesConfigChange app updateConfig = do [(_, dsoRules)] <- query @DsoRules app.dso let newConfig = updateConfig dsoRules.config - initiateAndAcceptVote app (Map.keys dsoRules.svs) $ + initiateAndAcceptVote app (operatorParties dsoRules) $ ARC_DsoRules with dsoAction = SRARC_SetConfig DsoRules_SetConfig with newConfig = newConfig @@ -125,7 +125,7 @@ initiateAndCastAmuletRulesConfigChange app targetEffectiveAt updateConfig = do let baseConfig = amuletRules.configSchedule.initialValue newConfig = updateConfig baseConfig - initiateAndCastVote app (Map.keys dsoRules.svs) (Some targetEffectiveAt) $ + initiateAndCastVote app (operatorParties dsoRules) (Some targetEffectiveAt) $ ARC_AmuletRules with amuletRulesAction = CRARC_SetConfig AmuletRules_SetConfig with newConfig diff --git a/daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml b/daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml new file mode 100644 index 0000000000..b3d6b64cc0 --- /dev/null +++ b/daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml @@ -0,0 +1,31 @@ +module Splice.DSO.SvRightOwner where + +import Splice.Util + +-- | Information about a super validator right owner. +data SvRightOwnerInfo = SvRightOwnerInfo + with + rightOwnerParty : Party -- ^ The party representing the SV rights owner + voteWeight : Int + -- ^ the weight of an SV for voting, can be zero + rewardWeight : Int + -- ^ the weight of an SV for reward minting, can be zero + rewardNodeOperatorName : Text + -- ^ Name of the SV node operator through which rewards are minted. + -- For rewards to be minted both the node operator. + beneficiaries : [(Party, Decimal)] + -- ^ List of beneficiaries and their percentages for reward distribution. Must not include rightOwnerParty. Remainder goes to rightOwnerParty. + -- FIXME: probably want to move this to a separate contract + -- FIXME: Comment for reviewer: This is deliberately a percentage not a weight. With automatic weight adjustments absolutel weights don't work anymore. + -- Beneficiaries are also more of an exception than the rule now that all actual SVs are directly represented as SVs and beneficiaries + -- are only if an SV does not want to mint directly under their SV party. + deriving (Eq, Show) + +instance Patchable SvRightOwnerInfo where + patch new base current = SvRightOwnerInfo + with + rightOwnerParty = patch new.rightOwnerParty base.rightOwnerParty current.rightOwnerParty + voteWeight = patch new.voteWeight base.voteWeight current.voteWeight + rewardWeight = patch new.rewardWeight base.rewardWeight current.rewardWeight + rewardNodeOperatorName = patch new.rewardNodeOperatorName base.rewardNodeOperatorName current.rewardNodeOperatorName + beneficiaries = patchScalar new.beneficiaries base.beneficiaries current.beneficiaries diff --git a/daml/splice-dso-governance/daml/Splice/DSO/SvState.daml b/daml/splice-dso-governance/daml/Splice/DSO/SvState.daml index 72239fd1f3..eb1d1ab2fb 100644 --- a/daml/splice-dso-governance/daml/Splice/DSO/SvState.daml +++ b/daml/splice-dso-governance/daml/Splice/DSO/SvState.daml @@ -43,7 +43,7 @@ data RewardState = RewardState with -- | State of reward collection for a sv identified by their sv name. template SvRewardState with dso : Party - svName : Text + svName : Text -- ^ sv right owner name state : RewardState where signatory dso diff --git a/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml b/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml index c3dedfbc78..1bbd93409e 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml @@ -4,8 +4,9 @@ module Splice.DsoBootstrap where import qualified DA.Map as Map +import qualified DA.TextMap as TextMap import DA.Time -import DA.Optional (fromOptional) +import DA.Optional import Splice.AmuletConfig import Splice.AmuletRules @@ -15,6 +16,7 @@ import Splice.Types import Splice.Ans import Splice.DSO.DecentralizedSynchronizer +import Splice.DSO.SvRightOwner import Splice.DsoRules data DsoBootstrap_BootstrapResult = DsoBootstrap_BootstrapResult @@ -35,6 +37,8 @@ template DsoBootstrap with initialTrafficState: Map.Map Text TrafficState isDevNet : Bool initialRound : Optional Int + sv1RightOwnerName : Optional Text + sv1VoteWeight : Optional Int where signatory dso observer sv1Party @@ -60,28 +64,32 @@ template DsoBootstrap with amuletPrice initialRound -- create the DSO rules with the SV1 as the sole sv - let sv1SvInfo = SvInfo with - name = sv1Name - joinedAsOfRound = fromOptional (Round 0) result.initialRound - svRewardWeight = sv1RewardWeight - participantId = sv1ParticipantId - let dsoRules = DsoRules with + let joinedAsOfRound = fromOptional (Round 0) result.initialRound + dsoRules = DsoRules with dso epoch = 0 - svs = Map.fromList [(sv1Party, sv1SvInfo)] + svs = Map.singleton sv1Party SvInfo with + name = sv1Name + svRewardWeight = if isSome sv1RightOwnerName then 0 else sv1RewardWeight + participantId = sv1ParticipantId + joinedAsOfRound offboardedSvs = Map.empty dsoDelegate = sv1Party config initialTrafficState isDevNet + svRightOwners = flip fmap sv1RightOwnerName $ \rightOwnerName -> TextMap.fromList [ + ( sv1Name + , SvRightOwnerInfo with + rightOwnerParty = sv1Party + voteWeight = fromOptional 0 sv1VoteWeight + rewardWeight = sv1RewardWeight + rewardNodeOperatorName = rightOwnerName + beneficiaries = [] + ) + ] create dsoRules - -- create initial per-sv and per-operator contracts for sv1 - let addSvChoiceArgs = DsoRules_AddSv with - newSvParty = sv1Party - newSvName = sv1Name - newSvParticipantId = sv1ParticipantId - joinedAsOfRound = fromOptional (Round 0) result.initialRound - newSvRewardWeight = sv1RewardWeight - createPerSvContracts dsoRules addSvChoiceArgs - createPerSvPartyContracts dso sv1Party sv1Name sv1SynchronizerNodes (Some amuletPrice) (getVoteCooldownTime config) + let joinedAsOfRound = fromOptional (Round 0) result.initialRound + createSvRightOwnerContracts dsoRules sv1Name joinedAsOfRound + createSvOperatorContracts dso sv1Party sv1Name sv1SynchronizerNodes (Some amuletPrice) (getVoteCooldownTime config) return DsoBootstrap_BootstrapResult diff --git a/daml/splice-dso-governance/daml/Splice/DsoRules.daml b/daml/splice-dso-governance/daml/Splice/DsoRules.daml index ff4829a8cd..95a63525ca 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoRules.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoRules.daml @@ -10,10 +10,11 @@ import DA.Assert import DA.Either (partitionEithers) import DA.Foldable (forA_, all) import DA.List as List hiding (all) -import DA.Optional (isNone, fromSome, fromOptional, isSome) +import DA.Optional (isNone, fromOptional, isSome, fromSome) import qualified DA.Map as Map import qualified DA.Set as Set import qualified DA.Text as T +import qualified DA.TextMap as TextMap import DA.Time import Splice.Amulet @@ -34,6 +35,7 @@ import Splice.Ans import Splice.SvOnboarding import Splice.DSO.AmuletPrice import Splice.DSO.DecentralizedSynchronizer +import Splice.DSO.SvRightOwner import Splice.DSO.SvState import Splice.Schedule import Splice.Util @@ -121,6 +123,9 @@ data DsoRules_ActionRequiringConfirmation -- ^ Create BootstrapExternalPartyConfigStateInstruction | SRARC_UpdateFeaturedAppRight DsoRules_UpdateFeaturedAppRight -- ^ Update a specific featured app right. + | SRARC_DsoRules_UpdateSvRightOwnerInfo DsoRules_UpdateSvRightOwnerInfo + | SRARC_DsoRules_AddSvRightOwner DsoRules_AddSvRightOwner + | SRARC_DsoRules_RemoveSvRightOwner DsoRules_RemoveSvRightOwner deriving (Eq, Show) data AnsEntryContext_ActionRequiringConfirmation @@ -132,7 +137,7 @@ data AnsEntryContext_ActionRequiringConfirmation -- | Information about SVs relevant to DSO governance. data SvInfo = SvInfo with - name : Text -- ^ Human-readable name; must be unique. + name : Text -- ^ Human-readable sv operator name; must be unique. joinedAsOfRound : Round -- ^ Round in which the SV joined svRewardWeight : Int -- ^ Weight of the SV in the SV reward distribution. participantId : Text -- ^ Participant ID of the SV, stored here as PartyToParticipant mappings are tracked via state on the DsoRules + SvOnboardingConfirmed contracts. @@ -152,6 +157,13 @@ data DsoSummary = DsoSummary with -- ^ The number of votes required for considering a confirmation, or a request for a vote deriving (Eq, Show) +data DsoSummaryV2 = DsoSummaryV2 + with + totalVoteWeight : Int + requiredVoteWeight : Int + votersWithWeight : TextMap.TextMap Int -- ^ Map from voter name (right owner or operator name depending on the vote type) to its vote weight + deriving (Eq, Show) + -- | Choice return types ------------------------- -- In order to support upgrades of the Daml models, all choices should return records, which can @@ -432,6 +444,18 @@ template VoteRequest ensure all (voteBefore <=) targetEffectiveAt signatory dso +-- FIXME: Placeholder, current implementation is arbitrary and just serves to be able to exercise both vote types in tests. +voteType : ActionRequiringConfirmation -> VoteType +voteType (ARC_DsoRules act) = case act of + SRARC_DsoRules_UpdateSvRightOwnerInfo{} -> RightOwnerVote + SRARC_DsoRules_AddSvRightOwner{} -> RightOwnerVote + SRARC_DsoRules_RemoveSvRightOwner{} -> RightOwnerVote + _ -> OperatorVote +voteType (ARC_AmuletRules _) = OperatorVote +voteType (ARC_AnsEntryContext _ _) = OperatorVote +voteType (ExtActionRequiringConformation _) = OperatorVote + + data DsoRules_CloseVoteRequestResult = DsoRules_CloseVoteRequestResult with request : VoteRequest -- ^ The original vote request. completedAt : Time -- ^ When the vote request was completed. @@ -456,7 +480,7 @@ data VoteRequestOutcome -- -- | A vote cast by an SV. data Vote = Vote with - sv : Party -- ^ The SV party used to submit the vote. + sv : Party -- ^ The SV party used to submit the vote. Can be a right owner party or an operator party depending on the vote type. accept : Bool -- ^ Whether the responder accepted the request to execute the action or not. reason : Reason @@ -518,19 +542,53 @@ data TrafficState = TrafficState with consumedTraffic: Int -- ^ Bytes of extra traffic consumed before the decentralized synchronizer was bootstrapped. deriving (Eq, Show) +validSvRightOwnerInfo : DsoRules -> SvRightOwnerInfo -> Bool +validSvRightOwnerInfo DsoRules{} SvRightOwnerInfo{..} = + voteWeight >= 0 && + rewardWeight >= 0 && + sum (map snd beneficiaries) <= 1.0 && + all (\(_, beneficiaryWeight) -> beneficiaryWeight > 0.0) beneficiaries && + all (\(beneficiary,_) -> beneficiary /= rightOwnerParty) beneficiaries && + unique (map fst beneficiaries) + -- FIXME: Do we want this assertion? If so, we need to switch the node operator on offboarding. + -- && any (\info -> info.name == rewardNodeOperatorName) (Map.values svs) + +getSvRightOwners : DsoRules -> TextMap.TextMap SvRightOwnerInfo +getSvRightOwners DsoRules{..} = fromOptional TextMap.empty svRightOwners + +onLedgerSvRightOwners : DsoRules -> Bool +onLedgerSvRightOwners DsoRules{..} = isSome svRightOwners + +requireOnLedgerSvRightOwners : DsoRules -> Update () +requireOnLedgerSvRightOwners this = + require "svRightOwners are tracked on-ledger" (onLedgerSvRightOwners this) + +requireNoOnLedgerSvRightOwners : DsoRules -> Update () +requireNoOnLedgerSvRightOwners this = + require "svRightOwners are not tracked on-ledger" (not $ onLedgerSvRightOwners this) + template DsoRules with dso : Party epoch : Int svs : Map.Map Party SvInfo + -- ^ Deprecated in favor of svRightOwners offboardedSvs : Map.Map Party OffboardedSvInfo + -- ^ Only set for sv node owners to handle DSO party offboarding dsoDelegate : Party -- ^ __Deprecated__ in favor of delegateless automation. config : DsoRulesConfig initialTrafficState: Map.Map Text TrafficState -- ^ Map from participant/mediator ID to its traffic state at the time of synchronizer bootstrapping. Used for testing, empty in prod. isDevNet : Bool + svRightOwners : Optional (TextMap.TextMap SvRightOwnerInfo) -- ^ Map from sv right owner name to info about the right owner + where ensure - config.numUnclaimedRewardsThreshold > 0 + config.numUnclaimedRewardsThreshold > 0 && + all (\(_, v) -> validSvRightOwnerInfo this v) (TextMap.toList (getSvRightOwners this)) && + -- when using on-ledger right owners they must be non-empty + optional True (\rightOwners -> TextMap.size rightOwners >= 1) svRightOwners && + -- when using on-ledger right owners the weight in the operator info must be 0 + (not (onLedgerSvRightOwners this) || all (\info -> info.svRewardWeight == 0) (Map.values svs)) -- NOTE: the svs are not direct signatories as that would not give us the right fault-tolerance wrt -- validating choices on this contract. Instead, the svs are indirect signatories by being @@ -554,20 +612,21 @@ template DsoRules with choice DsoRules_OffboardSv : DsoRules_OffboardSvResult with - sv : Party + sv : Party -- ^ sv operator party controller dso do + let svOperator = sv require "There is more than one sv" (Map.size svs > 1) - case Map.lookup sv svs of + case Map.lookup svOperator svs of None -> fail "Not a sv" Some info -> do -- NOTE: this immediate deletion will lead to the SV apps of the remaining svs -- revoking that sv's rights in the CometBFT network and the topology state. - let newSvs = Map.delete sv svs + let newSvs = Map.delete svOperator svs -- We optimize for prompt removal of a sv if the vote said so. -- and instead just choose the sv with the lexicographically smallest name. let (newDsoDelegate, newEpoch) - | sv == dsoDelegate = (head (Map.keys newSvs), epoch + 1) + | svOperator == dsoDelegate = (head (Map.keys newSvs), epoch + 1) | otherwise = (dsoDelegate, epoch) let offboardedSvInfo = OffboardedSvInfo with name = info.name @@ -578,7 +637,8 @@ template DsoRules with epoch = newEpoch dsoDelegate = newDsoDelegate svs = newSvs - offboardedSvs = Map.insert sv offboardedSvInfo offboardedSvs + svRightOwners + offboardedSvs = Map.insert svOperator offboardedSvInfo offboardedSvs config initialTrafficState isDevNet @@ -588,21 +648,20 @@ template DsoRules with -- Update an SV's Status report nonconsuming choice DsoRules_SubmitStatusReport : DsoRules_SubmitStatusReportResult with - sv : Party + sv : Party -- ^ sv operator party previousReportCid : ContractId SvStatusReport status : SvStatus controller sv do - newReport <- case Map.lookup sv svs of - None -> fail "SV is not an SV" - Some info -> do - previousReport <- fetchAndArchive (ForSvNode with dso; sv; svName = info.name) previousReportCid - create SvStatusReport with - dso - sv - svName = info.name - number = previousReport.number + 1 - status = Some status + let svOperator = sv + name <- getAndValidateSvNodeOperatorParty this (Some svOperator) + previousReport <- fetchAndArchive (ForSvNode with dso; sv = svOperator; svName = name) previousReportCid + newReport <- create SvStatusReport with + dso + sv = svOperator + svName = name + number = previousReport.number + 1 + status = Some status return DsoRules_SubmitStatusReportResult with .. -- Called by SV candidates to add themselves to the DsoRules once they are confirmed and ready. @@ -610,7 +669,7 @@ template DsoRules with -- the first round in which the new SV will receive rewards. nonconsuming choice DsoRules_AddConfirmedSv : DsoRules_AddConfirmedSvResult with - sv : Party + sv : Party -- ^ sv operator party svOnboardingConfirmedCid : ContractId SvOnboardingConfirmed earliestRoundCid : ContractId OpenMiningRound middleRoundCid : ContractId OpenMiningRound @@ -620,8 +679,8 @@ template DsoRules with -- (This was used when the current round number was tracked in the AmuletRules contract.) controller sv do - - svOnboardingConfirmed <- fetchAndArchive (ForOwner with dso; owner = sv) svOnboardingConfirmedCid + let svOperator = sv + svOnboardingConfirmed <- fetchAndArchive (ForOwner with dso; owner = svOperator) svOnboardingConfirmedCid assertWithinDeadline "svOnboardingConfirmed.expiresAt" svOnboardingConfirmed.expiresAt let forDso = ForDso with dso @@ -632,7 +691,7 @@ template DsoRules with require "latestRound is one after middleRound" (latestRound.round.number == middleRound.round.number + 1) addSvResult <- exercise self DsoRules_AddSv with - newSvParty = sv + newSvParty = svOperator newSvName = svOnboardingConfirmed.svName newSvRewardWeight = svOnboardingConfirmed.svRewardWeight newSvParticipantId = svOnboardingConfirmed.svParticipantId @@ -648,12 +707,14 @@ template DsoRules with -- Every SV can change their own synchronizer node's config within the configured limits. nonconsuming choice DsoRules_SetSynchronizerNodeConfig : DsoRules_SetSynchronizerNodeConfigResult with - sv : Party + sv : Party -- ^ sv operator party synchronizerId : Text newNodeConfig : SynchronizerNodeConfig nodeStateCid : ContractId SvNodeState controller sv do + let svOperator = sv + getAndValidateSvNodeOperatorParty this (Some svOperator) -- check that the synchronizer is known require "Synchronizer with this id is configured" (synchronizerId `Map.member` config.decentralizedSynchronizer.synchronizers) -- check validity of config and constraint on voting power @@ -661,9 +722,8 @@ template DsoRules with unless isDevNet $ require "CometBft voting power <= 1" (CometBft.totalVotingPower newNodeConfig.cometBft <= 1) -- update the SV operator node's state - info <- getSvInfo sv this - let svName = info.name - nodeState <- fetchAndArchive (ForSvNode with dso; sv; svName) nodeStateCid + (svName, _) <- getSvInfoByOperatorParty svOperator this + nodeState <- fetchAndArchive (ForSvNode with dso; sv = svOperator; svName) nodeStateCid let state = nodeState.state svNodeState <- create nodeState with state = state with @@ -714,7 +774,7 @@ template DsoRules with action : ActionRequiringConfirmation controller confirmer do - require "Confirmer is an SV" (confirmer `Map.member` svs) + getAndValidateSvNodeOperatorParty this (Some confirmer) now <- getTime let expiresAt = now `addRelTime` config.actionConfirmationTimeout confirmation <- create Confirmation with @@ -732,13 +792,14 @@ template DsoRules with sv : Optional Party controller sv do - _ <- getAndValidateSvParty this sv - let s = summarizeDso this + _ <- getAndValidateSvNodeOperatorParty this sv + let s = summarizeDso OperatorVote this let forDso = ForDso with dso - require "Enough confirmations" (length confirmationCids >= s.requiredNumVotes) + -- there are no operator vote weights so just number of confirmations is sufficient. + require "Enough confirmations" (length confirmationCids >= s.requiredVoteWeight) confirmers <- forA confirmationCids $ \confirmationCid -> do confirmation <- fetchAndArchive forDso confirmationCid - require "Confirmer is an SV" (confirmation.confirmer `Map.member` svs) + getAndValidateSvNodeOperatorParty this (Some confirmation.confirmer) require "Confirmed action matches" (confirmation.action == action) assertWithinDeadline "confirmation.expiresAt" confirmation.expiresAt pure confirmation.confirmer @@ -760,9 +821,7 @@ template DsoRules with targetEffectiveAt : Optional Time controller requester do - requesterName <- case requester `Map.lookup` svs of - None -> fail "Requester is not an SV" - Some info -> pure (info.name) + requesterName <- getAndValidateVotingParty this requester action requireWellformedReason config reason now <- getTime let voteBefore = case voteRequestTimeout of @@ -797,11 +856,9 @@ template DsoRules with do -- validate vote parameters requireWellformedVote config vote - voterName <- case Map.lookup vote.sv svs of - None -> fail "Voter is not an SV" - Some info -> pure info.name -- validate and archive request request <- fetchAndArchive (ForDso with dso) requestCid + voterName <- getAndValidateVotingParty this vote.sv request.action -- rate limit casting of votes by the same SV to avoid them blocking others from making progress -- Note: we currently ignore the optional self-declared vote casting time -- `vote.optCastAt`. We'll use that in the future when adding support for larger @@ -845,34 +902,33 @@ template DsoRules with sv : Optional Party controller sv do - _ <- getAndValidateSvParty this sv + _ <- getAndValidateSvNodeOperatorParty this sv now <- getTime - let s = summarizeDso this request <- fetchAndArchive (ForDso with dso) requestCid + let s = summarizeDso (voteType request.action) this - let activeSvs = map (.name) $ Map.values svs - - let activeSvSet = Set.fromList activeSvs let (validVotes, offboardedVoters) = partitionEithers - [ if voterName `Set.member` activeSvSet then Left vote else Right voterName + [ case TextMap.lookup voterName s.votersWithWeight of + None -> Right voterName + Some weight -> Left (voterName, vote, weight) | (voterName, vote) <- Map.toList request.votes ] - let abstainingSvs = [ name | name <- activeSvs, not (name `Map.member` request.votes) ] - let (yays, nays) = partition (.accept) validVotes - let numYays = length yays - let numNays = length nays - let numVotes = numYays + numNays + let abstainingSvs = [ name | (name, _) <- TextMap.toList s.votersWithWeight, not (name `Map.member` request.votes) ] + let (yays, nays) = partition (\(_, v, _) -> v.accept) validVotes + let yayWeight = sum $ map (\(_, _, weight) -> weight) yays + let nayWeight = sum $ map (\(_, _, weight) -> weight) nays + let totalWeight = yayWeight + nayWeight outcome <- case request.targetEffectiveAt of - Some _ | numNays >= s.requiredNumVotes -> + Some _ | nayWeight >= s.requiredVoteWeight -> pure $ VRO_Rejected - Some _ | now >= request.voteBefore && numVotes < s.requiredNumVotes -> + Some _ | now >= request.voteBefore && totalWeight < s.requiredVoteWeight -> pure $ VRO_Expired - Some effectiveTime | now >= effectiveTime && numYays >= s.requiredNumVotes -> + Some effectiveTime | now >= effectiveTime && yayWeight >= s.requiredVoteWeight -> do executeActionRequiringConfirmation dso self amuletRulesCid request.action pure $ VRO_Accepted with @@ -884,10 +940,10 @@ template DsoRules with Some _ -> fail "no definitive outcome for voting request with effectivity" - None | numNays >= s.requiredNumVotes -> + None | nayWeight >= s.requiredVoteWeight -> pure $ VRO_Rejected - None | numYays >= s.requiredNumVotes -> + None | yayWeight >= s.requiredVoteWeight -> do executeActionRequiringConfirmation dso self amuletRulesCid request.action -- TODO(#16139): Remove Config Schedule from AmuletConfig @@ -915,19 +971,20 @@ template DsoRules with nonconsuming choice DsoRules_UpdateAmuletPriceVote : DsoRules_UpdateAmuletPriceVoteResult with - sv : Party + sv : Party -- ^ sv operator party voteCid : ContractId AmuletPriceVote amuletPrice : Decimal controller sv do - pastVote <- fetchAndArchive (ForOwner with dso; owner = sv) voteCid + let svOperator = sv -- ^ for now we still tie amulet price votes to operators, it may make sense to change it to right owners eventually + pastVote <- fetchAndArchive (ForOwner with dso; owner = svOperator) voteCid -- rate limit, so that an SV cannot block round advancement by changing their price vote too often - enforceCooldown ("voteCooldownTime for " <> partyToText sv) (getVoteCooldownTime config) (Some pastVote.lastUpdatedAt) + enforceCooldown ("voteCooldownTime for " <> partyToText svOperator) (getVoteCooldownTime config) (Some pastVote.lastUpdatedAt) now <- getTime -- create new vote amuletPriceVote <- create AmuletPriceVote with dso - sv + sv = svOperator amuletPrice = Some amuletPrice lastUpdatedAt = now return DsoRules_UpdateAmuletPriceVoteResult with .. @@ -944,10 +1001,11 @@ template DsoRules with with nonSvVoteCids : [ContractId AmuletPriceVote] duplicateVoteCids : [[ContractId AmuletPriceVote]] - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator let forDso = ForDso with dso -- validate and archive non-sv votes forA_ nonSvVoteCids $ \voteCid -> do @@ -966,7 +1024,7 @@ template DsoRules with [_] -> fail "singleton list of duplicate votes" ((_, vote)::duplicates) -> do require "matching DSO party" (vote.dso == dso) - require "SV is a sv" (vote.sv `Map.member` svs) + getAndValidateSvNodeOperatorParty this (Some vote.sv) forA_ duplicates $ \(duplicateCid, duplicate) -> do -- safe, as we fetched it before and check the constraints below potentiallyUnsafeArchive duplicateCid @@ -993,10 +1051,11 @@ template DsoRules with choice DsoRules_UpdateSvRewardWeight : DsoRules_UpdateSvRewardWeightResult with - svParty : Party + svParty : Party -- ^ sv operator party but will be replaced by DsoRules_UpdateSvRightOwnerInfo newRewardWeight : Int controller dso do + requireNoOnLedgerSvRightOwners this require "New reward weight is positive" (newRewardWeight >= 0) case Map.lookup svParty svs of None -> fail "SV party is not registered" @@ -1049,13 +1108,13 @@ template DsoRules with nonconsuming choice DsoRules_OnboardValidator : DsoRules_OnboardValidatorResult with - sponsor : Party + sponsor : Party -- ^ sv operator for now, will be replaced as part of public sequencer work validator : Party version : Optional Text contactPoint : Optional Text controller sponsor do - require "Sponsor is an SV" (sponsor `Map.member` svs) + getAndValidateSvNodeOperatorParty this (Some sponsor) now <- getTime validatorLicense <- create ValidatorLicense with dso @@ -1072,9 +1131,10 @@ template DsoRules with -- There should never be duplicates going forward. with validatorLicenseCids : [ContractId ValidatorLicense] - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv - do _ <- getAndValidateSvParty this sv + do let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator require "Number of validatorLicense contracts to merge is >= 2" (length validatorLicenseCids >= 2) validatorLicenses <- forA validatorLicenseCids $ fetchAndArchive (ForDso this.dso) require "All validatorLicenses map to the same validator" ( length (dedup (map (.validator) validatorLicenses)) == 1) @@ -1097,10 +1157,11 @@ template DsoRules with candidateParty : Party candidateParticipantId: Text token : Text - sponsor : Party + sponsor : Party -- ^ sv operator controller sponsor do - require "Sponsor is an SV" (sponsor `Map.member` svs) + -- node onboarding is controlled by existing nodes + getAndValidateSvNodeOperatorParty this (Some sponsor) now <- getTime let expiresAt = now `addRelTime` config.svOnboardingRequestTimeout onboardingRequest <- create SvOnboardingRequest with .. @@ -1109,25 +1170,26 @@ template DsoRules with nonconsuming choice DsoRules_ExpireSvOnboardingRequest : DsoRules_ExpireSvOnboardingRequestResult with cid: ContractId SvOnboardingRequest - sv : Optional Party + sv : Optional Party -- ^ sv operator controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator exercise cid SvOnboardingRequest_Expire return DsoRules_ExpireSvOnboardingRequestResult nonconsuming choice DsoRules_ArchiveSvOnboardingRequest : DsoRules_ArchiveSvOnboardingRequestResult with svOnboardingRequestCid: ContractId SvOnboardingRequest - sv : Optional Party + sv : Optional Party -- ^ sv operator controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator -- TODO(#3756) Enable archiving also before the sv is added, after a matching `SvOnboardingConfirmed` contract is created. svOnboardingRequest <- fetchAndArchive (ForDso with dso) svOnboardingRequestCid - let maybeSv = Map.lookup svOnboardingRequest.candidateParty svs - require "SV party is an SV" (isSome maybeSv) - require "SV name matches" ((fromSome maybeSv).name == svOnboardingRequest.candidateName) + name <- getAndValidateSvNodeOperatorParty this (Some svOnboardingRequest.candidateParty) + require "SV name matches" (name == svOnboardingRequest.candidateName) return DsoRules_ArchiveSvOnboardingRequestResult nonconsuming choice DsoRules_ConfirmSvOnboarding : DsoRules_ConfirmSvOnboardingResult @@ -1142,7 +1204,7 @@ template DsoRules with ensureNeverOperatedNode newSvParty this if (not isDevNet) then - require "SV name is expected to be new unless in devnet" (newSvName `notElem` (map (.name) (Map.values svs))) + require "SV name is expected to be new unless in devnet" (isNone $ lookupSvOperatorInfoByName newSvName this) else pure () now <- getTime let expiresAt = now `addRelTime` config.svOnboardingConfirmedTimeout @@ -1159,10 +1221,11 @@ template DsoRules with choice DsoRules_ExpireSvOnboardingConfirmed : DsoRules_ExpireSvOnboardingConfirmedResult with cid: ContractId SvOnboardingConfirmed - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator svOnboardingConfirmed <- fetchButArchiveLater (ForDso with dso) cid exercise cid SvOnboardingConfirmed_Expire -- register the sv as offboarded so it's PartyToParticipant mapping for the DSO party gets removed @@ -1182,10 +1245,11 @@ template DsoRules with with extAmuletRulesCid : ContractId ExternalPartyAmuletRules expireAllocations : ExternalPartyAmuletRules_ExpireAmuletAllocations - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) TSU.requireMatchExpected ("expireAllocations.expectedDso", expireAllocations.expectedDso) dso res <- exercise extAmuletRulesCid (expireAllocations with expectedDso = dso) @@ -1195,10 +1259,11 @@ template DsoRules with with extAmuletRulesCid : ContractId ExternalPartyAmuletRules choiceArg : ExternalPartyAmuletRules_ExpireAmuletAllocationsV2 - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) _ <- fetchChecked (ForDso with dso) extAmuletRulesCid result <- exercise extAmuletRulesCid choiceArg pure DsoRules_ExpireAmuletAllocationsV2Result with result @@ -1207,10 +1272,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules transferInsts : AmuletRules_Amulet_ExpireTransferInstructions - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) require ("expectedDso " <> show transferInsts.expectedDso <> " matches the actualDso " <> show dso) (transferInsts.expectedDso == dso) res <- exercise amuletRulesCid (transferInsts with expectedDso = dso) pure DsoRules_Amulet_ExpireTransferInstructionsResult with result = res @@ -1227,10 +1293,11 @@ template DsoRules with with cid : ContractId Amulet choiceArg : Amulet_ExpireV2 - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator result <- exercise cid choiceArg return DsoRules_Amulet_ExpireV2Result with expireSum = result.expireSum @@ -1239,10 +1306,11 @@ template DsoRules with with cid : ContractId LockedAmulet choiceArg : LockedAmulet_ExpireAmulet - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator result <- exercise cid choiceArg return DsoRules_LockedAmulet_ExpireAmuletResult with expireSum = result.expireSum @@ -1251,10 +1319,11 @@ template DsoRules with with cid : ContractId LockedAmulet choiceArg : LockedAmulet_ExpireAmuletV2 - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator result <- exercise cid choiceArg return DsoRules_LockedAmulet_ExpireAmuletV2Result with expireSum = result.expireSum @@ -1270,11 +1339,12 @@ template DsoRules with middleRoundCid : ContractId OpenMiningRound latestRoundCid : ContractId OpenMiningRound amuletPriceVoteCids : [ContractId AmuletPriceVote] - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv - amuletPrice <- fetchMedianAmuletPrice dso (Map.keys svs) amuletPriceVoteCids + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator + amuletPrice <- fetchMedianAmuletPrice dso (operatorParties this) amuletPriceVoteCids result <- exercise amuletRulesCid AmuletRules_AdvanceOpenMiningRounds with .. return DsoRules_AdvanceOpenMiningRoundsResult with summarizingRound = result.summarizingRoundCid @@ -1286,10 +1356,11 @@ template DsoRules with externalPartyConfigStateCid0 : ContractId ExternalPartyConfigState externalPartyConfigStateCid1 : ContractId ExternalPartyConfigState openMiningRoundTriple : OpenMiningRoundTriple - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) result <- exercise amuletRulesCid AmuletRules_UpdateExternalPartyConfigStates with .. return DsoRules_UpdateExternalPartyConfigStatesResult with newExternalPartyConfigStateCid = result.newExternalPartyConfigStateCid @@ -1302,10 +1373,11 @@ template DsoRules with with ansEntryContextCid : ContractId AnsEntryContext choiceArg : AnsEntryContext_CollectEntryRenewalPayment - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator summary <- exercise ansEntryContextCid choiceArg return DsoRules_CollectEntryRenewalPaymentResult with ansEntry = summary.entryCid @@ -1315,10 +1387,11 @@ template DsoRules with with ansEntryCid : ContractId AnsEntry choiceArg : AnsEntry_Expire - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator exercise ansEntryCid choiceArg pure DsoRules_ExpireAnsEntryResult @@ -1327,10 +1400,11 @@ template DsoRules with ansEntryContextCid : ContractId AnsEntryContext subscriptionIdleStateCid: ContractId SubscriptionIdleState choiceArg : SubscriptionIdleState_ExpireSubscription - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator result <- exercise subscriptionIdleStateCid choiceArg exercise ansEntryContextCid (AnsEntryContext_Terminate dso result.terminatedSubscription) pure DsoRules_ExpireSubscriptionResult @@ -1339,27 +1413,29 @@ template DsoRules with with ansEntryContextCid : ContractId AnsEntryContext terminatedSubscriptionCid : ContractId TerminatedSubscription - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator exercise ansEntryContextCid (AnsEntryContext_Terminate dso terminatedSubscriptionCid) pure DsoRules_TerminateSubscriptionResult -- Reward management driven directly by the DSO delegates --------------------------------------------------------- - nonconsuming choice DsoRules_ReceiveSvRewardCoupon : DsoRules_ReceiveSvRewardCouponResult with - sv : Party + sv : Party -- ^ sv operator party openRoundCid : ContractId OpenMiningRound rewardStateCid : ContractId SvRewardState beneficiaries : [(Party, Int)] controller sv do - case Map.lookup sv svs of - None -> fail "SV is not an SV" + requireNoOnLedgerSvRightOwners this + let svOperator = sv + case Map.lookup svOperator svs of + None -> fail "SV is not an SV operator" Some info -> do -- check round now <- getTime @@ -1398,6 +1474,70 @@ template DsoRules with svRewardState = newRewardStateCid svRewardCoupons = couponCids + nonconsuming choice DsoRules_ReceiveSvRewardCouponV2 : () + with + sv : Party -- ^ sv operator party + openRoundCid : ContractId OpenMiningRound + svRewardStates : TextMap.TextMap (ContractId SvRewardState) + controller sv + do + requireOnLedgerSvRightOwners this + let svOperator = sv + operatorName <- getAndValidateSvNodeOperatorParty this (Some svOperator) + let info = fromSome (TextMap.lookup operatorName (getSvRightOwners this)) + now <- getTime + openRound <- fetchReferenceData (ForDso with dso) openRoundCid + require "OpenRound is open" (openRound.opensAt <= now) + + -- FIXME: Do we want to enforce that the operator has to pass in all states that have configured them as a node operator? + -- given that you do rely on the operator anyway to mint rewards maybe not required. + -- if we do enforce it, we need to handle cases where the lastRoundCollected is out of sync which can happen on operator switches. + forA_ (TextMap.toList svRewardStates) $ \(svName, rewardStateCid) -> do + svInfo <- case TextMap.lookup svName (getSvRightOwners this) of + None -> fail ("SV " <> svName <> " is not an SV") + Some svInfo -> do + require ("SV " <> svName <> " is minting rewards through " <> show operatorName) (svInfo.rewardNodeOperatorName == operatorName) + pure svInfo + rewardState <- fetchAndArchive (ForSv with dso; svName = svName) rewardStateCid + let state = rewardState.state + beneficiaries = svInfo.beneficiaries + let (configuredBeneficiaryCouponWeights, remainingWeight) = + foldl + (\(acc, remainingWeight) (beneficiary, weight) -> + let beneficiaryWeight = floor (weight * intToDecimal info.rewardWeight) + in ((beneficiary, beneficiaryWeight) :: acc, remainingWeight - beneficiaryWeight)) + ([], info.rewardWeight) + beneficiaries + beneficiaryCouponWeights = + if remainingWeight > 0 then (svInfo.rightOwnerParty, remainingWeight) :: configuredBeneficiaryCouponWeights + else configuredBeneficiaryCouponWeights + require + ("Round " <> show openRound.round <> " is greater than the last round a reward has been received for " <> show state.lastRoundCollected) + (state.lastRoundCollected < openRound.round) + + newRewardStateCid <- create rewardState with + state = RewardState with + lastRoundCollected = openRound.round + numRoundsCollected = state.numRoundsCollected + 1 + numRoundsMissed = + state.numRoundsMissed + (openRound.round.number - state.lastRoundCollected.number - 1) + numCouponsIssued = state.numCouponsIssued + length beneficiaryCouponWeights + + -- check weights and issue rewards + require "Sum of beneficiary weights matches" (info.rewardWeight == sum (map snd beneficiaryCouponWeights)) + + couponCids <- forA beneficiaryCouponWeights $ \(beneficiary, weight) -> + create SvRewardCoupon with + dso + sv = svInfo.rightOwnerParty + beneficiary + weight + round = openRound.round + + return (svName, (newRewardStateCid, couponCids)) + + pure () + -- Batch expiry of unclaimed rewards for a specific claimed round ----------------------------------------------------------------- @@ -1405,10 +1545,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules choiceArg : AmuletRules_ClaimExpiredRewards - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator -- TODO(#2025) Deprecate AmuletRules_ClaimExpiredRewards. We did not do that in the same change -- as inlining the definition here so don't need to bump splice-amulet which also requires validators to upgrade. @@ -1467,10 +1608,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules choiceArg : AmuletRules_ClaimExpiredRewardsV2 - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) result <- exercise amuletRulesCid choiceArg return DsoRules_ClaimExpiredRewardsV2Result with result @@ -1479,10 +1621,11 @@ template DsoRules with with processRewardsCid : ContractId RewardAccountingV2.ProcessRewardsV2 choiceArg : RewardAccountingV2.ProcessRewardsV2_ProcessBatch - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) result <- exercise processRewardsCid choiceArg return DsoRules_ProcessRewardsV2_ProcessBatchResult with result @@ -1491,10 +1634,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules choiceArg : AmuletRules_UnhideRewardCouponsV2 - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) result <- exercise amuletRulesCid choiceArg return DsoRules_UnhideRewardCouponsV2Result with result @@ -1504,10 +1648,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules choiceArg : AmuletRules_ArchiveDryRunRewardAccountingV2 - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) result <- exercise amuletRulesCid choiceArg return DsoRules_ArchiveDryRunRewardAccountingV2Result with result @@ -1518,10 +1663,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules unclaimedRewardCids : [ContractId UnclaimedReward] - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator require "Number of unclaimed rewards is above the configured threshold" $ length unclaimedRewardCids > config.numUnclaimedRewardsThreshold result <- exercise amuletRulesCid AmuletRules_MergeUnclaimedRewards with .. return DsoRules_MergeUnclaimedRewardsResult with @@ -1532,10 +1678,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules choiceArg : AmuletRules_MergeUnclaimedDevelopmentFundCoupons - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) result <- exercise amuletRulesCid choiceArg return DsoRules_MergeUnclaimedDevelopmentFundCouponsResult with result @@ -1543,10 +1690,11 @@ template DsoRules with -- ^ Expires a DevelopmentFundCoupon and produces an UnclaimedDevelopmentFundCoupon with the same amount. with developmentFundCouponCid : ContractId DevelopmentFundCoupon - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) result <- exercise developmentFundCouponCid DevelopmentFundCoupon_DsoExpire pure $ DsoRules_ExpireDevelopmentFundCouponResult with result @@ -1554,10 +1702,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules issuingRoundCid : ContractId IssuingMiningRound - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator result <- exercise amuletRulesCid AmuletRules_MiningRound_Close with .. return DsoRules_MiningRound_CloseResult with closedRound = result.closedRoundCid @@ -1570,10 +1719,11 @@ template DsoRules with nonconsuming choice DsoRules_ExpireStaleConfirmation : DsoRules_ExpireStaleConfirmationResult with staleConfirmationCid : ContractId Confirmation - sv : Optional Party + sv : Optional Party -- ^ sv operator controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator fetchChecked (ForDso with dso) staleConfirmationCid exercise staleConfirmationCid Confirmation_Expire return DsoRules_ExpireStaleConfirmationResult @@ -1584,10 +1734,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules trafficCids : [ContractId MemberTraffic] - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator require "Number of member traffic contracts is above the configured threshold" $ length trafficCids > config.numMemberTrafficContractsThreshold result <- exercise amuletRulesCid AmuletRules_MergeMemberTrafficContracts with .. return DsoRules_MergeMemberTrafficContractsResult with @@ -1599,9 +1750,10 @@ template DsoRules with with svName : Text rewardStateCids : [ContractId SvRewardState] - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv - do _ <- getAndValidateSvParty this sv + do let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator require "Number of SvRewardState contracts to merge is >= 2" (length rewardStateCids >= 2) rewardStates <- forA rewardStateCids $ fetchAndArchive (ForSv this.dso svName) -- We don't attempt to merge the fields in the reward state since there is no good @@ -1616,7 +1768,7 @@ template DsoRules with amuletRulesCid : ContractId AmuletRules sv : Optional Party controller sv - do _ <- getAndValidateSvParty this sv + do _ <- getAndValidateSvNodeOperatorParty this sv deprecatedChoice "splice-dso-governance" "0.1.16" "DsoRules_PruneAmuletConfigSchedule" -- external party @@ -1639,10 +1791,11 @@ template DsoRules with nonconsuming choice DsoRules_ExpireTransferPreapproval : DsoRules_ExpireTransferPreapprovalResult with transferPreapprovalCid : ContractId TransferPreapproval - sv : Optional Party + sv : Optional Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator exercise transferPreapprovalCid TransferPreapproval_Expire pure DsoRules_ExpireTransferPreapprovalResult @@ -1650,10 +1803,11 @@ template DsoRules with with amuletRulesCid : ContractId AmuletRules argument : AmuletRules_ConvertFeaturedAppActivityMarkers - sv : Optional Party + sv : Optional Party -- ^ sv operator controller sv do - _ <- getAndValidateSvParty this sv + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this svOperator result <- exercise amuletRulesCid argument pure DsoRules_AmuletRules_ConvertFeaturedAppActivityMarkersResult with result @@ -1687,10 +1841,11 @@ template DsoRules with unclaimedRewardsToBurnCids : [ContractId UnclaimedReward] -- ^ A sufficient list of `UnclaimedReward` to be archived. -- It must cover at least the requested amount. - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) UnallocatedUnclaimedActivityRecord{..} <- fetchAndArchive (ForDso with dso) unallocatedUnclaimedActivityRecordCid assertWithinDeadline "UnallocatedUnclaimedActivityRecord.expiresAt" expiresAt @@ -1715,10 +1870,11 @@ template DsoRules with nonconsuming choice DsoRules_ExpireUnallocatedUnclaimedActivityRecord : DsoRules_ExpireUnallocatedUnclaimedActivityRecordResult with unallocatedUnclaimedActivityRecordCid : ContractId UnallocatedUnclaimedActivityRecord - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) unallocatedUnclaimedActivityRecord <- fetchAndArchive (ForDso with dso) unallocatedUnclaimedActivityRecordCid assertDeadlineExceeded "UnallocatedUnclaimedActivityRecord.expiresAt" unallocatedUnclaimedActivityRecord.expiresAt pure $ DsoRules_ExpireUnallocatedUnclaimedActivityRecordResult @@ -1726,10 +1882,11 @@ template DsoRules with nonconsuming choice DsoRules_ExpireUnclaimedActivityRecord : DsoRules_ExpireUnclaimedActivityRecordResult with unclaimedActivityRecordCid : ContractId UnclaimedActivityRecord - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) UnclaimedActivityRecord_DsoExpireResult unclaimedRewardCid <- exercise unclaimedActivityRecordCid UnclaimedActivityRecord_DsoExpire pure DsoRules_ExpireUnclaimedActivityRecordResult with unclaimedRewardCid @@ -1745,16 +1902,199 @@ template DsoRules with amuletRulesCid : ContractId AmuletRules instructionCid : ContractId BootstrapExternalPartyConfigStateInstruction openMiningRoundTriple : OpenMiningRoundTriple - sv : Party + sv : Party -- ^ sv operator party controller sv do - _ <- getAndValidateSvParty this (Some sv) + let svOperator = sv + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) _ <- fetchAndArchive (ForDso dso) instructionCid _ <- exercise amuletRulesCid AmuletRules_BootstrapExternalPartyConfigState with openMiningRoundTriple expectedDso = dso pure DsoRules_BootstrapExternalPartyConfigStateResult + choice DsoRules_MigrateToOnLedgerSvRightOwners : ContractId DsoRules + with + svOperator : Party + controller svOperator + do + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) + require "svRightOwners is not already on-ledger" (isNone this.svRightOwners) + let svRightOwnerFromOperator svOperator info = SvRightOwnerInfo with + rightOwnerParty = svOperator + rewardNodeOperatorName = info.name + rewardWeight = info.svRewardWeight + beneficiaries = [] + -- ^ FIXME: Consider how we want the migration to work + -- option 1: Set it to empty here and then have automation in the sv app that sets it to the ones locally configured. + -- Then through two votes with same effectivity reduce weight & remove beneficiary + a separate vote to add new sv right owner + -- option 2: Switchover through a vote that sets beneficiaries for everyone + -- option 3: two-step process, first setup sv right owners through votes (probably a batched vote in some form) and then have a second vote to actually start using right owners (needs a new config flag to indicate whether right owners take effect) + voteWeight = 1 + create this with + svs = Map.fromList ([(sv, info with svRewardWeight = 0) | (sv, info) <- Map.toList this.svs]) + svRightOwners = Some (TextMap.fromList [(info.name, svRightOwnerFromOperator svOperator info) | (svOperator, info) <- Map.toList this.svs]) + + choice DsoRules_UpdateRightOwnerParty : ContractId DsoRules + with + name : Text + oldRightOwnerParty : Party + newRightOwnerParty : Party + controller oldRightOwnerParty + do + requireOnLedgerSvRightOwners this + case TextMap.lookup name (getSvRightOwners this) of + None -> abort ("No sv with name " <> show name) + Some info -> do + require "right owner parties match" (info.rightOwnerParty == oldRightOwnerParty) + create this with + svRightOwners = Some (TextMap.insert name (info with rightOwnerParty = newRightOwnerParty) (getSvRightOwners this)) + + choice DsoRules_UpdateBeneficiaries : ContractId DsoRules + with + name : Text + rightOwnerParty : Party + beneficiaries : [(Party, Decimal)] + controller rightOwnerParty + do + requireOnLedgerSvRightOwners this + case TextMap.lookup name (getSvRightOwners this) of + None -> abort ("No sv with name " <> show name) + Some info -> do + require "right owner parties match" (info.rightOwnerParty == rightOwnerParty) + create this with + svRightOwners = Some (TextMap.insert name (info with beneficiaries = beneficiaries) (getSvRightOwners this)) + + choice DsoRules_UpdateSvRightOwnerInfo : ContractId DsoRules + with + name : Text + baseInfo : SvRightOwnerInfo -- ^ The info the vote was created against + newInfo : SvRightOwnerInfo -- ^ The target info, only fields that are different from baseInfo will be updated + controller dso + do + requireOnLedgerSvRightOwners this + case TextMap.lookup name (getSvRightOwners this) of + None -> abort ("No SV with name " <> show name) + Some currentInfo -> do + create this with + svRightOwners = Some (TextMap.insert name (patch newInfo baseInfo currentInfo) (getSvRightOwners this)) + + nonconsuming choice DsoRules_AddSvRightOwner : ContractId AddSvRightOwnerInstruction + with + rightOwnerName : Text + info : SvRightOwnerInfo + controller dso + do + requireOnLedgerSvRightOwners this + now <- getTime + case TextMap.lookup rightOwnerName (getSvRightOwners this) of + Some _ -> abort ("SV with name " <> rightOwnerName <> " already exists") + None -> do + create AddSvRightOwnerInstruction with + dso + rightOwnerName + info + expiresAt = now `addRelTime` hours 1 + + choice DsoRules_ExecuteAddSvRightOwnerInstruction : ContractId DsoRules + with + instructionCid : ContractId AddSvRightOwnerInstruction + openMiningRoundCid : ContractId OpenMiningRound + svOperator : Party + controller svOperator + do + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) + requireOnLedgerSvRightOwners this + instruction <- fetchAndArchive (ForDso dso) instructionCid + openMiningRound <- fetchReferenceData (ForDso dso) openMiningRoundCid + case TextMap.lookup instruction.rightOwnerName (getSvRightOwners this) of + Some _ -> abort ("SV with name " <> instruction.rightOwnerName <> " already exists") + None -> do + createSvRightOwnerContracts this instruction.rightOwnerName openMiningRound.round + create this with + svRightOwners = Some (TextMap.insert instruction.rightOwnerName instruction.info (getSvRightOwners this)) + + nonconsuming choice DsoRules_RemoveSvRightOwner : ContractId RemoveSvRightOwnerInstruction + with + rightOwnerName : Text + controller dso + do + requireOnLedgerSvRightOwners this + case TextMap.lookup rightOwnerName (getSvRightOwners this) of + Some _ -> do + now <- getTime + create RemoveSvRightOwnerInstruction with + dso + rightOwnerName + expiresAt = now `addRelTime` hours 1 + None -> abort ("No SV with name " <> show rightOwnerName) + + choice DsoRules_ExecuteRemoveSvRightOwnerInstruction : ContractId DsoRules + with + instructionCid : ContractId RemoveSvRightOwnerInstruction + rewardStateCid : ContractId SvRewardState + svOperator : Party + controller svOperator + do + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) + requireOnLedgerSvRightOwners this + instruction <- fetchAndArchive (ForDso dso) instructionCid + case TextMap.lookup instruction.rightOwnerName (getSvRightOwners this) of + Some _ -> do + -- We archive the reward state as part of offboarding to avoid having to track offboardedSvs for non-operators. + -- In theory reonboarding an SV immediately could let it mint rewards twice for the same round. + -- In practice, reonboarding that quickly seems unrealistic in practice. + _ <- fetchAndArchive (ForSv with dso; svName = instruction.rightOwnerName) rewardStateCid + create this with svRightOwners = Some (TextMap.delete instruction.rightOwnerName (getSvRightOwners this)) + None -> abort ("No SV with name " <> show instruction.rightOwnerName) + + nonconsuming choice DsoRules_ExpireRemoveSvRightOwnerInstruction : () + with + instructionCid : ContractId RemoveSvRightOwnerInstruction + svOperator : Party + controller svOperator + do + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) + requireOnLedgerSvRightOwners this + instruction <- fetchAndArchive (ForDso dso) instructionCid + assertDeadlineExceeded "RemoveSvRightOwnerInstruction.expiresAt" instruction.expiresAt + pure () + + nonconsuming choice DsoRules_ExpireAddSvRightOwnerInstruction : () + with + instructionCid : ContractId AddSvRightOwnerInstruction + svOperator : Party + controller svOperator + do + _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) + requireOnLedgerSvRightOwners this + instruction <- fetchAndArchive (ForDso dso) instructionCid + assertDeadlineExceeded "AddSvRightOwnerInstruction.expiresAt" instruction.expiresAt + pure () + + +template AddSvRightOwnerInstruction + with + dso : Party + rightOwnerName : Text + info : SvRightOwnerInfo + expiresAt : Time + where + signatory dso + +template RemoveSvRightOwnerInstruction + with + dso : Party + rightOwnerName : Text + expiresAt : Time + where + signatory dso + +instance HasCheckedFetch RemoveSvRightOwnerInstruction ForDso where + contractGroupId RemoveSvRightOwnerInstruction{..} = ForDso dso + +instance HasCheckedFetch AddSvRightOwnerInstruction ForDso where + contractGroupId AddSvRightOwnerInstruction{..} = ForDso dso pruneAtLeastOne : Ord t => t -> Schedule t a -> Optional (Schedule t a) pruneAtLeastOne now schedule = @@ -1764,25 +2104,21 @@ pruneAtLeastOne now schedule = where (past, future) = span (\(t, _) -> t <= now) schedule.futureValues -summarizeDso : DsoRules -> DsoSummary -summarizeDso dsoRules = DsoSummary with - dsoDelegate = dsoRules.dsoDelegate - numSvs - requiredNumVotes = - -- NOTE: - -- For a vote with n svs and f = floor((n - 1) /3) byzantine svs, we want to have the following properties: - -- *availability*: f operators abstaining, won’t stop the vote - -- ⇒ numRequiredVotes <= n - f - -- *tolerate DSO delegate selecting the votes*: the threshold must be independent of the number of votes cast - -- *integrity*: f operators cannot boost their voting power for future votes by collaborating - -- ⇒ implies f < threshold-for-accepting-an-action - -- *result acceptance*: outcome is accepted by SV operators - -- ⇒ we can pick between requiring numYays >= n / 2 + 1 (simple majority) and requiring numYays >= numRequiredVotes (super-majority) - -- We favor the following threshold that agrees with our preference of having both integrity and availability. - ceiling ((intToDecimal (numSvs + f + 1)) / 2.0) +data VoteType = OperatorVote | RightOwnerVote + +summarizeDso : VoteType -> DsoRules -> DsoSummaryV2 +summarizeDso voteType dsoRules = DsoSummaryV2 with + totalVoteWeight + requiredVoteWeight = + ceiling ((intToDecimal (totalVoteWeight + f + 1)) / 2.0) + votersWithWeight = TextMap.fromList votersWithWeight where - numSvs = Map.size dsoRules.svs - f = floor ((intToDecimal (numSvs - 1)) / 3.0) + votersWithWeight = case voteType of + RightOwnerVote -> [(name, info.voteWeight) | (name, info) <- TextMap.toList (getSvRightOwners dsoRules), info.voteWeight > 0] + OperatorVote -> [(info.name, 1) | (_, info) <- Map.toList dsoRules.svs] -- operators have weight 1 + totalVoteWeight = sum (map snd votersWithWeight) + + f = floor ((intToDecimal (totalVoteWeight - 1)) / 3.0) -- | Execute an action which requires certain number of confirmations from SVs. -- Each confirmed action can at most be executed once. @@ -1817,6 +2153,9 @@ executeActionRequiringConfirmation dso dsoRulesCid amuletRulesCid act = case act SRARC_CreateTransferCommandCounter choiceArg -> void $ exercise dsoRulesCid choiceArg SRARC_CreateUnallocatedUnclaimedActivityRecord choiceArg -> void $ exercise dsoRulesCid choiceArg SRARC_CreateBootstrapExternalPartyConfigStateInstruction choiceArg -> void $ exercise dsoRulesCid choiceArg + SRARC_DsoRules_UpdateSvRightOwnerInfo choiceArg -> void $ exercise dsoRulesCid choiceArg + SRARC_DsoRules_AddSvRightOwner choiceArg -> void $ exercise dsoRulesCid choiceArg + SRARC_DsoRules_RemoveSvRightOwner choiceArg -> void $ exercise dsoRulesCid choiceArg ARC_AnsEntryContext with .. -> do void $ fetchChecked (ForDso with dso) ansEntryContextCid case ansEntryContextAction of @@ -1880,12 +2219,19 @@ actionRequiringConfirmationEffectiveAt action = -- On- and offboarding ---------------------- -getSvInfo : Party -> DsoRules -> Update SvInfo -getSvInfo operator this = - optional (fail "Not a sv") pure $ Map.lookup operator this.svs +getSvInfoByOperatorParty : ActionFail m => Party -> DsoRules -> m (Text, SvInfo) +getSvInfoByOperatorParty operator this = + case Map.lookup operator this.svs of + None -> fail ("Not a sv operator: " <> show operator) + Some svInfo -> pure (svInfo.name, svInfo) + +lookupSvInfoByName : Text -> DsoRules -> Optional SvRightOwnerInfo +lookupSvInfoByName svName this = + TextMap.lookup svName (getSvRightOwners this) + -lookupSvInfoByName : Text -> DsoRules -> Optional (Party, SvInfo) -lookupSvInfoByName svName DsoRules{..} = +lookupSvOperatorInfoByName : Text -> DsoRules -> Optional (Party, SvInfo) +lookupSvOperatorInfoByName svName DsoRules{..} = find (\info -> info._2.name == svName) $ Map.toList svs -- | Returns True if an SV with that name is either currently onboarded @@ -1899,34 +2245,37 @@ ensureNeverOperatedNode newSvParty this = do require "SV party has not yet operated a node" $ not (newSvParty `Map.member` this.svs || newSvParty `Map.member` this.offboardedSvs) --- factored out from the choice to avoid mistakes from having the fields of DsoRules{..} in scope -dsoRules_addSv : DsoRules -> DsoRules_AddSv -> Update (ContractId DsoRules) -dsoRules_addSv this0 arg@DsoRules_AddSv{..} = do - ensureNeverOperatedNode newSvParty this0 +checkSvNotAlreadyOnboarded : DsoRules -> Text -> Update DsoRules +checkSvNotAlreadyOnboarded this svOperatorName = -- in DevNet we allow changing the operator of an existing sv, which we implement as a removal and re-addition - this@DsoRules{..} <- - if this0.isDevNet + if this.isDevNet then - let DsoRules{..} = this0 in -- bring all DsoRules fields into scope - case lookupSvInfoByName newSvName this0 of - None -> pure this0 - Some (sv, info) -> do + case lookupSvOperatorInfoByName svOperatorName this of + Some (sv, SvInfo{participantId}) -> do let offboardingInfo = OffboardedSvInfo with - name = info.name - participantId = info.participantId - pure $ this0 with - svs = Map.delete sv svs - offboardedSvs = Map.insert sv offboardingInfo offboardedSvs + name = svOperatorName + participantId + pure $ this with + offboardedSvs = Map.insert sv offboardingInfo this.offboardedSvs + svs = Map.delete sv this.svs + _ -> pure this else do - require "SV is not currently onboarded" (isNone $ lookupSvInfoByName newSvName this0) - pure this0 + require "SV is not currently onboarded" (isNone $ lookupSvOperatorInfoByName svOperatorName this) + pure this - -- create per-sv contracts if they have never been onboarded - unless (svHasBeenOnboardedBefore newSvName this) $ - createPerSvContracts this arg +-- factored out from the choice to avoid mistakes from having the fields of DsoRules{..} in scope +dsoRules_addSv : DsoRules -> DsoRules_AddSv -> Update (ContractId DsoRules) +dsoRules_addSv this0 DsoRules_AddSv{..} = do + ensureNeverOperatedNode newSvParty this0 + this@DsoRules{..} <- checkSvNotAlreadyOnboarded this0 newSvName + if onLedgerSvRightOwners this + then require "rewardWeight must be 0 when onboarding a new SV operator with on-ledger right owners" (newSvRewardWeight == 0) + else + unless (svHasBeenOnboardedBefore newSvName this) $ + createSvRightOwnerContracts this newSvName joinedAsOfRound -- create per SV party contracts let initialAmuletPriceVote = None - createPerSvPartyContracts dso newSvParty newSvName noSynchronizerNodes initialAmuletPriceVote (getVoteCooldownTime config) + createSvOperatorContracts dso newSvParty newSvName noSynchronizerNodes initialAmuletPriceVote (getVoteCooldownTime config) -- register the new operator in the DsoRules let svInfo = SvInfo with name = newSvName @@ -1936,19 +2285,20 @@ dsoRules_addSv this0 arg@DsoRules_AddSv{..} = do create this with svs = Map.insert newSvParty svInfo svs -createPerSvContracts : DsoRules -> DsoRules_AddSv -> Update () -createPerSvContracts DsoRules{..} DsoRules_AddSv{..} = do +createSvRightOwnerContracts : DsoRules -> Text -> Round -> Update () +createSvRightOwnerContracts DsoRules{..} newSvName joinedAsOfRound = do void $ create SvRewardState with dso svName = newSvName state = RewardState with lastRoundCollected = Round (joinedAsOfRound.number - 1) numRoundsMissed = 0 + numRoundsCollected = 0 numCouponsIssued = 0 -createPerSvPartyContracts : Party -> Party -> Text -> SynchronizerNodeConfigMap -> Optional Decimal -> RelTime -> Update () -createPerSvPartyContracts dso newSvParty newSvName synchronizerNodes amuletPrice voteCooldownTime = do +createSvOperatorContracts : Party -> Party -> Text -> SynchronizerNodeConfigMap -> Optional Decimal -> RelTime -> Update () +createSvOperatorContracts dso newSvParty newSvName synchronizerNodes amuletPrice voteCooldownTime = do -- Note: we currently track the amulet-price vote on a per operator basis. -- This implies it will be reset when an operator is offboarded and re-onboarded. now <- getTime @@ -1972,12 +2322,25 @@ createPerSvPartyContracts dso newSvParty newSvName synchronizerNodes amuletPrice state = NodeState with synchronizerNodes -getAndValidateSvParty : DsoRules -> Optional Party -> Update Party -getAndValidateSvParty _ None = fail "no SV party provided" -getAndValidateSvParty rules (Some sv) = do - require "SV party is an actual SV" (sv `Map.member` rules.svs) - pure sv - +getAndValidateSvNodeOperatorParty : DsoRules -> Optional Party -> Update Text +getAndValidateSvNodeOperatorParty _ None = fail "no SV operator party provided" +getAndValidateSvNodeOperatorParty rules (Some sv) = do + case Map.lookup sv rules.svs of + None -> fail ("SV party " <> show sv <> " is not a registered SV node operator") + Some svInfo -> pure svInfo.name + +getAndValidateSvRightOwnerParty : DsoRules -> Optional Party -> Update Text +getAndValidateSvRightOwnerParty _ None = fail "no SV right owner party provided" +getAndValidateSvRightOwnerParty rules (Some sv) = do + case find (\(_, info) -> info.rightOwnerParty == sv) (TextMap.toList (getSvRightOwners rules)) of + None -> fail ("SV party " <> show sv <> " is not a right owner party") + Some (name, _) -> pure name + +getAndValidateVotingParty : DsoRules -> Party -> ActionRequiringConfirmation -> Update Text +getAndValidateVotingParty dsoRules party action = + case voteType action of + RightOwnerVote -> getAndValidateSvRightOwnerParty dsoRules (Some party) + OperatorVote -> getAndValidateSvNodeOperatorParty dsoRules (Some party) -- Rate limiting ---------------- @@ -2067,3 +2430,10 @@ instance Patchable LogicalSynchronizerUpgradeSchedule where upgradeTime = patch new.upgradeTime base.upgradeTime current.upgradeTime newPhysicalSynchronizerSerial = patch new.newPhysicalSynchronizerSerial base.newPhysicalSynchronizerSerial current.newPhysicalSynchronizerSerial newPhysicalSynchronizerProtocolVersion = patch new.newPhysicalSynchronizerProtocolVersion base.newPhysicalSynchronizerProtocolVersion current.newPhysicalSynchronizerProtocolVersion + +operatorParties : DsoRules -> [Party] +operatorParties DsoRules{svs} = Map.keys svs + +rightOwnerParties : DsoRules -> [Party] +rightOwnerParties this = + map (\(_, v) -> v.rightOwnerParty) (TextMap.toList (getSvRightOwners this)) From 820ea9c7b7b6c5da66fb1e3ceedb992ff9e34bba Mon Sep 17 00:00:00 2001 From: "moritz.kiefer@digitalasset.com" Date: Thu, 30 Jul 2026 17:08:57 +0200 Subject: [PATCH 02/30] Move right owner data to per right owner contract Signed-off-by: moritz.kiefer@digitalasset.com --- .../daml/Splice/Scripts/DsoTestUtils.daml | 31 ++- .../daml/Splice/Scripts/TestGovernance.daml | 78 +++++-- .../daml/Splice/DSO/SvRightOwner.daml | 41 +++- .../daml/Splice/DsoBootstrap.daml | 20 +- .../daml/Splice/DsoRules.daml | 193 +++++++++--------- 5 files changed, 240 insertions(+), 123 deletions(-) diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml index 020ee35790..dafb1d09ad 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml @@ -379,25 +379,46 @@ executeAllDefinitiveVotes app = do let activeSvs = Set.fromList (map fst $ TextMap.toList (getSvRightOwners rules)) let execute = request.voteBefore <= now || (activeSvs == Set.fromList (Map.keys request.votes)) + rightOwnerCids <- querySvRightOwners app when execute $ do + Some request <- queryContractId app.dso requestCid void $ submit (actAs submitter <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_CloseVoteRequest with requestCid amuletRulesCid = Some amuletRulesCid sv = Some submitter + rightOwnerCids = if voteType request.action == RightOwnerVote then rightOwnerCids else None + +lookupRightOwner : AmuletApp -> Party -> Script (Optional (ContractId SvRightOwner)) +lookupRightOwner app rightOwnerParty = do + rightOwners <- queryFilter @SvRightOwner app.dso (\ro -> ro.info.rightOwnerParty == rightOwnerParty) + case rightOwners of + [] -> pure None + [(roCid, _)] -> pure (Some roCid) + _ -> abort "lookupRightOwner: multiple SvRightOwner contracts found for the same party" + +querySvRightOwners : AmuletApp -> Script (Optional (TextMap.TextMap (ContractId SvRightOwner))) +querySvRightOwners app = do + rightOwners <- query @SvRightOwner app.dso + pure $ if null rightOwners + then None + else Some (TextMap.fromList [(ro.rightOwnerName, roCid) | (roCid, ro) <- rightOwners]) initiateAndCastVote : AmuletApp -> [Party] -> Optional Time -> ActionRequiringConfirmation -> Script (ContractId VoteRequest) initiateAndCastVote _ [] _ _ = error "initiateVote: require at least one party" initiateAndCastVote app (initiator::others) targetEffectiveAt action = do [(dsoRulesCid, _)] <- query @DsoRules app.dso + rightOwnerCid <- lookupRightOwner app initiator requestCid <- submit (actAs initiator <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with requester = initiator action reason = Reason with url = ""; body = "let's get it done" targetEffectiveAt voteRequestTimeout = None + rightOwnerCid = if voteType action == RightOwnerVote then rightOwnerCid else None foldlA (castVote dsoRulesCid) requestCid.voteRequest others where castVote dsoRulesCid requestCid sv = do + rightOwnerCid <- lookupRightOwner app sv result <- submit (actAs sv <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with requestCid vote = Vote with @@ -405,22 +426,26 @@ initiateAndCastVote app (initiator::others) targetEffectiveAt action = do accept = True reason = Reason with url = ""; body = "✓" optCastAt = None + rightOwnerCid = if voteType action == RightOwnerVote then rightOwnerCid else None return result.voteRequest initiateAndAcceptVote : AmuletApp -> [Party] -> ActionRequiringConfirmation -> Script () initiateAndAcceptVote _ [] _ = error "initiateAndAcceptVote: require at least one party" initiateAndAcceptVote app (initiator::others) action = do [(dsoRulesCid, _)] <- query @DsoRules app.dso + rightOwnerCid <- lookupRightOwner app initiator requestCid <- submit (actAs initiator <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with requester = initiator action reason = Reason with url = ""; body = "let's get it done" targetEffectiveAt = None voteRequestTimeout = None + rightOwnerCid = if voteType action == RightOwnerVote then rightOwnerCid else None foldlA (castVote dsoRulesCid) requestCid.voteRequest others executeAllDefinitiveVotes app where castVote dsoRulesCid requestCid sv = do + rightOwnerCid <- lookupRightOwner app sv result <- submit (actAs sv <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with requestCid vote = Vote with @@ -428,13 +453,16 @@ initiateAndAcceptVote app (initiator::others) action = do accept = True reason = Reason with url = ""; body = "✓" optCastAt = None + rightOwnerCid = if voteType action == RightOwnerVote then rightOwnerCid else None return result.voteRequest -- cast a vote on a request castVote : AmuletApp -> Party -> ContractId VoteRequest -> Bool -> Script (ContractId VoteRequest) castVote app sv requestCid vote = do [(dsoRulesCid, _)] <- query @DsoRules app.dso - result <- submit (actAs sv <> actAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with + rightOwnerCid <- lookupRightOwner app sv + Some request <- queryContractId app.dso requestCid + result <- submit (actAs sv <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with requestCid = requestCid vote = Vote with sv = sv @@ -443,6 +471,7 @@ castVote app sv requestCid vote = do url = "" body = "" optCastAt = None + rightOwnerCid = if voteType request.action == RightOwnerVote then rightOwnerCid else None return result.voteRequest -- | Update all currently desired prices to the target price diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml index 41b37751cb..3e453d5f7b 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernance.daml @@ -55,16 +55,18 @@ testVoteRequestAcceptanceWithoutEffectivity = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = None voteRequestTimeout = Some (days 7) -- give everybody 7 days to vote + rightOwnerCid = None let requestCid1 = result.voteRequest - + -- sv2 rejects initially requestCid <- castVote app sv2 requestCid1 False - + -- there are two votes, which is not enough to consider the vote definitive and grant the app right submitMustFail (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CloseVoteRequest with requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- a day passes and sv2 updates their vote passTime (days 1) @@ -79,6 +81,7 @@ testVoteRequestAcceptanceWithoutEffectivity = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- sv3 accepts too requestCid <- castVote app sv3 requestCid True @@ -88,6 +91,7 @@ testVoteRequestAcceptanceWithoutEffectivity = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None [(rightCid, right)] <- query @FeaturedAppRight provider right === FeaturedAppRight with dso; provider; activityWeight = Some 11.0 @@ -130,6 +134,7 @@ testVoteRequestAcceptanceWithEffectivity = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = Some (effectiveTime) -- the right will be granted in 8 days voteRequestTimeout = Some (days 7) -- give everybody 7 days to vote with the possibility to change their vote + rightOwnerCid = None let requestCid1 = result.voteRequest -- sv2 accepts @@ -140,6 +145,7 @@ testVoteRequestAcceptanceWithEffectivity = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- the voteRequest trackingCid is set to the initial requestCid Some voteRequest <- queryContractId dso requestCid @@ -154,6 +160,7 @@ testVoteRequestAcceptanceWithEffectivity = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- sv4 rejects requestCid <- castVote app sv4 requestCid False @@ -166,6 +173,7 @@ testVoteRequestAcceptanceWithEffectivity = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- sv4 can change its vote past the expiration date requestCid <- castVote app sv4 requestCid True @@ -178,6 +186,7 @@ testVoteRequestAcceptanceWithEffectivity = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None now <- getTime result.completedAt === now @@ -227,7 +236,7 @@ testVoteRequestAcceptanceWithEffectivity = do testVoteRequestRejectionWithoutEffectivity : Script () testVoteRequestRejectionWithoutEffectivity = do - (_app, dso, (sv1, sv2, _sv3, sv4)) <- initMainNet + (app, dso, (sv1, sv2, _sv3, sv4)) <- initMainNet [(dsoRulesCid, _)] <- query @DsoRules dso @@ -245,14 +254,15 @@ testVoteRequestRejectionWithoutEffectivity = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = None voteRequestTimeout = Some (days 7) -- give everybody 7 days to vote + rightOwnerCid = None let requestCid = result.voteRequest -- majority rejects the request - requestCid <- castVote _app sv2 requestCid False - requestCid <- castVote _app sv4 requestCid False + requestCid <- castVote app sv2 requestCid False + requestCid <- castVote app sv4 requestCid False -- sv1 changes their opinion and votes again after the cooldown of 1 minute passTime (minutes 1) - requestCid <- castVote _app sv1 requestCid False + requestCid <- castVote app sv1 requestCid False -- the request is directly rejected now <- getTime @@ -260,6 +270,7 @@ testVoteRequestRejectionWithoutEffectivity = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] @@ -291,6 +302,7 @@ testVoteRequestRejectionWithEffectivityBeforeExpiration = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = Some (effectiveTime) voteRequestTimeout = Some (days 3) -- give everybody 3 days to vote + rightOwnerCid = None let requestCid = result.voteRequest -- majority rejects the request @@ -306,6 +318,7 @@ testVoteRequestRejectionWithEffectivityBeforeExpiration = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] @@ -337,6 +350,7 @@ testVoteRequestRejectionWithEffectivityAfterExpiration = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = Some (addRelTime now (days 1)) voteRequestTimeout = Some (days 2) + rightOwnerCid = None -- sv1 initiates the granting of the featured app right for the provider result <- submit (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with @@ -348,6 +362,7 @@ testVoteRequestRejectionWithEffectivityAfterExpiration = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = Some (effectiveTime) voteRequestTimeout = Some (days 3) -- give everybody 3 days to vote + rightOwnerCid = None let requestCid = result.voteRequest -- a majority accepts the request before the expiration data @@ -359,6 +374,7 @@ testVoteRequestRejectionWithEffectivityAfterExpiration = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- the expiration date has passed passTime (days 3) @@ -373,6 +389,7 @@ testVoteRequestRejectionWithEffectivityAfterExpiration = do requestCid amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None now <- getTime @@ -399,6 +416,7 @@ testRacingSvRemoval = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 7) -- give everybody 7 days to vote + rightOwnerCid = None result2 <- submit (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with requester = sv1 @@ -408,6 +426,7 @@ testRacingSvRemoval = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 7) -- give everybody 7 days to vote + rightOwnerCid = None -- sv2 counters and wants to remove sv1 result3 <- submit (actAs sv2 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with @@ -418,6 +437,7 @@ testRacingSvRemoval = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 7) -- give everybody 7 days to vote + rightOwnerCid = None -- sv1 is not really happy with sv2, and issues a third removal request with an effective date set in 8 days. now <- getTime @@ -431,6 +451,7 @@ testRacingSvRemoval = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = Some (effectiveTime) voteRequestTimeout = Some (days 2) -- give everybody 2 days to vote + rightOwnerCid = None let (req1, req2, req3, req4) = (result1.voteRequest, result2.voteRequest, result3.voteRequest, result4.voteRequest) @@ -447,6 +468,7 @@ testRacingSvRemoval = do accept = True reason = Reason with url = ""; body = "OK, let them go" optCastAt = None + rightOwnerCid = None result2 <- submit (actAs sv2 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with requestCid = result1.voteRequest vote = Vote with @@ -454,6 +476,7 @@ testRacingSvRemoval = do accept = True reason = Reason with url = ""; body = "OK, let them go" optCastAt = None + rightOwnerCid = None result3 <- submit (actAs sv3 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with requestCid = result2.voteRequest vote = Vote with @@ -461,6 +484,7 @@ testRacingSvRemoval = do accept = True reason = Reason with url = ""; body = "OK, let them go" optCastAt = None + rightOwnerCid = None result4 <- submit (actAs sv4 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with requestCid = result3.voteRequest vote = Vote with @@ -468,6 +492,7 @@ testRacingSvRemoval = do accept = True reason = Reason with url = ""; body = "OK, let them go" optCastAt = None + rightOwnerCid = None pure result4.voteRequest -- sv1 attempts to immediatly accept the request to remove sv2 @@ -476,6 +501,7 @@ testRacingSvRemoval = do requestCid = req1 amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] @@ -489,6 +515,7 @@ testRacingSvRemoval = do requestCid = req2 amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- sv3 refuses and sv4 accepts request 4 with effectivity 8 days before the expiration. req4 <- castVote app sv3 req4 False @@ -504,6 +531,7 @@ testRacingSvRemoval = do requestCid = req4 amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None now <- getTime result.completedAt === now @@ -517,6 +545,7 @@ testRacingSvRemoval = do requestCid = req3 amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === ["sv2"] @@ -537,6 +566,7 @@ testRacingSvRemoval = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (seconds 1) -- attempt to not give sv4 enough time to vote + rightOwnerCid = None let req4 = result4.voteRequest -- early closing is not possible, as the outcome of the vote is not determined, and we thus leave @@ -545,6 +575,7 @@ testRacingSvRemoval = do requestCid = req4 amuletRulesCid = None sv = Some sv3 + rightOwnerCids = None -- after enough time has passed the closing works passTime (seconds 1) @@ -552,6 +583,7 @@ testRacingSvRemoval = do requestCid = req4 amuletRulesCid = None sv = Some sv3 + rightOwnerCids = None -- however sv4 is still here, as at least `numSvs / 2 + 1` svs need to accept the offboarding result.outcome === VRO_Expired @@ -565,6 +597,7 @@ testRacingSvRemoval = do reason = Reason with url = ""; body = "they want to leave!" targetEffectiveAt = None voteRequestTimeout = Some (days 1) + rightOwnerCid = None castResult <- submit (actAs sv4 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with requestCid = result5.voteRequest @@ -573,6 +606,7 @@ testRacingSvRemoval = do accept = True reason = Reason with url = ""; body = "yes, let me go please!" optCastAt = None + rightOwnerCid = None let req5 = castResult.voteRequest -- and actually early closing is possible, as everybody has voted and the outcome is definite @@ -581,6 +615,7 @@ testRacingSvRemoval = do requestCid = req5 amuletRulesCid = None sv = Some sv3 + rightOwnerCids = None result.outcome === VRO_Accepted with effectiveAt = now @@ -649,6 +684,7 @@ testDsoRulesConfigChange = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 2) + rightOwnerCid = None result2 <- submit (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with requester = sv1 @@ -659,6 +695,7 @@ testDsoRulesConfigChange = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 2) + rightOwnerCid = None let (req1, req2) = (result1.voteRequest, result2.voteRequest) @@ -670,6 +707,7 @@ testDsoRulesConfigChange = do requestCid = req1 amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] @@ -687,6 +725,7 @@ testDsoRulesConfigChange = do requestCid = req2 amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] @@ -703,7 +742,6 @@ testDsoRulesConfigChange = do testAmuletRulesTickDurationChange : Script () testAmuletRulesTickDurationChange = do (app, dso, (sv1, sv2, sv3, _)) <- initMainNet - [(dsoRulesCid, _)] <- query @DsoRules dso [(_, amuletRules)] <- query @AmuletRules dso @@ -722,6 +760,7 @@ testAmuletRulesTickDurationChange = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 2) + rightOwnerCid = None now <- getTime -- vote on change @@ -733,6 +772,7 @@ testAmuletRulesTickDurationChange = do requestCid = request amuletRulesCid = Some amuletRulesCid sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] @@ -826,6 +866,7 @@ testAmuletRulesConfigChange = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 2) + rightOwnerCid = None result2 <- submit (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_RequestVote with requester = sv1 @@ -836,6 +877,7 @@ testAmuletRulesConfigChange = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 2) + rightOwnerCid = None let (req1, req2) = (result1.voteRequest, result2.voteRequest) @@ -846,7 +888,7 @@ testAmuletRulesConfigChange = do requestCid = req1 amuletRulesCid = Some amuletRulesCid sv = Some sv1 - + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] result.abstainingSvs === ["sv4"] @@ -863,6 +905,7 @@ testAmuletRulesConfigChange = do requestCid = req2 amuletRulesCid = Some amuletRulesCid sv = Some sv1 + rightOwnerCids = None result.completedAt === now result.offboardedVoters === [] @@ -932,7 +975,7 @@ testOffboardSvAndAmuletPriceVotes = do -- | vote request contract is archived if it has expired testVoteRequestExpireWithoutEffectivity : Script () testVoteRequestExpireWithoutEffectivity = do - (_, dso, (sv1, _, _, _)) <- initMainNet + (_app, dso, (sv1, _, _, _)) <- initMainNet provider <- allocateParty "provider" [(dsoRulesCid, _)] <- query @DsoRules dso @@ -945,12 +988,14 @@ testVoteRequestExpireWithoutEffectivity = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = None voteRequestTimeout = None + rightOwnerCid = None -- attempt to close the vote request before its voting period submitMustFail (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CloseVoteRequest with requestCid = requestResult.voteRequest amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None passTime(days 7) now <- getTime @@ -960,6 +1005,7 @@ testVoteRequestExpireWithoutEffectivity = do requestCid = requestResult.voteRequest amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- only sv1 voted to accept as they created the request result.completedAt === now @@ -972,7 +1018,7 @@ testVoteRequestExpireWithoutEffectivity = do testVoteRequestExpireWithEffectivity : Script () testVoteRequestExpireWithEffectivity = do - (_, dso, (sv1, _, _, _)) <- initMainNet + (_app, dso, (sv1, _, _, _)) <- initMainNet provider <- allocateParty "provider" now <- getTime @@ -988,12 +1034,14 @@ testVoteRequestExpireWithEffectivity = do reason = Reason with url = ""; body = "they are great!" targetEffectiveAt = Some (effectiveTime) voteRequestTimeout = None + rightOwnerCid = None -- attempt to close the vote request before its voting period submitMustFail (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CloseVoteRequest with requestCid = requestResult.voteRequest amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None passTime(days 7) now <- getTime @@ -1003,6 +1051,7 @@ testVoteRequestExpireWithEffectivity = do requestCid = requestResult.voteRequest amuletRulesCid = None sv = Some sv1 + rightOwnerCids = None -- only sv1 voted to accept as they created the request result.completedAt === now @@ -1083,7 +1132,7 @@ testAmuletPriceVoting = do testVoteCastingCooldown : Script () testVoteCastingCooldown = do - (_, dso, (sv1, sv2, _sv3, _sv4)) <- initMainNet + (_app, dso, (sv1, sv2, _sv3, _sv4)) <- initMainNet [(dsoRulesCid, _)] <- query @DsoRules dso @@ -1096,6 +1145,7 @@ testVoteCastingCooldown = do reason = Reason with url = ""; body = "they are not good for us!" targetEffectiveAt = None voteRequestTimeout = Some (days 7) -- give everybody 7 days to vote + rightOwnerCid = None let requestCid = result.voteRequest -- SV2 can immediately cast a vote @@ -1106,6 +1156,7 @@ testVoteCastingCooldown = do accept = False reason = Reason with url = ""; body = "noooo, let me stay on please!" optCastAt = None + rightOwnerCid = None let requestCid = result.voteRequest -- The second vote SV2 fails though @@ -1116,6 +1167,7 @@ testVoteCastingCooldown = do accept = False reason = Reason with url = ""; body = "a better rebuttal" optCastAt = None + rightOwnerCid = None -- And that same holds for SV1, as it voted as part of creating the request. _ <- submitMustFail (actAs sv1 <> readAs dso) $ exerciseCmd dsoRulesCid DsoRules_CastVote with @@ -1125,7 +1177,7 @@ testVoteCastingCooldown = do accept = True reason = Reason with url = ""; body = "a better reason" optCastAt = None - + rightOwnerCid = None -- let the vote cooldown pass, so they can update their votes passTime (minutes 1) @@ -1137,6 +1189,7 @@ testVoteCastingCooldown = do accept = False reason = Reason with url = ""; body = "a better rebuttal" optCastAt = None + rightOwnerCid = None let requestCid = result.voteRequest -- And that same holds for SV1, as it voted as part of creating the request. @@ -1147,5 +1200,6 @@ testVoteCastingCooldown = do accept = True reason = Reason with url = ""; body = "a better reason" optCastAt = None + rightOwnerCid = None pure () diff --git a/daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml b/daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml index b3d6b64cc0..6d1b0f89ea 100644 --- a/daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml +++ b/daml/splice-dso-governance/daml/Splice/DSO/SvRightOwner.daml @@ -1,6 +1,9 @@ module Splice.DSO.SvRightOwner where +import DA.List (unique) +import Splice.DSO.SvState import Splice.Util +import Splice.Types -- | Information about a super validator right owner. data SvRightOwnerInfo = SvRightOwnerInfo @@ -15,10 +18,6 @@ data SvRightOwnerInfo = SvRightOwnerInfo -- For rewards to be minted both the node operator. beneficiaries : [(Party, Decimal)] -- ^ List of beneficiaries and their percentages for reward distribution. Must not include rightOwnerParty. Remainder goes to rightOwnerParty. - -- FIXME: probably want to move this to a separate contract - -- FIXME: Comment for reviewer: This is deliberately a percentage not a weight. With automatic weight adjustments absolutel weights don't work anymore. - -- Beneficiaries are also more of an exception than the rule now that all actual SVs are directly represented as SVs and beneficiaries - -- are only if an SV does not want to mint directly under their SV party. deriving (Eq, Show) instance Patchable SvRightOwnerInfo where @@ -28,4 +27,36 @@ instance Patchable SvRightOwnerInfo where voteWeight = patch new.voteWeight base.voteWeight current.voteWeight rewardWeight = patch new.rewardWeight base.rewardWeight current.rewardWeight rewardNodeOperatorName = patch new.rewardNodeOperatorName base.rewardNodeOperatorName current.rewardNodeOperatorName - beneficiaries = patchScalar new.beneficiaries base.beneficiaries current.beneficiaries + beneficiaries = patchScalar new.beneficiaries base.beneficiaries current.beneficiaries + +template SvRightOwner + with + dso : Party + rightOwnerName : Text + info : SvRightOwnerInfo + where + signatory dso + ensure validSvRightOwnerInfo info + +instance HasCheckedFetch SvRightOwner ForSv where + contractGroupId SvRightOwner{..} = + ForSv + with + dso + svName = rightOwnerName + +instance HasCheckedFetch SvRightOwner ForDso where + contractGroupId SvRightOwner{..} = + ForDso + with + dso + +validSvRightOwnerInfo : SvRightOwnerInfo -> Bool +validSvRightOwnerInfo SvRightOwnerInfo{..} = + voteWeight >= 0 && + rewardWeight >= 0 && + sum (map snd beneficiaries) <= 1.0 && + all (\(_, beneficiaryWeight) -> beneficiaryWeight > 0.0) beneficiaries && + all (\(beneficiary,_) -> beneficiary /= rightOwnerParty) beneficiaries && + unique (map fst beneficiaries) && + length beneficiaries <= 20 \ No newline at end of file diff --git a/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml b/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml index 1bbd93409e..6f00313f36 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml @@ -3,6 +3,7 @@ module Splice.DsoBootstrap where +import DA.Functor import qualified DA.Map as Map import qualified DA.TextMap as TextMap import DA.Time @@ -78,18 +79,15 @@ template DsoBootstrap with config initialTrafficState isDevNet - svRightOwners = flip fmap sv1RightOwnerName $ \rightOwnerName -> TextMap.fromList [ - ( sv1Name - , SvRightOwnerInfo with - rightOwnerParty = sv1Party - voteWeight = fromOptional 0 sv1VoteWeight - rewardWeight = sv1RewardWeight - rewardNodeOperatorName = rightOwnerName - beneficiaries = [] - ) - ] + svRightOwners = sv1RightOwnerName <&> \name -> TextMap.fromList [(name, ())] + let info = sv1RightOwnerName <&> \rightOwnerName -> SvRightOwnerInfo with + rightOwnerParty = sv1Party + voteWeight = fromOptional 0 sv1VoteWeight + rewardWeight = sv1RewardWeight + rewardNodeOperatorName = rightOwnerName + beneficiaries = [] create dsoRules let joinedAsOfRound = fromOptional (Round 0) result.initialRound - createSvRightOwnerContracts dsoRules sv1Name joinedAsOfRound + createSvRightOwnerContracts dsoRules sv1Name info joinedAsOfRound createSvOperatorContracts dso sv1Party sv1Name sv1SynchronizerNodes (Some amuletPrice) (getVoteCooldownTime config) return DsoBootstrap_BootstrapResult diff --git a/daml/splice-dso-governance/daml/Splice/DsoRules.daml b/daml/splice-dso-governance/daml/Splice/DsoRules.daml index 95a63525ca..39b1f1f78c 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoRules.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoRules.daml @@ -10,7 +10,7 @@ import DA.Assert import DA.Either (partitionEithers) import DA.Foldable (forA_, all) import DA.List as List hiding (all) -import DA.Optional (isNone, fromOptional, isSome, fromSome) +import DA.Optional (isNone, fromOptional, isSome) import qualified DA.Map as Map import qualified DA.Set as Set import qualified DA.Text as T @@ -542,18 +542,7 @@ data TrafficState = TrafficState with consumedTraffic: Int -- ^ Bytes of extra traffic consumed before the decentralized synchronizer was bootstrapped. deriving (Eq, Show) -validSvRightOwnerInfo : DsoRules -> SvRightOwnerInfo -> Bool -validSvRightOwnerInfo DsoRules{} SvRightOwnerInfo{..} = - voteWeight >= 0 && - rewardWeight >= 0 && - sum (map snd beneficiaries) <= 1.0 && - all (\(_, beneficiaryWeight) -> beneficiaryWeight > 0.0) beneficiaries && - all (\(beneficiary,_) -> beneficiary /= rightOwnerParty) beneficiaries && - unique (map fst beneficiaries) - -- FIXME: Do we want this assertion? If so, we need to switch the node operator on offboarding. - -- && any (\info -> info.name == rewardNodeOperatorName) (Map.values svs) - -getSvRightOwners : DsoRules -> TextMap.TextMap SvRightOwnerInfo +getSvRightOwners : DsoRules -> TextMap.TextMap () getSvRightOwners DsoRules{..} = fromOptional TextMap.empty svRightOwners onLedgerSvRightOwners : DsoRules -> Bool @@ -571,7 +560,7 @@ template DsoRules with dso : Party epoch : Int svs : Map.Map Party SvInfo - -- ^ Deprecated in favor of svRightOwners + -- ^ SV Node Operators offboardedSvs : Map.Map Party OffboardedSvInfo -- ^ Only set for sv node owners to handle DSO party offboarding dsoDelegate : Party @@ -579,12 +568,12 @@ template DsoRules with config : DsoRulesConfig initialTrafficState: Map.Map Text TrafficState -- ^ Map from participant/mediator ID to its traffic state at the time of synchronizer bootstrapping. Used for testing, empty in prod. isDevNet : Bool - svRightOwners : Optional (TextMap.TextMap SvRightOwnerInfo) -- ^ Map from sv right owner name to info about the right owner + svRightOwners : Optional (TextMap.TextMap ()) -- ^ Set of sv right owner names + -- FIXME: Consider changing to [Text] where ensure config.numUnclaimedRewardsThreshold > 0 && - all (\(_, v) -> validSvRightOwnerInfo this v) (TextMap.toList (getSvRightOwners this)) && -- when using on-ledger right owners they must be non-empty optional True (\rightOwners -> TextMap.size rightOwners >= 1) svRightOwners && -- when using on-ledger right owners the weight in the operator info must be 0 @@ -793,7 +782,7 @@ template DsoRules with controller sv do _ <- getAndValidateSvNodeOperatorParty this sv - let s = summarizeDso OperatorVote this + s <- summarizeDso OperatorVote TextMap.empty this let forDso = ForDso with dso -- there are no operator vote weights so just number of confirmations is sufficient. require "Enough confirmations" (length confirmationCids >= s.requiredVoteWeight) @@ -819,9 +808,10 @@ template DsoRules with reason : Reason voteRequestTimeout : Optional RelTime targetEffectiveAt : Optional Time + rightOwnerCid : Optional (ContractId SvRightOwner) controller requester do - requesterName <- getAndValidateVotingParty this requester action + requesterName <- getAndValidateVotingParty rightOwnerCid this requester action requireWellformedReason config reason now <- getTime let voteBefore = case voteRequestTimeout of @@ -852,13 +842,14 @@ template DsoRules with with requestCid : ContractId VoteRequest vote : Vote + rightOwnerCid : Optional (ContractId SvRightOwner) controller vote.sv do -- validate vote parameters requireWellformedVote config vote -- validate and archive request request <- fetchAndArchive (ForDso with dso) requestCid - voterName <- getAndValidateVotingParty this vote.sv request.action + voterName <- getAndValidateVotingParty rightOwnerCid this vote.sv request.action -- rate limit casting of votes by the same SV to avoid them blocking others from making progress -- Note: we currently ignore the optional self-declared vote casting time -- `vote.optCastAt`. We'll use that in the future when adding support for larger @@ -900,13 +891,14 @@ template DsoRules with requestCid : ContractId VoteRequest amuletRulesCid : Optional (ContractId AmuletRules) sv : Optional Party + rightOwnerCids : Optional (TextMap.TextMap (ContractId SvRightOwner)) controller sv do _ <- getAndValidateSvNodeOperatorParty this sv now <- getTime request <- fetchAndArchive (ForDso with dso) requestCid - let s = summarizeDso (voteType request.action) this + s <- summarizeDso (voteType request.action) (fromOptional TextMap.empty rightOwnerCids) this let (validVotes, offboardedVoters) = partitionEithers [ case TextMap.lookup voterName s.votersWithWeight of @@ -1478,35 +1470,29 @@ template DsoRules with with sv : Party -- ^ sv operator party openRoundCid : ContractId OpenMiningRound - svRewardStates : TextMap.TextMap (ContractId SvRewardState) + svRewardStates : TextMap.TextMap (ContractId SvRightOwner, ContractId SvRewardState) controller sv do requireOnLedgerSvRightOwners this let svOperator = sv operatorName <- getAndValidateSvNodeOperatorParty this (Some svOperator) - let info = fromSome (TextMap.lookup operatorName (getSvRightOwners this)) now <- getTime openRound <- fetchReferenceData (ForDso with dso) openRoundCid require "OpenRound is open" (openRound.opensAt <= now) - -- FIXME: Do we want to enforce that the operator has to pass in all states that have configured them as a node operator? - -- given that you do rely on the operator anyway to mint rewards maybe not required. - -- if we do enforce it, we need to handle cases where the lastRoundCollected is out of sync which can happen on operator switches. - forA_ (TextMap.toList svRewardStates) $ \(svName, rewardStateCid) -> do - svInfo <- case TextMap.lookup svName (getSvRightOwners this) of - None -> fail ("SV " <> svName <> " is not an SV") - Some svInfo -> do - require ("SV " <> svName <> " is minting rewards through " <> show operatorName) (svInfo.rewardNodeOperatorName == operatorName) - pure svInfo - rewardState <- fetchAndArchive (ForSv with dso; svName = svName) rewardStateCid + forA_ (TextMap.toList svRewardStates) $ \(svName, (rightOwnerCid, rewardStateCid)) -> do + rewardState <- fetchAndArchive (ForSv with dso, svName) rewardStateCid + svRightOwner <- fetchChecked (ForSv with dso, svName) rightOwnerCid + require "Operator matches" (svRightOwner.info.rewardNodeOperatorName == operatorName) + let svInfo = svRightOwner.info let state = rewardState.state beneficiaries = svInfo.beneficiaries let (configuredBeneficiaryCouponWeights, remainingWeight) = foldl (\(acc, remainingWeight) (beneficiary, weight) -> - let beneficiaryWeight = floor (weight * intToDecimal info.rewardWeight) + let beneficiaryWeight = floor (weight * intToDecimal svInfo.rewardWeight) in ((beneficiary, beneficiaryWeight) :: acc, remainingWeight - beneficiaryWeight)) - ([], info.rewardWeight) + ([], svInfo.rewardWeight) beneficiaries beneficiaryCouponWeights = if remainingWeight > 0 then (svInfo.rightOwnerParty, remainingWeight) :: configuredBeneficiaryCouponWeights @@ -1524,7 +1510,7 @@ template DsoRules with numCouponsIssued = state.numCouponsIssued + length beneficiaryCouponWeights -- check weights and issue rewards - require "Sum of beneficiary weights matches" (info.rewardWeight == sum (map snd beneficiaryCouponWeights)) + require "Sum of beneficiary weights matches" (svInfo.rewardWeight == sum (map snd beneficiaryCouponWeights)) couponCids <- forA beneficiaryCouponWeights $ \(beneficiary, weight) -> create SvRewardCoupon with @@ -1931,53 +1917,55 @@ template DsoRules with -- option 2: Switchover through a vote that sets beneficiaries for everyone -- option 3: two-step process, first setup sv right owners through votes (probably a batched vote in some form) and then have a second vote to actually start using right owners (needs a new config flag to indicate whether right owners take effect) voteWeight = 1 + forA_ (Map.toList this.svs) $ \(svOperator, info) -> do + create SvRightOwner with + dso + info = svRightOwnerFromOperator svOperator info + rightOwnerName = info.name create this with svs = Map.fromList ([(sv, info with svRewardWeight = 0) | (sv, info) <- Map.toList this.svs]) - svRightOwners = Some (TextMap.fromList [(info.name, svRightOwnerFromOperator svOperator info) | (svOperator, info) <- Map.toList this.svs]) + svRightOwners = Some (TextMap.fromList [(info.name, ()) | (_, info) <- Map.toList this.svs]) - choice DsoRules_UpdateRightOwnerParty : ContractId DsoRules + nonconsuming choice DsoRules_UpdateRightOwnerParty : ContractId SvRightOwner with name : Text + svRightOwnerCid : ContractId SvRightOwner oldRightOwnerParty : Party newRightOwnerParty : Party controller oldRightOwnerParty do requireOnLedgerSvRightOwners this - case TextMap.lookup name (getSvRightOwners this) of - None -> abort ("No sv with name " <> show name) - Some info -> do - require "right owner parties match" (info.rightOwnerParty == oldRightOwnerParty) - create this with - svRightOwners = Some (TextMap.insert name (info with rightOwnerParty = newRightOwnerParty) (getSvRightOwners this)) + svRightOwner <- fetchAndArchive (ForSv with dso; svName = name) svRightOwnerCid + require "right owner parties match" (svRightOwner.info.rightOwnerParty == oldRightOwnerParty) + create svRightOwner with + info.rightOwnerParty = newRightOwnerParty - choice DsoRules_UpdateBeneficiaries : ContractId DsoRules + choice DsoRules_UpdateBeneficiaries : ContractId SvRightOwner with name : Text + svRightOwnerCid : ContractId SvRightOwner rightOwnerParty : Party beneficiaries : [(Party, Decimal)] controller rightOwnerParty do requireOnLedgerSvRightOwners this - case TextMap.lookup name (getSvRightOwners this) of - None -> abort ("No sv with name " <> show name) - Some info -> do - require "right owner parties match" (info.rightOwnerParty == rightOwnerParty) - create this with - svRightOwners = Some (TextMap.insert name (info with beneficiaries = beneficiaries) (getSvRightOwners this)) + svRightOwner <- fetchAndArchive (ForSv with dso; svName = name) svRightOwnerCid + require "right owner parties match" (svRightOwner.info.rightOwnerParty == rightOwnerParty) + create svRightOwner with + info.beneficiaries = beneficiaries - choice DsoRules_UpdateSvRightOwnerInfo : ContractId DsoRules + nonconsuming choice DsoRules_UpdateSvRightOwnerInfo : ContractId SvRightOwner with name : Text + rightOwnercid : ContractId SvRightOwner baseInfo : SvRightOwnerInfo -- ^ The info the vote was created against newInfo : SvRightOwnerInfo -- ^ The target info, only fields that are different from baseInfo will be updated controller dso do requireOnLedgerSvRightOwners this - case TextMap.lookup name (getSvRightOwners this) of - None -> abort ("No SV with name " <> show name) - Some currentInfo -> do - create this with - svRightOwners = Some (TextMap.insert name (patch newInfo baseInfo currentInfo) (getSvRightOwners this)) + rightOwner <- fetchAndArchive (ForSv with dso; svName = name) rightOwnercid + create rightOwner with + info = patch newInfo baseInfo rightOwner.info nonconsuming choice DsoRules_AddSvRightOwner : ContractId AddSvRightOwnerInstruction with @@ -2010,9 +1998,9 @@ template DsoRules with case TextMap.lookup instruction.rightOwnerName (getSvRightOwners this) of Some _ -> abort ("SV with name " <> instruction.rightOwnerName <> " already exists") None -> do - createSvRightOwnerContracts this instruction.rightOwnerName openMiningRound.round + createSvRightOwnerContracts this instruction.rightOwnerName (Some instruction.info) openMiningRound.round create this with - svRightOwners = Some (TextMap.insert instruction.rightOwnerName instruction.info (getSvRightOwners this)) + svRightOwners = Some (TextMap.insert instruction.rightOwnerName () (getSvRightOwners this)) nonconsuming choice DsoRules_RemoveSvRightOwner : ContractId RemoveSvRightOwnerInstruction with @@ -2033,6 +2021,7 @@ template DsoRules with with instructionCid : ContractId RemoveSvRightOwnerInstruction rewardStateCid : ContractId SvRewardState + svRightOwnerCid : ContractId SvRightOwner svOperator : Party controller svOperator do @@ -2045,6 +2034,7 @@ template DsoRules with -- In theory reonboarding an SV immediately could let it mint rewards twice for the same round. -- In practice, reonboarding that quickly seems unrealistic in practice. _ <- fetchAndArchive (ForSv with dso; svName = instruction.rightOwnerName) rewardStateCid + _ <- fetchAndArchive (ForSv with dso; svName = instruction.rightOwnerName) svRightOwnerCid create this with svRightOwners = Some (TextMap.delete instruction.rightOwnerName (getSvRightOwners this)) None -> abort ("No SV with name " <> show instruction.rightOwnerName) @@ -2104,21 +2094,26 @@ pruneAtLeastOne now schedule = where (past, future) = span (\(t, _) -> t <= now) schedule.futureValues -data VoteType = OperatorVote | RightOwnerVote - -summarizeDso : VoteType -> DsoRules -> DsoSummaryV2 -summarizeDso voteType dsoRules = DsoSummaryV2 with +data VoteType = OperatorVote | RightOwnerVote deriving (Show, Eq) + +summarizeDso : VoteType -> TextMap.TextMap (ContractId SvRightOwner) -> DsoRules -> Update DsoSummaryV2 +summarizeDso voteType svRightOwnerCids dsoRules = do + votersWithWeight <- case voteType of + RightOwnerVote -> do + require "set of right owner cids matches the list of right owners" (map fst (TextMap.toList svRightOwnerCids) == map fst (TextMap.toList (getSvRightOwners dsoRules))) + rightOwners <- forA (TextMap.toList svRightOwnerCids) $ \(name, rightOwnerCid) -> do + fetchChecked (ForSv with dso = dsoRules.dso; svName = name) rightOwnerCid + pure [(rightOwner.rightOwnerName, rightOwner.info.voteWeight) | rightOwner <- rightOwners, rightOwner.info.voteWeight > 0] + OperatorVote -> do + require "operator votes should not specify any right owner cids" (TextMap.null svRightOwnerCids) + pure [(info.name, 1) | (_, info) <- Map.toList dsoRules.svs] -- operators have weight 1 + let totalVoteWeight = sum (map snd votersWithWeight) + let f = floor ((intToDecimal (totalVoteWeight - 1)) / 3.0) + pure DsoSummaryV2 with totalVoteWeight requiredVoteWeight = ceiling ((intToDecimal (totalVoteWeight + f + 1)) / 2.0) votersWithWeight = TextMap.fromList votersWithWeight - where - votersWithWeight = case voteType of - RightOwnerVote -> [(name, info.voteWeight) | (name, info) <- TextMap.toList (getSvRightOwners dsoRules), info.voteWeight > 0] - OperatorVote -> [(info.name, 1) | (_, info) <- Map.toList dsoRules.svs] -- operators have weight 1 - totalVoteWeight = sum (map snd votersWithWeight) - - f = floor ((intToDecimal (totalVoteWeight - 1)) / 3.0) -- | Execute an action which requires certain number of confirmations from SVs. -- Each confirmed action can at most be executed once. @@ -2225,11 +2220,6 @@ getSvInfoByOperatorParty operator this = None -> fail ("Not a sv operator: " <> show operator) Some svInfo -> pure (svInfo.name, svInfo) -lookupSvInfoByName : Text -> DsoRules -> Optional SvRightOwnerInfo -lookupSvInfoByName svName this = - TextMap.lookup svName (getSvRightOwners this) - - lookupSvOperatorInfoByName : Text -> DsoRules -> Optional (Party, SvInfo) lookupSvOperatorInfoByName svName DsoRules{..} = find (\info -> info._2.name == svName) $ Map.toList svs @@ -2238,7 +2228,7 @@ lookupSvOperatorInfoByName svName DsoRules{..} = -- or an SV with that name has been onboarded before and is now in offboardedSvs. svHasBeenOnboardedBefore : Text -> DsoRules -> Bool svHasBeenOnboardedBefore svName this = - isSome (lookupSvInfoByName svName this) || any (\info -> info.name == svName) (Map.values this.offboardedSvs) + isSome (lookupSvOperatorInfoByName svName this) || any (\info -> info.name == svName) (Map.values this.offboardedSvs) ensureNeverOperatedNode : Party -> DsoRules -> Update () ensureNeverOperatedNode newSvParty this = do @@ -2272,7 +2262,7 @@ dsoRules_addSv this0 DsoRules_AddSv{..} = do then require "rewardWeight must be 0 when onboarding a new SV operator with on-ledger right owners" (newSvRewardWeight == 0) else unless (svHasBeenOnboardedBefore newSvName this) $ - createSvRightOwnerContracts this newSvName joinedAsOfRound + createSvRightOwnerContracts this newSvName None joinedAsOfRound -- create per SV party contracts let initialAmuletPriceVote = None createSvOperatorContracts dso newSvParty newSvName noSynchronizerNodes initialAmuletPriceVote (getVoteCooldownTime config) @@ -2285,17 +2275,24 @@ dsoRules_addSv this0 DsoRules_AddSv{..} = do create this with svs = Map.insert newSvParty svInfo svs -createSvRightOwnerContracts : DsoRules -> Text -> Round -> Update () -createSvRightOwnerContracts DsoRules{..} newSvName joinedAsOfRound = do +createSvRightOwnerContracts : DsoRules -> Text -> Optional SvRightOwnerInfo -> Round -> Update () +createSvRightOwnerContracts rules@DsoRules{..} newSvName rightOwnerInfo joinedAsOfRound = do void $ create SvRewardState with dso svName = newSvName state = RewardState with lastRoundCollected = Round (joinedAsOfRound.number - 1) numRoundsMissed = 0 - numRoundsCollected = 0 numCouponsIssued = 0 + case rightOwnerInfo of + None -> requireNoOnLedgerSvRightOwners rules + Some info -> do + requireOnLedgerSvRightOwners rules + void $ create SvRightOwner with + dso + rightOwnerName = newSvName + info createSvOperatorContracts : Party -> Party -> Text -> SynchronizerNodeConfigMap -> Optional Decimal -> RelTime -> Update () createSvOperatorContracts dso newSvParty newSvName synchronizerNodes amuletPrice voteCooldownTime = do @@ -2329,18 +2326,30 @@ getAndValidateSvNodeOperatorParty rules (Some sv) = do None -> fail ("SV party " <> show sv <> " is not a registered SV node operator") Some svInfo -> pure svInfo.name -getAndValidateSvRightOwnerParty : DsoRules -> Optional Party -> Update Text -getAndValidateSvRightOwnerParty _ None = fail "no SV right owner party provided" -getAndValidateSvRightOwnerParty rules (Some sv) = do - case find (\(_, info) -> info.rightOwnerParty == sv) (TextMap.toList (getSvRightOwners rules)) of - None -> fail ("SV party " <> show sv <> " is not a right owner party") - Some (name, _) -> pure name - -getAndValidateVotingParty : DsoRules -> Party -> ActionRequiringConfirmation -> Update Text -getAndValidateVotingParty dsoRules party action = +getAndValidateSvRightOwnerParty : Optional (ContractId SvRightOwner) -> DsoRules -> Optional Party -> Update Text +getAndValidateSvRightOwnerParty _ _ None = fail "no SV right owner party provided" +getAndValidateSvRightOwnerParty rightOwnerCid rules (Some sv) = do + if onLedgerSvRightOwners rules + then + case rightOwnerCid of + None -> fail "no SV right owner contract id provided" + Some cid -> do + rightOwner <- fetchChecked (ForDso with dso = rules.dso) cid + require "SV right owner parties match" (rightOwner.info.rightOwnerParty == sv) + pure rightOwner.rightOwnerName + else do + require "Right owner cid is not specified when not using on-ledger right owners" (isNone rightOwnerCid) + case Map.lookup sv rules.svs of + None -> fail ("SV party " <> show sv <> " is not a right owner party") + Some info -> pure info.name + +getAndValidateVotingParty : Optional (ContractId SvRightOwner) -> DsoRules -> Party -> ActionRequiringConfirmation -> Update Text +getAndValidateVotingParty rightOwnerCid dsoRules party action = case voteType action of - RightOwnerVote -> getAndValidateSvRightOwnerParty dsoRules (Some party) - OperatorVote -> getAndValidateSvNodeOperatorParty dsoRules (Some party) + RightOwnerVote -> getAndValidateSvRightOwnerParty rightOwnerCid dsoRules (Some party) + OperatorVote -> do + require "Right owner cid is not specified for operator vote" (isNone rightOwnerCid) + getAndValidateSvNodeOperatorParty dsoRules (Some party) -- Rate limiting ---------------- @@ -2433,7 +2442,3 @@ instance Patchable LogicalSynchronizerUpgradeSchedule where operatorParties : DsoRules -> [Party] operatorParties DsoRules{svs} = Map.keys svs - -rightOwnerParties : DsoRules -> [Party] -rightOwnerParties this = - map (\(_, v) -> v.rightOwnerParty) (TextMap.toList (getSvRightOwners this)) From 375e1d562ea01cff289c61f2b11310906791a39f Mon Sep 17 00:00:00 2001 From: "moritz.kiefer@digitalasset.com" Date: Fri, 31 Jul 2026 11:01:44 +0200 Subject: [PATCH 03/30] Switch from textmap () to [Text] Signed-off-by: moritz.kiefer@digitalasset.com --- .../daml/Splice/Scripts/DsoTestUtils.daml | 4 +- .../Scripts/TestGovernanceRefactor.daml | 11 +++-- .../daml/Splice/DsoBootstrap.daml | 3 +- .../daml/Splice/DsoRules.daml | 41 +++++++++---------- 4 files changed, 28 insertions(+), 31 deletions(-) diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml index dafb1d09ad..2f0f817096 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml @@ -376,7 +376,7 @@ executeAllDefinitiveVotes app = do now <- getTime requests <- query @VoteRequest app.dso forA_ requests $ \(requestCid, request) -> do - let activeSvs = Set.fromList (map fst $ TextMap.toList (getSvRightOwners rules)) + let activeSvs = Set.fromList (getSvRightOwners rules) let execute = request.voteBefore <= now || (activeSvs == Set.fromList (Map.keys request.votes)) rightOwnerCids <- querySvRightOwners app @@ -495,7 +495,7 @@ checkSvRewardStates app = do rewardStates <- query @SvRewardState app.dso [(_, dsoRules)] <- query @DsoRules app.dso if onLedgerSvRightOwners dsoRules then - Set.fromList [state.svName | (_, state) <- rewardStates] === Set.fromList (map fst (TextMap.toList (getSvRightOwners dsoRules))) + Set.fromList [state.svName | (_, state) <- rewardStates] === Set.fromList (getSvRightOwners dsoRules) else Set.fromList [state.svName | (_, state) <- rewardStates] === Set.fromList (map (.name) (Map.values dsoRules.svs)) diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml index 17cdbe67ee..54c78fd559 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml @@ -5,10 +5,9 @@ module Splice.Scripts.TestGovernanceRefactor where import DA.Action import DA.Assert -import DA.Foldable +import DA.Foldable hiding (length) import DA.List (sort) import Daml.Script -import qualified DA.TextMap as TextMap import qualified DA.Map as Map import Splice.DSO.SvRightOwner @@ -35,7 +34,7 @@ testGovernanceRefactor = do beneficiaries = [] executeAddSvRightOwnerInstructions sv1 app [(_, dsoRules)] <- query @DsoRules app.dso - TextMap.size (getSvRightOwners dsoRules) === 5 + length (getSvRightOwners dsoRules) === 5 voteRequest <- initiateAndCastVote app [sv1, sv2, sv3, sv4] None $ ARC_DsoRules $ SRARC_DsoRules_AddSvRightOwner $ DsoRules_AddSvRightOwner nonOperatorName2 SvRightOwnerInfo with rightOwnerParty = rightOwnerParty2 voteWeight = 1 @@ -55,7 +54,7 @@ testGovernanceRefactor = do -- now we have reached the vote weight None <- queryContractId app.dso voteRequest [(_, dsoRules)] <- query @DsoRules app.dso - TextMap.size (getSvRightOwners dsoRules) === 6 + length (getSvRightOwners dsoRules) === 6 pure () testGovernanceRefactorMigration : Script () @@ -66,8 +65,8 @@ testGovernanceRefactorMigration = do submit (actAs sv1 <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_MigrateToOnLedgerSvRightOwners with svOperator = sv1 [(_, dsoRules)] <- query @DsoRules app.dso - sort (map fst $ TextMap.toList $ getSvRightOwners dsoRules) === sort (map (.name) (Map.values dsoRules.svs)) - TextMap.size (getSvRightOwners dsoRules) === 4 + sort (getSvRightOwners dsoRules) === sort (map (.name) (Map.values dsoRules.svs)) + length (getSvRightOwners dsoRules) === 4 pure () diff --git a/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml b/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml index 6f00313f36..f15672579d 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoBootstrap.daml @@ -5,7 +5,6 @@ module Splice.DsoBootstrap where import DA.Functor import qualified DA.Map as Map -import qualified DA.TextMap as TextMap import DA.Time import DA.Optional @@ -79,7 +78,7 @@ template DsoBootstrap with config initialTrafficState isDevNet - svRightOwners = sv1RightOwnerName <&> \name -> TextMap.fromList [(name, ())] + svRightOwners = sv1RightOwnerName <&> \name -> [name] let info = sv1RightOwnerName <&> \rightOwnerName -> SvRightOwnerInfo with rightOwnerParty = sv1Party voteWeight = fromOptional 0 sv1VoteWeight diff --git a/daml/splice-dso-governance/daml/Splice/DsoRules.daml b/daml/splice-dso-governance/daml/Splice/DsoRules.daml index 39b1f1f78c..3a918fd44c 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoRules.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoRules.daml @@ -542,8 +542,8 @@ data TrafficState = TrafficState with consumedTraffic: Int -- ^ Bytes of extra traffic consumed before the decentralized synchronizer was bootstrapped. deriving (Eq, Show) -getSvRightOwners : DsoRules -> TextMap.TextMap () -getSvRightOwners DsoRules{..} = fromOptional TextMap.empty svRightOwners +getSvRightOwners : DsoRules -> [Text] +getSvRightOwners DsoRules{..} = fromOptional [] svRightOwners onLedgerSvRightOwners : DsoRules -> Bool onLedgerSvRightOwners DsoRules{..} = isSome svRightOwners @@ -568,14 +568,13 @@ template DsoRules with config : DsoRulesConfig initialTrafficState: Map.Map Text TrafficState -- ^ Map from participant/mediator ID to its traffic state at the time of synchronizer bootstrapping. Used for testing, empty in prod. isDevNet : Bool - svRightOwners : Optional (TextMap.TextMap ()) -- ^ Set of sv right owner names - -- FIXME: Consider changing to [Text] + svRightOwners : Optional [Text] -- ^ Set of sv right owner names where ensure config.numUnclaimedRewardsThreshold > 0 && -- when using on-ledger right owners they must be non-empty - optional True (\rightOwners -> TextMap.size rightOwners >= 1) svRightOwners && + optional True (\rightOwners -> length rightOwners >= 1 && unique rightOwners) svRightOwners && -- when using on-ledger right owners the weight in the operator info must be 0 (not (onLedgerSvRightOwners this) || all (\info -> info.svRewardWeight == 0) (Map.values svs)) @@ -1924,7 +1923,7 @@ template DsoRules with rightOwnerName = info.name create this with svs = Map.fromList ([(sv, info with svRewardWeight = 0) | (sv, info) <- Map.toList this.svs]) - svRightOwners = Some (TextMap.fromList [(info.name, ()) | (_, info) <- Map.toList this.svs]) + svRightOwners = Some (map (.name) (Map.values this.svs)) nonconsuming choice DsoRules_UpdateRightOwnerParty : ContractId SvRightOwner with @@ -1975,9 +1974,9 @@ template DsoRules with do requireOnLedgerSvRightOwners this now <- getTime - case TextMap.lookup rightOwnerName (getSvRightOwners this) of - Some _ -> abort ("SV with name " <> rightOwnerName <> " already exists") - None -> do + if rightOwnerName `elem` getSvRightOwners this + then abort ("SV with name " <> rightOwnerName <> " already exists") + else create AddSvRightOwnerInstruction with dso rightOwnerName @@ -1995,12 +1994,12 @@ template DsoRules with requireOnLedgerSvRightOwners this instruction <- fetchAndArchive (ForDso dso) instructionCid openMiningRound <- fetchReferenceData (ForDso dso) openMiningRoundCid - case TextMap.lookup instruction.rightOwnerName (getSvRightOwners this) of - Some _ -> abort ("SV with name " <> instruction.rightOwnerName <> " already exists") - None -> do + if instruction.rightOwnerName `elem` getSvRightOwners this + then abort ("SV with name " <> instruction.rightOwnerName <> " already exists") + else do createSvRightOwnerContracts this instruction.rightOwnerName (Some instruction.info) openMiningRound.round create this with - svRightOwners = Some (TextMap.insert instruction.rightOwnerName () (getSvRightOwners this)) + svRightOwners = Some (instruction.rightOwnerName :: getSvRightOwners this) nonconsuming choice DsoRules_RemoveSvRightOwner : ContractId RemoveSvRightOwnerInstruction with @@ -2008,14 +2007,14 @@ template DsoRules with controller dso do requireOnLedgerSvRightOwners this - case TextMap.lookup rightOwnerName (getSvRightOwners this) of - Some _ -> do + if rightOwnerName `elem` getSvRightOwners this + then do now <- getTime create RemoveSvRightOwnerInstruction with dso rightOwnerName expiresAt = now `addRelTime` hours 1 - None -> abort ("No SV with name " <> show rightOwnerName) + else abort ("No SV with name " <> show rightOwnerName) choice DsoRules_ExecuteRemoveSvRightOwnerInstruction : ContractId DsoRules with @@ -2028,15 +2027,15 @@ template DsoRules with _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) requireOnLedgerSvRightOwners this instruction <- fetchAndArchive (ForDso dso) instructionCid - case TextMap.lookup instruction.rightOwnerName (getSvRightOwners this) of - Some _ -> do + if instruction.rightOwnerName `elem` getSvRightOwners this + then do -- We archive the reward state as part of offboarding to avoid having to track offboardedSvs for non-operators. -- In theory reonboarding an SV immediately could let it mint rewards twice for the same round. -- In practice, reonboarding that quickly seems unrealistic in practice. _ <- fetchAndArchive (ForSv with dso; svName = instruction.rightOwnerName) rewardStateCid _ <- fetchAndArchive (ForSv with dso; svName = instruction.rightOwnerName) svRightOwnerCid - create this with svRightOwners = Some (TextMap.delete instruction.rightOwnerName (getSvRightOwners this)) - None -> abort ("No SV with name " <> show instruction.rightOwnerName) + create this with svRightOwners = Some (filter (/= instruction.rightOwnerName) (getSvRightOwners this)) + else abort ("No SV with name " <> show instruction.rightOwnerName) nonconsuming choice DsoRules_ExpireRemoveSvRightOwnerInstruction : () with @@ -2100,7 +2099,7 @@ summarizeDso : VoteType -> TextMap.TextMap (ContractId SvRightOwner) -> DsoRules summarizeDso voteType svRightOwnerCids dsoRules = do votersWithWeight <- case voteType of RightOwnerVote -> do - require "set of right owner cids matches the list of right owners" (map fst (TextMap.toList svRightOwnerCids) == map fst (TextMap.toList (getSvRightOwners dsoRules))) + require "set of right owner cids matches the list of right owners" (sort (map fst (TextMap.toList svRightOwnerCids)) == sort (getSvRightOwners dsoRules)) rightOwners <- forA (TextMap.toList svRightOwnerCids) $ \(name, rightOwnerCid) -> do fetchChecked (ForSv with dso = dsoRules.dso; svName = name) rightOwnerCid pure [(rightOwner.rightOwnerName, rightOwner.info.voteWeight) | rightOwner <- rightOwners, rightOwner.info.voteWeight > 0] From 6a24a1f454d2e28c49657c33602323e0682d9679 Mon Sep 17 00:00:00 2001 From: "moritz.kiefer@digitalasset.com" Date: Fri, 31 Jul 2026 11:06:31 +0200 Subject: [PATCH 04/30] document invariant Signed-off-by: moritz.kiefer@digitalasset.com --- daml/splice-dso-governance/daml/Splice/DsoRules.daml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/daml/splice-dso-governance/daml/Splice/DsoRules.daml b/daml/splice-dso-governance/daml/Splice/DsoRules.daml index 3a918fd44c..9c12bebbe8 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoRules.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoRules.daml @@ -568,7 +568,9 @@ template DsoRules with config : DsoRulesConfig initialTrafficState: Map.Map Text TrafficState -- ^ Map from participant/mediator ID to its traffic state at the time of synchronizer bootstrapping. Used for testing, empty in prod. isDevNet : Bool - svRightOwners : Optional [Text] -- ^ Set of sv right owner names + svRightOwners : Optional [Text] + -- ^ Set of sv right owner names. we maintain the invariant that for each right owner here there is exactly one SvRightOwner contract + -- and the list of SvRightOwner contracts and the list of sv right owners here are kept in sync atomically. where ensure From abdf54a9f6113f4eef6594aeee0ccc6798bdf031 Mon Sep 17 00:00:00 2001 From: "moritz.kiefer@digitalasset.com" Date: Fri, 31 Jul 2026 13:01:38 +0200 Subject: [PATCH 05/30] migrate directly to the target state Signed-off-by: moritz.kiefer@digitalasset.com --- .../daml/Splice/Scripts/DsoTestUtils.daml | 2 +- .../Scripts/TestGovernanceRefactor.daml | 56 +++++++++++++++++-- .../daml/Splice/DsoRules.daml | 30 ++++------ 3 files changed, 62 insertions(+), 26 deletions(-) diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml index 2f0f817096..2f4a88d639 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/DsoTestUtils.daml @@ -376,7 +376,7 @@ executeAllDefinitiveVotes app = do now <- getTime requests <- query @VoteRequest app.dso forA_ requests $ \(requestCid, request) -> do - let activeSvs = Set.fromList (getSvRightOwners rules) + let activeSvs = if onLedgerSvRightOwners rules then Set.fromList (getSvRightOwners rules) else Set.fromList (map (.name) (Map.values rules.svs)) let execute = request.voteBefore <= now || (activeSvs == Set.fromList (Map.keys request.votes)) rightOwnerCids <- querySvRightOwners app diff --git a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml index 54c78fd559..6fab3bd264 100644 --- a/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml +++ b/daml/splice-dso-governance-test/daml/Splice/Scripts/TestGovernanceRefactor.daml @@ -9,6 +9,7 @@ import DA.Foldable hiding (length) import DA.List (sort) import Daml.Script import qualified DA.Map as Map +import qualified DA.TextMap as TextMap import Splice.DSO.SvRightOwner import Splice.Issuance() @@ -59,14 +60,57 @@ testGovernanceRefactor = do testGovernanceRefactorMigration : Script () testGovernanceRefactorMigration = do - (app, _, (sv1, _sv2, _sv3, _sv4)) <- initMainNetNoOnLedgerSvRightOwners - [(dsoRulesCid, dsoRules)] <- query @DsoRules app.dso + (app, _, (sv1, sv2, sv3, sv4)) <- initMainNetNoOnLedgerSvRightOwners + [(_, dsoRules)] <- query @DsoRules app.dso dsoRules.svRightOwners === None - submit (actAs sv1 <> readAs app.dso) $ exerciseCmd dsoRulesCid DsoRules_MigrateToOnLedgerSvRightOwners with - svOperator = sv1 + initiateAndAcceptVote app [sv1, sv2, sv3, sv4] $ ARC_DsoRules $ SRARC_DsoRules_MigrateToOnLedgerSvRightOwners DsoRules_MigrateToOnLedgerSvRightOwners with + rightOwners = TextMap.fromList [ + ( "sv1", + SvRightOwnerInfo with + rightOwnerParty = sv1 + voteWeight = 1 + rewardWeight = 100000 + rewardNodeOperatorName = "sv1" + beneficiaries = [] + ), + ( "sv2", + SvRightOwnerInfo with + rightOwnerParty = sv2 + voteWeight = 1 + rewardWeight = 30000 + rewardNodeOperatorName = "sv2" + beneficiaries = [] + ), + ( "sv3", + SvRightOwnerInfo with + rightOwnerParty = sv3 + voteWeight = 1 + rewardWeight = 30000 + rewardNodeOperatorName = "sv3" + beneficiaries = [] + ), + ( "sv4", + SvRightOwnerInfo with + rightOwnerParty = sv4 + voteWeight = 1 + rewardWeight = 10000 + rewardNodeOperatorName = "sv4" + beneficiaries = [] + ), + -- before the migration sv4 had weight 30_000 with 20_000 of this going to a beneficiary. The beneficiary is now represented as a dedicated right owner. + ( "rightOwnerFormerlyOnSv4", + SvRightOwnerInfo with + rightOwnerParty = sv4 + voteWeight = 1 + rewardWeight = 20000 + rewardNodeOperatorName = "sv4" + beneficiaries = [] + ) + ] + executeAllDefinitiveVotes app [(_, dsoRules)] <- query @DsoRules app.dso - sort (getSvRightOwners dsoRules) === sort (map (.name) (Map.values dsoRules.svs)) - length (getSvRightOwners dsoRules) === 4 + sort (getSvRightOwners dsoRules) === sort ("rightOwnerFormerlyOnSv4" :: map (.name) (Map.values dsoRules.svs)) + length (getSvRightOwners dsoRules) === 5 pure () diff --git a/daml/splice-dso-governance/daml/Splice/DsoRules.daml b/daml/splice-dso-governance/daml/Splice/DsoRules.daml index 9c12bebbe8..779f87303e 100644 --- a/daml/splice-dso-governance/daml/Splice/DsoRules.daml +++ b/daml/splice-dso-governance/daml/Splice/DsoRules.daml @@ -126,6 +126,7 @@ data DsoRules_ActionRequiringConfirmation | SRARC_DsoRules_UpdateSvRightOwnerInfo DsoRules_UpdateSvRightOwnerInfo | SRARC_DsoRules_AddSvRightOwner DsoRules_AddSvRightOwner | SRARC_DsoRules_RemoveSvRightOwner DsoRules_RemoveSvRightOwner + | SRARC_DsoRules_MigrateToOnLedgerSvRightOwners DsoRules_MigrateToOnLedgerSvRightOwners deriving (Eq, Show) data AnsEntryContext_ActionRequiringConfirmation @@ -1902,30 +1903,20 @@ template DsoRules with choice DsoRules_MigrateToOnLedgerSvRightOwners : ContractId DsoRules with - svOperator : Party - controller svOperator + rightOwners : TextMap.TextMap SvRightOwnerInfo + controller dso do - _ <- getAndValidateSvNodeOperatorParty this (Some svOperator) require "svRightOwners is not already on-ledger" (isNone this.svRightOwners) - let svRightOwnerFromOperator svOperator info = SvRightOwnerInfo with - rightOwnerParty = svOperator - rewardNodeOperatorName = info.name - rewardWeight = info.svRewardWeight - beneficiaries = [] - -- ^ FIXME: Consider how we want the migration to work - -- option 1: Set it to empty here and then have automation in the sv app that sets it to the ones locally configured. - -- Then through two votes with same effectivity reduce weight & remove beneficiary + a separate vote to add new sv right owner - -- option 2: Switchover through a vote that sets beneficiaries for everyone - -- option 3: two-step process, first setup sv right owners through votes (probably a batched vote in some form) and then have a second vote to actually start using right owners (needs a new config flag to indicate whether right owners take effect) - voteWeight = 1 - forA_ (Map.toList this.svs) $ \(svOperator, info) -> do + require "Sum of SV weights does not change" + (sum (map (.svRewardWeight) (Map.values this.svs)) == sum [info.rewardWeight | (_, info) <- TextMap.toList rightOwners]) + forA_ (TextMap.toList rightOwners) $ \(rightOwnerName, info) -> do create SvRightOwner with dso - info = svRightOwnerFromOperator svOperator info - rightOwnerName = info.name + info + rightOwnerName create this with svs = Map.fromList ([(sv, info with svRewardWeight = 0) | (sv, info) <- Map.toList this.svs]) - svRightOwners = Some (map (.name) (Map.values this.svs)) + svRightOwners = Some (map fst $ TextMap.toList rightOwners) nonconsuming choice DsoRules_UpdateRightOwnerParty : ContractId SvRightOwner with @@ -2152,6 +2143,7 @@ executeActionRequiringConfirmation dso dsoRulesCid amuletRulesCid act = case act SRARC_DsoRules_UpdateSvRightOwnerInfo choiceArg -> void $ exercise dsoRulesCid choiceArg SRARC_DsoRules_AddSvRightOwner choiceArg -> void $ exercise dsoRulesCid choiceArg SRARC_DsoRules_RemoveSvRightOwner choiceArg -> void $ exercise dsoRulesCid choiceArg + SRARC_DsoRules_MigrateToOnLedgerSvRightOwners choiceArg -> void $ exercise dsoRulesCid choiceArg ARC_AnsEntryContext with .. -> do void $ fetchChecked (ForDso with dso) ansEntryContextCid case ansEntryContextAction of @@ -2330,7 +2322,7 @@ getAndValidateSvNodeOperatorParty rules (Some sv) = do getAndValidateSvRightOwnerParty : Optional (ContractId SvRightOwner) -> DsoRules -> Optional Party -> Update Text getAndValidateSvRightOwnerParty _ _ None = fail "no SV right owner party provided" getAndValidateSvRightOwnerParty rightOwnerCid rules (Some sv) = do - if onLedgerSvRightOwners rules + if onLedgerSvRightOwners rules then case rightOwnerCid of None -> fail "no SV right owner contract id provided" From 3d987ca13168b1cdc58df44788f54c98677ac89c Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Tue, 14 Jul 2026 11:15:01 -0400 Subject: [PATCH 06/30] WIP of user-of-allocations code --- .../daml/Splice/AggregateLock.daml | 187 ++++++++++++++++++ 1 file changed, 187 insertions(+) create mode 100644 daml/splice-amulet/daml/Splice/AggregateLock.daml diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml new file mode 100644 index 0000000000..5ed0ef4eb7 --- /dev/null +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -0,0 +1,187 @@ +module Splice.AggregateLock where + +import Splice.Api.Token.AllocationV2 as V2 +import Splice.Api.Token.HoldingV2 (Account) +import Splice.Api.Token.MetadataV1 +import DA.TextMap as TM +import DA.Map as M + + +isValidAggregateLockedAllocation : Party -> V2.Allocation -> Bool +isValidAggregateLockedAllocation dso alloc = + True +-- alloc.allocation.admin = dso +-- && alloc.allocation. + +baseLockedMetadata = emptyMetadata +baseVestingMetadata = emptyMetadata + +type ControllerSets = [[Party]] + +controllerSetFromMeta : Text -> ControllerSets +controllerSetFromMeta = map partiesFromText . splitOn ";" + +data AggregateLocked = AggregateLocked with + unlockControllerSets : ControllerSets + substituteControllerSets : ControllerSets + +aggLockedAmuletFromMeta : Metadata -> Account -> AggregateLocked +aggLockedAmuletFromMeta meta acctParty = AggregateLocked with + unlockControllerSets = controllerSetFromMetaMap "cip-105/unlockControllerSets" + substituteControllerSets = controllerSetFromMetaMap "cip-105/substituteControllerSets" + where + controllerSetFromMetaMap key = controllerSetFromMeta $ fromOptional acctParty $ meta.values `TM.lookup` key + + +template AggregateLock + with + dso: Party + instrumentId : Text + allowImmediateUnlock : Bool + where + signatory dso + nonconsuming choice AggregateLock_Unlock : SettlementFactory_SettleBatchResult + with + factoryCid : ContractId SettlementFactory + lockedCid : ContractId Allocation + withdrawToCid : ContractId Allocation + authorizers : [ Party ] + amount : Decimal + where + controller authorizers + do + locked <- fetch lockedCid + withdrawTo <- fetch withdrawToCid + let ownerParty = fromSomeNote "Account must be basic" $ locked.allocation.authorizer.owner + let aggLockedAmulet = aggLockedAmuletFromMeta locked.meta ownerParty + require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets + require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer + if not allowImmediateUnlocks then require "Unlock without vesting is only allowed when specifically enabled" else pure () + require "Must be a valid goverance-locked allocation" $ isValidGovernanceLocked locked + require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid + let + info = SettlementInfo with + executors = [ dso ] + id = "AggregateLock" + sid = self + transferLegId = "unlock" + + exercise factoryCid $ SettlementFactory_SettleBatch with + info + transferLegs = + [ TransferLeg with + transferLegId + sender = locked.authorizer + receiver = withdrawTo.authorizer + amount + instrumentId + meta = emptyMetadata + ] + allocations = + [ FinalizedAllocation with + allocationCid = locked + extraTransferLegSides = + [ TransferLegSide with + transferLegId + side = SenderSide + otherside = authorizer + amount + instrumentId + meta = baseLockedMetadata + ] + nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount + , FinalizedAllocation with + allocationCid = locked + extraTransferLegSides = + [ TransferLegSide with + transferLegId + side = SenderSide + otherside = authorizer + amount + instrumentId + meta = baseLockedMetadata + ] + nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount + ] + + nonconsuming choice AggregateLock_substitute : SettlementFactory_SettleBatchResult -- AggregateLock_SubstituteResult + with + factoryCid : ContractId SettlementFactory + unlockingCid : ContractId Allocation + fundsToLock : ContractId Allocation + lockingCid : ContractId Allocation + authorizers : [ Party ] + amount : Decimal + where + controller authorizers + do + unlocking <- fetch lockedCid + locking <- fetch withdrawToCid + let ownerParty = fromSomeNote "Account must be basic" $ locked.allocation.authorizer.owner + let aggLockedAmulet = aggLockedAmuletFromMeta locked.meta ownerParty + require "Substitute controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) substituteControllerSets + require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer + if not allowImmediateUnlocks then require "Unlock without vesting is only allowed when specifically enabled" else pure () + require "Must be a valid goverance-locked allocation" $ isValidGovernanceLocked locked + require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid + let + info = SettlementInfo with + executors = [ dso ] + id = "AggregateLock" + sid = self + transferLegId = "unlock" + + exercise factoryCid AllocationFactory_SettleBatch with + info + transferLegs = + [ TransferLeg with + transferLegId + sender = locked.authorizer + receiver = locked.authorizer + amount + instrumentId + meta = emptyMetadata + , TransferLeg with + transferLegId + sender = locked.authorizer + receiver = locked.authorizer + amount + instrumentId + meta = emptyMetadata + ] + allocations = + [ FinalizedAllocation with + allocationCid = locked + extraTransferLegSides = + [ TransferLegSide with + transferLegId + side = SenderSide + otherside = authorizer + amount + instrumentId + meta = baseLockedMetadata + ] + nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount + , FinalizedAllocation with + allocationCid = locked + extraTransferLegSides = + [ TransferLegSide with + transferLegId + side = SenderSide + otherside = authorizer + amount + instrumentId + meta = baseLockedMetadata + ] + nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount + ] + + {- data AggregateLock_UnlockResult + = AggregateLock_UnlockResult_Vesting with + vesting : ContractId VestedAmulet + locked : ContractId AggregateLockedAmulet + | AggregateLock_UnlockResult_Immediate with + unlocked : ContractId Amulet + locked : ContractId AggregateLockedAmulet + deriving (Show) +-} From fe04641fa6bdbd5ea24d629d09dc0378c74da1fc Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Tue, 14 Jul 2026 19:25:44 +0000 Subject: [PATCH 07/30] WIP: Potentially fix some errors/imports --- .../daml/Splice/AggregateLock.daml | 62 ++++++++++++------- 1 file changed, 39 insertions(+), 23 deletions(-) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 5ed0ef4eb7..2abc8c2e84 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -3,8 +3,12 @@ module Splice.AggregateLock where import Splice.Api.Token.AllocationV2 as V2 import Splice.Api.Token.HoldingV2 (Account) import Splice.Api.Token.MetadataV1 -import DA.TextMap as TM +import Splice.Util + import DA.Map as M +import DA.Optional +import DA.Text +import DA.TextMap as TM isValidAggregateLockedAllocation : Party -> V2.Allocation -> Bool @@ -19,7 +23,7 @@ baseVestingMetadata = emptyMetadata type ControllerSets = [[Party]] controllerSetFromMeta : Text -> ControllerSets -controllerSetFromMeta = map partiesFromText . splitOn ";" +controllerSetFromMeta = map partyFromText . splitOn ";" data AggregateLocked = AggregateLocked with unlockControllerSets : ControllerSets @@ -56,18 +60,22 @@ template AggregateLock let aggLockedAmulet = aggLockedAmuletFromMeta locked.meta ownerParty require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer - if not allowImmediateUnlocks then require "Unlock without vesting is only allowed when specifically enabled" else pure () + if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" else pure () + -- TODO: What is isValidGovernanceLocked? require "Must be a valid goverance-locked allocation" $ isValidGovernanceLocked locked require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid let info = SettlementInfo with executors = [ dso ] - id = "AggregateLock" - sid = self + id = "AggregateLock_Unlock" + cid = Some self + meta = emptyMetadata transferLegId = "unlock" exercise factoryCid $ SettlementFactory_SettleBatch with - info + settlement = info + actors = [ dso ] + extraArgs = ExtraArgs emptyChoiceContext emptyMetadata transferLegs = [ TransferLeg with transferLegId @@ -89,6 +97,7 @@ template AggregateLock instrumentId meta = baseLockedMetadata ] + -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount , FinalizedAllocation with allocationCid = locked @@ -101,10 +110,11 @@ template AggregateLock instrumentId meta = baseLockedMetadata ] + -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount ] - nonconsuming choice AggregateLock_substitute : SettlementFactory_SettleBatchResult -- AggregateLock_SubstituteResult + nonconsuming choice AggregateLock_Substitute : SettlementFactory_SettleBatchResult -- AggregateLock_SubstituteResult with factoryCid : ContractId SettlementFactory unlockingCid : ContractId Allocation @@ -117,41 +127,45 @@ template AggregateLock do unlocking <- fetch lockedCid locking <- fetch withdrawToCid - let ownerParty = fromSomeNote "Account must be basic" $ locked.allocation.authorizer.owner - let aggLockedAmulet = aggLockedAmuletFromMeta locked.meta ownerParty + let ownerParty = fromSomeNote "Account must be basic" $ unlocking.allocation.authorizer.owner + let aggLockedAmulet = aggLockedAmuletFromMeta unlocking.meta ownerParty require "Substitute controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) substituteControllerSets - require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer - if not allowImmediateUnlocks then require "Unlock without vesting is only allowed when specifically enabled" else pure () - require "Must be a valid goverance-locked allocation" $ isValidGovernanceLocked locked + require "Not allowed to unlock to a different party than locked the funds" $ unlocking.allocation.authorizer == withdrawTo.allocation.authorizer + if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" else pure () + -- TODO: What is isValidGovernanceLocked? + require "Must be a valid goverance-locked allocation" $ isValidGovernanceLocked unlocking require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid let info = SettlementInfo with executors = [ dso ] - id = "AggregateLock" - sid = self - transferLegId = "unlock" + id = "AggregateLock_substitute" + cid = Some self + meta = emptyMetadata + transferLegId = "substitute" - exercise factoryCid AllocationFactory_SettleBatch with - info + exercise factoryCid SettlementFactory_SettleBatch with + settlement = info + actors = [dso] + extraArgs = ExtraArgs emptyChoiceContext emptyMetadata transferLegs = [ TransferLeg with transferLegId - sender = locked.authorizer - receiver = locked.authorizer + sender = unlocking.authorizer + receiver = unlocking.authorizer amount instrumentId meta = emptyMetadata , TransferLeg with transferLegId - sender = locked.authorizer - receiver = locked.authorizer + sender = unlocking.authorizer + receiver = unlocking.authorizer amount instrumentId meta = emptyMetadata ] allocations = [ FinalizedAllocation with - allocationCid = locked + allocationCid = unlocking extraTransferLegSides = [ TransferLegSide with transferLegId @@ -161,9 +175,10 @@ template AggregateLock instrumentId meta = baseLockedMetadata ] + -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount , FinalizedAllocation with - allocationCid = locked + allocationCid = unlocking extraTransferLegSides = [ TransferLegSide with transferLegId @@ -173,6 +188,7 @@ template AggregateLock instrumentId meta = baseLockedMetadata ] + -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount ] From 0082c4cd5b820624eab19e14a617d9d974c4ddeb Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Tue, 14 Jul 2026 20:53:37 +0000 Subject: [PATCH 08/30] WIP correct some more fields and functions --- .../daml/Splice/AggregateLock.daml | 37 +++++++++++-------- 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 2abc8c2e84..85fa67daa4 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -5,20 +5,29 @@ import Splice.Api.Token.HoldingV2 (Account) import Splice.Api.Token.MetadataV1 import Splice.Util -import DA.Map as M +import qualified DA.Map as M import DA.Optional import DA.Text -import DA.TextMap as TM +import qualified DA.TextMap as TM isValidAggregateLockedAllocation : Party -> V2.Allocation -> Bool isValidAggregateLockedAllocation dso alloc = - True --- alloc.allocation.admin = dso --- && alloc.allocation. + and [ alloc.allocation.admin == dso + , alloc.allocation.committed + , null alloc.allocation.transferLegSides + , TM.lookup alloc.allocation.meta.values "cip-105/type" == Some "aggregateLock" + , alloc.allocation.expiresAt == Some maxBound + ] -baseLockedMetadata = emptyMetadata -baseVestingMetadata = emptyMetadata +isValidVestingLockedDestination : Party -> V2.Allocation -> Bool +isValidVestingLockedDestination dso alloc = + and [ alloc.allocation.admin == dso + , alloc.allocation.committed + , null alloc.allocation.transferLegSides + , TM.lookup alloc.allocation.meta.values "cip-105/type" == Some "aggregateLock" + , alloc.allocation.expiresAt == Some maxBound + ] type ControllerSets = [[Party]] @@ -61,8 +70,7 @@ template AggregateLock require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" else pure () - -- TODO: What is isValidGovernanceLocked? - require "Must be a valid goverance-locked allocation" $ isValidGovernanceLocked locked + require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation locked require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid let info = SettlementInfo with @@ -95,7 +103,7 @@ template AggregateLock otherside = authorizer amount instrumentId - meta = baseLockedMetadata + meta = emptyMetadata ] -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount @@ -108,7 +116,7 @@ template AggregateLock otherside = authorizer amount instrumentId - meta = baseLockedMetadata + meta = emptyMetadata ] -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount @@ -132,8 +140,7 @@ template AggregateLock require "Substitute controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) substituteControllerSets require "Not allowed to unlock to a different party than locked the funds" $ unlocking.allocation.authorizer == withdrawTo.allocation.authorizer if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" else pure () - -- TODO: What is isValidGovernanceLocked? - require "Must be a valid goverance-locked allocation" $ isValidGovernanceLocked unlocking + require "Must be a valid goverance-locked allocation" $ isValidAggregateLockedAllocation unlocking require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid let info = SettlementInfo with @@ -173,7 +180,7 @@ template AggregateLock otherside = authorizer amount instrumentId - meta = baseLockedMetadata + meta = emptyMetadata ] -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount @@ -186,7 +193,7 @@ template AggregateLock otherside = authorizer amount instrumentId - meta = baseLockedMetadata + meta = emptyMetadata ] -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount From a6c3aaa85d079ac070a0c1379cfa0bf27c8e05eb Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Tue, 14 Jul 2026 21:26:12 +0000 Subject: [PATCH 09/30] WIP fixing type errors in AggregageLock.daml --- .../daml/Splice/AggregateLock.daml | 32 +++++++++++-------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 85fa67daa4..8305d5c371 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -16,7 +16,7 @@ isValidAggregateLockedAllocation dso alloc = and [ alloc.allocation.admin == dso , alloc.allocation.committed , null alloc.allocation.transferLegSides - , TM.lookup alloc.allocation.meta.values "cip-105/type" == Some "aggregateLock" + , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "aggregateLock" , alloc.allocation.expiresAt == Some maxBound ] @@ -25,14 +25,17 @@ isValidVestingLockedDestination dso alloc = and [ alloc.allocation.admin == dso , alloc.allocation.committed , null alloc.allocation.transferLegSides - , TM.lookup alloc.allocation.meta.values "cip-105/type" == Some "aggregateLock" + , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "aggregateLock" , alloc.allocation.expiresAt == Some maxBound ] type ControllerSets = [[Party]] -controllerSetFromMeta : Text -> ControllerSets -controllerSetFromMeta = map partyFromText . splitOn ";" +partiesFromText : Text -> Optional [Party] +partiesFromText = mapA partyFromText . splitOn "," + +controllerSetFromMeta : Text -> Optional ControllerSets +controllerSetFromMeta = mapA partiesFromText . splitOn ";" data AggregateLocked = AggregateLocked with unlockControllerSets : ControllerSets @@ -72,6 +75,7 @@ template AggregateLock if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" else pure () require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation locked require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid + require "Must have amounts reserved within the next settlement iteration" $ isSome locked.allocation.nextIterationFunding let info = SettlementInfo with executors = [ dso ] @@ -80,6 +84,10 @@ template AggregateLock meta = emptyMetadata transferLegId = "unlock" + newLockedAmount <- case locked.allocation.nextIterationFunding of + Some a -> pure $ a - amount + None -> require "Must have amounts reserved within the next settlement iteration" False + exercise factoryCid $ SettlementFactory_SettleBatch with settlement = info actors = [ dso ] @@ -95,7 +103,7 @@ template AggregateLock ] allocations = [ FinalizedAllocation with - allocationCid = locked + allocationCid = lockedCid extraTransferLegSides = [ TransferLegSide with transferLegId @@ -105,10 +113,9 @@ template AggregateLock instrumentId meta = emptyMetadata ] - -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount , FinalizedAllocation with - allocationCid = locked + allocationCid = withdrawToCid extraTransferLegSides = [ TransferLegSide with transferLegId @@ -118,10 +125,9 @@ template AggregateLock instrumentId meta = emptyMetadata ] - -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount ] - +{- nonconsuming choice AggregateLock_Substitute : SettlementFactory_SettleBatchResult -- AggregateLock_SubstituteResult with factoryCid : ContractId SettlementFactory @@ -134,7 +140,7 @@ template AggregateLock controller authorizers do unlocking <- fetch lockedCid - locking <- fetch withdrawToCid + withdrawTo <- fetch withdrawToCid let ownerParty = fromSomeNote "Account must be basic" $ unlocking.allocation.authorizer.owner let aggLockedAmulet = aggLockedAmuletFromMeta unlocking.meta ownerParty require "Substitute controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) substituteControllerSets @@ -172,7 +178,7 @@ template AggregateLock ] allocations = [ FinalizedAllocation with - allocationCid = unlocking + allocationCid = unlockingCid extraTransferLegSides = [ TransferLegSide with transferLegId @@ -185,7 +191,7 @@ template AggregateLock -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount , FinalizedAllocation with - allocationCid = unlocking + allocationCid = unlockingCid extraTransferLegSides = [ TransferLegSide with transferLegId @@ -198,7 +204,7 @@ template AggregateLock -- TODO: what's newLockedAmount nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount ] - +-} {- data AggregateLock_UnlockResult = AggregateLock_UnlockResult_Vesting with vesting : ContractId VestedAmulet From c600db864a25ee3d00b39138ff766b10ed3bfead Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Wed, 15 Jul 2026 00:38:28 +0000 Subject: [PATCH 10/30] WIP: externally-defined governance lock implementation using V2 allocations. --- .../daml/Splice/AggregateLock.daml | 147 ++++-------------- 1 file changed, 33 insertions(+), 114 deletions(-) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 8305d5c371..292f85372a 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -1,32 +1,30 @@ module Splice.AggregateLock where import Splice.Api.Token.AllocationV2 as V2 -import Splice.Api.Token.HoldingV2 (Account) import Splice.Api.Token.MetadataV1 import Splice.Util -import qualified DA.Map as M import DA.Optional import DA.Text import qualified DA.TextMap as TM -isValidAggregateLockedAllocation : Party -> V2.Allocation -> Bool +isValidAggregateLockedAllocation : Party -> V2.AllocationView -> Bool isValidAggregateLockedAllocation dso alloc = and [ alloc.allocation.admin == dso , alloc.allocation.committed , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "aggregateLock" - , alloc.allocation.expiresAt == Some maxBound + , alloc.expiresAt == Some maxBound ] -isValidVestingLockedDestination : Party -> V2.Allocation -> Bool +isValidVestingLockedDestination : Party -> V2.AllocationView -> Bool isValidVestingLockedDestination dso alloc = and [ alloc.allocation.admin == dso , alloc.allocation.committed , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "aggregateLock" - , alloc.allocation.expiresAt == Some maxBound + , alloc.expiresAt == Some maxBound ] type ControllerSets = [[Party]] @@ -37,18 +35,25 @@ partiesFromText = mapA partyFromText . splitOn "," controllerSetFromMeta : Text -> Optional ControllerSets controllerSetFromMeta = mapA partiesFromText . splitOn ";" -data AggregateLocked = AggregateLocked with +data GovernanceLockedControllers = GovernanceLockedControllers with unlockControllerSets : ControllerSets substituteControllerSets : ControllerSets -aggLockedAmuletFromMeta : Metadata -> Account -> AggregateLocked -aggLockedAmuletFromMeta meta acctParty = AggregateLocked with +governanceLockedControllersFromMeta : Metadata -> Party -> GovernanceLockedControllers +governanceLockedControllersFromMeta meta acctParty = GovernanceLockedControllers with unlockControllerSets = controllerSetFromMetaMap "cip-105/unlockControllerSets" substituteControllerSets = controllerSetFromMetaMap "cip-105/substituteControllerSets" where - controllerSetFromMetaMap key = controllerSetFromMeta $ fromOptional acctParty $ meta.values `TM.lookup` key + controllerSetFromMetaMap key = fromOptional [[acctParty]] $ controllerSetFromMeta =<< key `TM.lookup` meta.values +-- | The intention is to treat the overall aggregate lock for a SV as if it is +-- "the settlement" for the allocations locked to it, and use iterated +-- settlement to execute updates on the committed allocations as needed. +-- This approach would permit most of the specific governance locking and +-- vesting to be in a separate dar from amulet only needed for SVs and +-- interested observers. + template AggregateLock with dso: Party @@ -66,27 +71,28 @@ template AggregateLock where controller authorizers do - locked <- fetch lockedCid - withdrawTo <- fetch withdrawToCid - let ownerParty = fromSomeNote "Account must be basic" $ locked.allocation.authorizer.owner - let aggLockedAmulet = aggLockedAmuletFromMeta locked.meta ownerParty + locked <- view <$> fetch lockedCid + withdrawTo <- view <$> fetch withdrawToCid + ownerParty <- whenNone locked.allocation.authorizer.owner $ + assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" + let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta locked.meta ownerParty require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer - if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" else pure () - require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation locked - require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid + if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" False else pure () + require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation dso locked + require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination dso withdrawTo require "Must have amounts reserved within the next settlement iteration" $ isSome locked.allocation.nextIterationFunding let info = SettlementInfo with executors = [ dso ] id = "AggregateLock_Unlock" - cid = Some self + cid = Some $ coerceContractId self meta = emptyMetadata transferLegId = "unlock" - newLockedAmount <- case locked.allocation.nextIterationFunding of - Some a -> pure $ a - amount - None -> require "Must have amounts reserved within the next settlement iteration" False + currentLockedAmount <- whenNone (locked.allocation.nextIterationFunding >>= TM.lookup instrumentId) $ + assertFail "The requirement 'Must have amounts reserved within the next settlement iteration' was not met" + let newLockedAmount = currentLockedAmount - amount exercise factoryCid $ SettlementFactory_SettleBatch with settlement = info @@ -95,8 +101,8 @@ template AggregateLock transferLegs = [ TransferLeg with transferLegId - sender = locked.authorizer - receiver = withdrawTo.authorizer + sender = locked.allocation.authorizer + receiver = withdrawTo.allocation.authorizer amount instrumentId meta = emptyMetadata @@ -108,109 +114,22 @@ template AggregateLock [ TransferLegSide with transferLegId side = SenderSide - otherside = authorizer + otherside = withdrawTo.allocation.authorizer amount instrumentId meta = emptyMetadata ] - nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount + nextIterationFunding = Some $ TM.singleton instrumentId newLockedAmount , FinalizedAllocation with allocationCid = withdrawToCid extraTransferLegSides = [ TransferLegSide with transferLegId side = SenderSide - otherside = authorizer - amount - instrumentId - meta = emptyMetadata - ] - nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount - ] -{- - nonconsuming choice AggregateLock_Substitute : SettlementFactory_SettleBatchResult -- AggregateLock_SubstituteResult - with - factoryCid : ContractId SettlementFactory - unlockingCid : ContractId Allocation - fundsToLock : ContractId Allocation - lockingCid : ContractId Allocation - authorizers : [ Party ] - amount : Decimal - where - controller authorizers - do - unlocking <- fetch lockedCid - withdrawTo <- fetch withdrawToCid - let ownerParty = fromSomeNote "Account must be basic" $ unlocking.allocation.authorizer.owner - let aggLockedAmulet = aggLockedAmuletFromMeta unlocking.meta ownerParty - require "Substitute controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) substituteControllerSets - require "Not allowed to unlock to a different party than locked the funds" $ unlocking.allocation.authorizer == withdrawTo.allocation.authorizer - if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" else pure () - require "Must be a valid goverance-locked allocation" $ isValidAggregateLockedAllocation unlocking - require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination withdrawToCid - let - info = SettlementInfo with - executors = [ dso ] - id = "AggregateLock_substitute" - cid = Some self - meta = emptyMetadata - transferLegId = "substitute" - - exercise factoryCid SettlementFactory_SettleBatch with - settlement = info - actors = [dso] - extraArgs = ExtraArgs emptyChoiceContext emptyMetadata - transferLegs = - [ TransferLeg with - transferLegId - sender = unlocking.authorizer - receiver = unlocking.authorizer - amount - instrumentId - meta = emptyMetadata - , TransferLeg with - transferLegId - sender = unlocking.authorizer - receiver = unlocking.authorizer - amount - instrumentId - meta = emptyMetadata - ] - allocations = - [ FinalizedAllocation with - allocationCid = unlockingCid - extraTransferLegSides = - [ TransferLegSide with - transferLegId - side = SenderSide - otherside = authorizer - amount - instrumentId - meta = emptyMetadata - ] - -- TODO: what's newLockedAmount - nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount - , FinalizedAllocation with - allocationCid = unlockingCid - extraTransferLegSides = - [ TransferLegSide with - transferLegId - side = SenderSide - otherside = authorizer + otherside = locked.allocation.authorizer amount instrumentId meta = emptyMetadata ] - -- TODO: what's newLockedAmount - nextIterationFunding = Some $ M.singleton instrumentId newLockedAmount + nextIterationFunding = Some $ TM.singleton instrumentId newLockedAmount ] --} - {- data AggregateLock_UnlockResult - = AggregateLock_UnlockResult_Vesting with - vesting : ContractId VestedAmulet - locked : ContractId AggregateLockedAmulet - | AggregateLock_UnlockResult_Immediate with - unlocked : ContractId Amulet - locked : ContractId AggregateLockedAmulet - deriving (Show) --} From 283b869979f3d5b35d4c2b3fe02b417b095bbaea Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Mon, 20 Jul 2026 14:34:19 +0000 Subject: [PATCH 11/30] WIP: Test for lock-to-aggregate and unlock, and bug fixes. --- .../Splice/Scripts/TestAggregateLocks.daml | 109 ++++++++++++++++++ .../daml/Splice/AggregateLock.daml | 24 ++-- .../daml/Splice/AmuletAllocationV2.daml | 2 + 3 files changed, 128 insertions(+), 7 deletions(-) create mode 100644 daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml new file mode 100644 index 0000000000..090f340218 --- /dev/null +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -0,0 +1,109 @@ +{-# LANGUAGE ApplicativeDo #-} +module Splice.Scripts.TestAggregateLocks where + +import DA.Time +import Daml.Script +import Splice.Amulet +import Splice.AggregateLock +import Splice.AmuletRules +import Splice.Expiry +import Splice.Scripts.Util +import Splice.TokenStandard.Utils qualified as TSU +import Splice.Api.Token.AllocationV2 qualified as V2 +import Splice.Testing.TokenStandard.RegistryApiV2 +import Splice.Testing.TokenStandard.WalletClientV2 qualified as WalletClientV2 +import Splice.Testing.Registries.AmuletRegistryV2 +import Splice.Api.Token.MetadataV1 +import Splice.Api.Token.AllocationV2 +import Splice.Api.Token.AllocationInstructionV2 +import Splice.AmuletAllocationV2 +import Splice.Testing.Utils + +import Splice.ExternalPartyAmuletRules + +import DA.Assert +import DA.Optional +import DA.Functor +import DA.Foldable (mapA_, sequence_) +import qualified DA.TextMap as TM + +import Splice.Scripts.TokenStandard.TestAmuletTokenStandardTestEnv +import Splice.Testing.Registries.AmuletRegistryV2 qualified as AmuletRegistryV2 + + +lockForGovernance : TestEnv -> TM.TextMap Decimal -> Metadata -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult +lockForGovernance (TestEnv {..}) amounts meta party aggCid = do + WalletClientV2.allocateV2 registries bob lockSettlementInfo lockAllocation + where + lockSettlementInfo = V2.SettlementInfo with + executors = [ instrId.admin ] + id = "AggregateLock" + cid = Some $ coerceContractId aggCid + meta = emptyMetadata + lockAllocation = V2.AllocationSpecification with + admin = instrId.admin + authorizer = TSU.basicAccount bob + transferLegSides = [] + committed = True + nextIterationFunding = Some $ amounts -- TM.fromList [(instrId.id, amount)] + settlementDeadline = Some maxBound + meta + +lockForAggregate : TestEnv -> Decimal -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult +lockForAggregate te amount = lockForGovernance te (TM.fromList [(te.instrId.id, amount)]) $ Metadata $ TM.fromList + [ ("cip-105/type", "aggregateLock") ] + +lockForVesting : TestEnv -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult +lockForVesting te = lockForGovernance te TM.empty $ Metadata $ TM.fromList + [ ("cip-105/type", "vestingLock") + , ("cip-105/vestingPeriod", "365") ] + +testAggregateLockHappyPath : Script () +testAggregateLockHappyPath = do + env@TestEnv{..} <- setupTest + now <- getTime + let dso = env.instrId.admin + + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 + + aggLock <- submit (actAs [alice, dso]) $ createCmd AggregateLock with + dso + instrumentId = env.instrId.id + vestingSchedule = VestingSchedule_SV + Some aggLockDisclosure <- queryDisclosure dso aggLock + + -- Lock some funds for the aggregate + AllocationInstructionResult { output = AllocationInstructionResult_Completed locked } <- lockForAggregate env 1000.0 bob aggLock + + -- Check total for the aggregate; needs to be implemented. + + AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting env bob aggLock + + -- use getSettlementFactory to get the extraArgs and disclosures to call AggregateLock_Unlock + enriched <- getSettlementFactory registriesEnv.amuletV2 $ SettlementFactory_SettleBatch with + settlement = SettlementInfo with + executors = [ dso ] + id = "AggregateLock" + cid = None + meta = emptyMetadata + actors = [ dso ] + extraArgs = emptyExtraArgs + transferLegs = [] + allocations = [] + + submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ AggregateLock_Unlock with + factoryCid = enriched.factoryCid + lockedCid = locked + withdrawToCid = vestingInput + authorizers = [ bob ] + amount = 100.0 + extraArgs = enriched.arg.extraArgs + + allocations <- query @AmuletAllocationV2 bob + + debug allocations + + assert $ length allocations == 2 + + -- Need to check other than via inspection that the two allocations actually exist with correct values. + diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 292f85372a..a3dec7a4f2 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -23,7 +23,7 @@ isValidVestingLockedDestination dso alloc = and [ alloc.allocation.admin == dso , alloc.allocation.committed , null alloc.allocation.transferLegSides - , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "aggregateLock" + , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "vestingLock" , alloc.expiresAt == Some maxBound ] @@ -46,6 +46,15 @@ governanceLockedControllersFromMeta meta acctParty = GovernanceLockedControllers where controllerSetFromMetaMap key = fromOptional [[acctParty]] $ controllerSetFromMeta =<< key `TM.lookup` meta.values +data VestingSchedule + = VestingSchedule_SV + | VestingSchedule_Immediate + deriving (Show, Eq, Ord) + +validateVestingSchedule : VestingSchedule -> Metadata -> Bool +validateVestingSchedule VestingSchedule_SV meta = + TM.lookup "cip-105/vestingPeriod" meta.values == Some "365" -- Placeholder check, depends on vesting impl. +validateVestingSchedule VestingSchedule_Immediate _ = True -- | The intention is to treat the overall aggregate lock for a SV as if it is -- "the settlement" for the allocations locked to it, and use iterated @@ -58,7 +67,7 @@ template AggregateLock with dso: Party instrumentId : Text - allowImmediateUnlock : Bool + vestingSchedule : VestingSchedule where signatory dso nonconsuming choice AggregateLock_Unlock : SettlementFactory_SettleBatchResult @@ -68,6 +77,7 @@ template AggregateLock withdrawToCid : ContractId Allocation authorizers : [ Party ] amount : Decimal + extraArgs : ExtraArgs where controller authorizers do @@ -78,14 +88,14 @@ template AggregateLock let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta locked.meta ownerParty require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer - if not allowImmediateUnlock then require "Unlock without vesting is only allowed when specifically enabled" False else pure () require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation dso locked require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination dso withdrawTo require "Must have amounts reserved within the next settlement iteration" $ isSome locked.allocation.nextIterationFunding + require "Vesting allocation must have a correct schedule configuration" $ validateVestingSchedule vestingSchedule withdrawTo.allocation.meta let info = SettlementInfo with executors = [ dso ] - id = "AggregateLock_Unlock" + id = "AggregateLock" cid = Some $ coerceContractId self meta = emptyMetadata transferLegId = "unlock" @@ -97,7 +107,7 @@ template AggregateLock exercise factoryCid $ SettlementFactory_SettleBatch with settlement = info actors = [ dso ] - extraArgs = ExtraArgs emptyChoiceContext emptyMetadata + extraArgs transferLegs = [ TransferLeg with transferLegId @@ -125,11 +135,11 @@ template AggregateLock extraTransferLegSides = [ TransferLegSide with transferLegId - side = SenderSide + side = ReceiverSide otherside = locked.allocation.authorizer amount instrumentId meta = emptyMetadata ] - nextIterationFunding = Some $ TM.singleton instrumentId newLockedAmount + nextIterationFunding = Some $ TM.singleton instrumentId amount ] diff --git a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml index 469ede68f2..088455e03f 100644 --- a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml +++ b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml @@ -230,7 +230,9 @@ computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline = | maxTime `subTime` oldExpiresAt <= maxTTL = maxTime | otherwise = oldExpiresAt `addRelTime` maxTTL +-- FIXME: the exception to allow Some maxBound is for infinite-duration governance locks, and should probably be limited more explicitly to only those cases. computeAllocationExpiry : TransferConfigV2 Amulet -> Time -> Optional Time -> Update Time +computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline | settlementDeadline == Some maxBound = pure maxBound computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline = do let expiresAt = computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline assertWithinDeadline "allocation.expiresAt" expiresAt From d2edb49e8f32bb1ec8e5a8365412c54c14b46e9f Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Mon, 20 Jul 2026 17:47:37 +0000 Subject: [PATCH 12/30] fix tests --- .../daml/Splice/Scripts/TestAggregateLocks.daml | 12 +++++++----- daml/splice-amulet/daml/Splice/AggregateLock.daml | 15 ++++++++++----- 2 files changed, 17 insertions(+), 10 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index 090f340218..8a7968e8c2 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -29,6 +29,7 @@ import qualified DA.TextMap as TM import Splice.Scripts.TokenStandard.TestAmuletTokenStandardTestEnv import Splice.Testing.Registries.AmuletRegistryV2 qualified as AmuletRegistryV2 +import Splice.TokenStandard.Utils.Internal.Conversions (encodeTime) lockForGovernance : TestEnv -> TM.TextMap Decimal -> Metadata -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult @@ -53,15 +54,15 @@ lockForAggregate : TestEnv -> Decimal -> Party -> ContractId AggregateLock -> Sc lockForAggregate te amount = lockForGovernance te (TM.fromList [(te.instrId.id, amount)]) $ Metadata $ TM.fromList [ ("cip-105/type", "aggregateLock") ] -lockForVesting : TestEnv -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult -lockForVesting te = lockForGovernance te TM.empty $ Metadata $ TM.fromList +lockForVesting : Time -> TestEnv -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult +lockForVesting now te = lockForGovernance te TM.empty $ Metadata $ TM.fromList [ ("cip-105/type", "vestingLock") - , ("cip-105/vestingPeriod", "365") ] + , ("cip-105/vestingLock.startDate", encodeTime now) + , ("cip-105/vestingLock.endDate", encodeTime $ addRelTime now $ days 365 + hours 6) ] testAggregateLockHappyPath : Script () testAggregateLockHappyPath = do env@TestEnv{..} <- setupTest - now <- getTime let dso = env.instrId.admin AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 @@ -77,7 +78,8 @@ testAggregateLockHappyPath = do -- Check total for the aggregate; needs to be implemented. - AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting env bob aggLock + now <- getTime + AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting (addRelTime now $ minutes 5) env bob aggLock -- use getSettlementFactory to get the extraArgs and disclosures to call AggregateLock_Unlock enriched <- getSettlementFactory registriesEnv.amuletV2 $ SettlementFactory_SettleBatch with diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index a3dec7a4f2..488ea48cf4 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -51,10 +51,14 @@ data VestingSchedule | VestingSchedule_Immediate deriving (Show, Eq, Ord) -validateVestingSchedule : VestingSchedule -> Metadata -> Bool -validateVestingSchedule VestingSchedule_SV meta = - TM.lookup "cip-105/vestingPeriod" meta.values == Some "365" -- Placeholder check, depends on vesting impl. -validateVestingSchedule VestingSchedule_Immediate _ = True +validateVestingSchedule : VestingSchedule -> Time -> Metadata -> Bool +validateVestingSchedule VestingSchedule_SV now meta = + let + start = decodeTime $ fromSomeNote "start must exist" (TM.lookup "cip-105/vestingLock.startDate" meta.values) + end = decodeTime $ fromSomeNote "end must exist" (TM.lookup "cip-105/vestingLock.endDate" meta.values) + in + now < start && end `subTime` start == days 365 + hours 6 +validateVestingSchedule VestingSchedule_Immediate _ _ = True -- | The intention is to treat the overall aggregate lock for a SV as if it is -- "the settlement" for the allocations locked to it, and use iterated @@ -91,7 +95,8 @@ template AggregateLock require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation dso locked require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination dso withdrawTo require "Must have amounts reserved within the next settlement iteration" $ isSome locked.allocation.nextIterationFunding - require "Vesting allocation must have a correct schedule configuration" $ validateVestingSchedule vestingSchedule withdrawTo.allocation.meta + now <- getTime + require "Vesting allocation must have a correct schedule configuration" $ validateVestingSchedule vestingSchedule now withdrawTo.allocation.meta let info = SettlementInfo with executors = [ dso ] From c935dc5348875eadbf513383e17a665143e3d9a5 Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Wed, 15 Jul 2026 21:47:15 +0000 Subject: [PATCH 13/30] WIP: Converting Vesting state to use the V2 Allocations --- .../daml/Splice/AggregateLock.daml | 42 ++++++++++++++++++- .../TestTokenV2/TestAllocationHappyV2.daml | 27 ++++++++++++ .../Utils/Internal/Conversions.daml | 3 ++ 3 files changed, 71 insertions(+), 1 deletion(-) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 488ea48cf4..c810063451 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -2,12 +2,13 @@ module Splice.AggregateLock where import Splice.Api.Token.AllocationV2 as V2 import Splice.Api.Token.MetadataV1 +import Splice.TokenStandard.Utils.Internal.Conversions (decodeTime) import Splice.Util import DA.Optional import DA.Text import qualified DA.TextMap as TM - +import DA.Time isValidAggregateLockedAllocation : Party -> V2.AllocationView -> Bool isValidAggregateLockedAllocation dso alloc = @@ -25,7 +26,11 @@ isValidVestingLockedDestination dso alloc = , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "vestingLock" , alloc.expiresAt == Some maxBound + , TM.member "cip-105/vestingLock.startDate" metaValues + , TM.member "cip-105/vestingLock.endDate" metaValues + -- TODO: Check the period is valid, check startDate < endDate ] + where metaValues = alloc.allocation.meta.values type ControllerSets = [[Party]] @@ -60,6 +65,24 @@ validateVestingSchedule VestingSchedule_SV now meta = now < start && end `subTime` start == days 365 + hours 6 validateVestingSchedule VestingSchedule_Immediate _ _ = True +calculateAvailableWithdrawAmount : Time -> V2.AllocationView -> Decimal -> Decimal +calculateAvailableWithdrawAmount currentDateTime alloc nextIterationFundAmount = max 0.0 availAmount + where + availAmount = if currentDateTime >= endDate + then nextIterationFundAmount + else 0.0 + -- (initialAmount * totalVestedPercentageElapsed) - withdrawnAmount + meta = alloc.allocation.meta.values + -- The initial amount represents the total that was locked initially when thrown into vesting state + initialAmount = fromSome $ TM.lookup "cip-105/vestingLock.initialAmount" meta + startDate = decodeTime . fromSome $ TM.lookup "cip-105/vestingLock.startDate" meta + endDate = decodeTime . fromSome $ TM.lookup "cip-105/vestingLock.endDate" meta + --totalUnlockPeriod = intToDecimal . convertRelTimeToMicroseconds $ subTime endDate startDate + --unlockPeriodElapsed = intToDecimal . convertRelTimeToMicroseconds $ subTime currentDateTime startDate + --totalVestedPercentageElapsed : Decimal = unlockPeriodElapsed / totalUnlockPeriod + --withdrawnAmount = initialAmount - nextIterationFundAmount + + -- | The intention is to treat the overall aggregate lock for a SV as if it is -- "the settlement" for the allocations locked to it, and use iterated -- settlement to execute updates on the committed allocations as needed. @@ -148,3 +171,20 @@ template AggregateLock ] nextIterationFunding = Some $ TM.singleton instrumentId amount ] + -- Choice temporarily lives here and it will be moved, testing/draft purposes atm + nonconsuming choice VestingLock_Withdraw : () -- AllocationResult + with + authorizers : [Party] + vestingLockCid : ContractId Allocation + where + controller authorizers + do + -- remainingLocked stays in nextIterationFunding + vestingLock <- view <$> fetch vestingLockCid + + require "There are no remaining funds to withdraw" + $ isSome vestingLock.allocation.nextIterationFunding + require "There must be an initialAmount set for the vestingLock" + $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values + + pure () diff --git a/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml b/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml index 43cb979150..9fc600beaa 100644 --- a/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml +++ b/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml @@ -10,6 +10,7 @@ import DA.Assert import DA.List (sort) import DA.Map qualified as Map import DA.TextMap qualified as TextMap +import DA.Time (addRelTime, days, hours) import Daml.Script @@ -24,6 +25,7 @@ import Splice.Testing.Tokens.TestTokenV2 qualified as TestTokenV2 import Splice.Testing.Utils import Splice.Testing.Registries.TestTokenV2_RegistryV2 qualified as TestTokenRegistryV2 +import Splice.TokenStandard.Utils.Internal.Conversions (encodeTime) import Splice.Testing.TokenStandard.RegistryApiV2 qualified as V2 import Splice.Testing.TokenStandard.WalletClientV2 qualified as WalletClientV2 import Splice.Testing.TokenStandard.MultiRegistry qualified as MultiRegistry @@ -45,6 +47,31 @@ test_allocation_WithdrawV2 = test_allocation_withdrawCancel_generic $ \TestEnv { meta = emptyMetadata pure () +-- This is a temporary test script +test_vesting_lock_WithdrawV2 : Script () +test_vesting_lock_WithdrawV2 = do + TestEnv {..} <- setupTest + now <- getTime + let endDate : Time = addRelTime now $ (days 365) + (hours 6) + vestingInitialAmount : Decimal = 3652.5 + + let allocationV2 = V2.AllocationSpecification with + admin = instrId.admin + authorizer = TSU.basicAccount alice + transferLegSides = [] + committed = False + nextIterationFunding = Some $ TextMap.fromList [(instrId.id, vestingInitialAmount)] + settlementDeadline = None + meta = Metadata with + values = TextMap.fromList + [ ("cip-105/type", "vestingLock") + , ("cip-105/vestingLock.initialAmount", show vestingInitialAmount) + , ("cip-105/vestingLock.startDate", encodeTime now) + , ("cip-105/vestingLock.endDate", encodeTime endDate) + ] + + pure () + -- TODO(tech-debt): add support for dealing with stale references to locked tokens -- -- Handle them analogous to how Amulet handles them and copy the relevant tests from Amulet. diff --git a/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml b/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml index 5fbcdd253a..1e70ba6c5c 100644 --- a/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml +++ b/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml @@ -27,6 +27,9 @@ module Splice.TokenStandard.Utils.Internal.Conversions ( partiesToMeta, dropMeta, validateNoMeta, + -- TODO: Is exporting the below cool? + encodeTime, + decodeTime, -- * Transfer utils reasonMetaKey, From 57f8bde01eff48059cf70a212a21c5449db239fe Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Thu, 16 Jul 2026 20:05:06 +0000 Subject: [PATCH 14/30] WIP Fixing withdrawing from VestingLock choice --- .../daml/Splice/AggregateLock.daml | 84 ++++++++++++++++--- 1 file changed, 71 insertions(+), 13 deletions(-) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index c810063451..e77a5dd610 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -65,22 +65,24 @@ validateVestingSchedule VestingSchedule_SV now meta = now < start && end `subTime` start == days 365 + hours 6 validateVestingSchedule VestingSchedule_Immediate _ _ = True -calculateAvailableWithdrawAmount : Time -> V2.AllocationView -> Decimal -> Decimal -calculateAvailableWithdrawAmount currentDateTime alloc nextIterationFundAmount = max 0.0 availAmount +-- TODO: Potentially make return type, it's own data type? +calculateAvailableWithdrawAmount : Time -> V2.AllocationView -> Decimal -> (Decimal, Decimal) +calculateAvailableWithdrawAmount currentDateTime alloc nextIterationFundAmount = max (0.0, 0.0) availAmount where availAmount = if currentDateTime >= endDate - then nextIterationFundAmount - else 0.0 - -- (initialAmount * totalVestedPercentageElapsed) - withdrawnAmount + then (nextIterationFundAmount, 0.0) + else (availableWithdrawAmount, remainingVestingAmount) + availableWithdrawAmount = (initialAmount * totalVestedRatioElapsed) - withdrawnAmount + remainingVestingAmount = nextIterationFundAmount - availableWithdrawAmount meta = alloc.allocation.meta.values -- The initial amount represents the total that was locked initially when thrown into vesting state - initialAmount = fromSome $ TM.lookup "cip-105/vestingLock.initialAmount" meta - startDate = decodeTime . fromSome $ TM.lookup "cip-105/vestingLock.startDate" meta - endDate = decodeTime . fromSome $ TM.lookup "cip-105/vestingLock.endDate" meta - --totalUnlockPeriod = intToDecimal . convertRelTimeToMicroseconds $ subTime endDate startDate - --unlockPeriodElapsed = intToDecimal . convertRelTimeToMicroseconds $ subTime currentDateTime startDate - --totalVestedPercentageElapsed : Decimal = unlockPeriodElapsed / totalUnlockPeriod - --withdrawnAmount = initialAmount - nextIterationFundAmount + initialAmount : Decimal = fromSome . parseDecimal . fromSome $ TM.lookup "cip-105/vestingLock.initialAmount" meta + startDate : Time = decodeTime . fromSome $ TM.lookup "cip-105/vestingLock.startDate" meta + endDate : Time = decodeTime . fromSome $ TM.lookup "cip-105/vestingLock.endDate" meta + totalUnlockPeriod : Decimal = intToDecimal . convertRelTimeToMicroseconds $ subTime endDate startDate + unlockPeriodElapsed : Decimal = intToDecimal . convertRelTimeToMicroseconds $ subTime currentDateTime startDate + totalVestedRatioElapsed : Decimal = unlockPeriodElapsed / totalUnlockPeriod + withdrawnAmount = initialAmount - nextIterationFundAmount -- | The intention is to treat the overall aggregate lock for a SV as if it is @@ -172,8 +174,10 @@ template AggregateLock nextIterationFunding = Some $ TM.singleton instrumentId amount ] -- Choice temporarily lives here and it will be moved, testing/draft purposes atm - nonconsuming choice VestingLock_Withdraw : () -- AllocationResult + -- Note: this whole choice is WIP + nonconsuming choice VestingLock_Withdraw : () -- TODO: Return type possibly AllocationResult with + factoryCid : ContractId SettlementFactory authorizers : [Party] vestingLockCid : ContractId Allocation where @@ -181,10 +185,64 @@ template AggregateLock do -- remainingLocked stays in nextIterationFunding vestingLock <- view <$> fetch vestingLockCid + now <- getTime + -- TODO: Probably add valid unlockController set check? + -- TODO: Potentially do case statement with nextIterationFunding optionals require "There are no remaining funds to withdraw" $ isSome vestingLock.allocation.nextIterationFunding + + let mNextIterationFunding = TM.lookup instrumentId $ fromSome vestingLock.allocation.nextIterationFunding + require ("The instrumentId " <> show instrumentId <> ", does not exist under the nextIterationFunding") + $ isSome mNextIterationFunding require "There must be an initialAmount set for the vestingLock" $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values + let (availableWithdrawAmount, remainingVestingAmount) : (Decimal, Decimal) = calculateAvailableWithdrawAmount now vestingLock + $ fromSome mNextIterationFunding + + require ("Current eligible withdraw amount for vesting lock is not greater than 0.0. " + <> "currentEligibleWithdrawableAmount came back = '" + <> show availableWithdrawAmount + <> "'." + ) + $ availableWithdrawAmount > 0.0 + + let + info = SettlementInfo with + executors = [ dso ] + id = "VestingLock_Withdraw" + cid = Some $ coerceContractId vestingLockCid + meta = emptyMetadata + transferLegId = "withdraw" + + exercise factoryCid $ SettlementFactory_SettleBatch with + settlement = info + actors = [ dso ] + extraArgs = ExtraArgs emptyChoiceContext emptyMetadata + transferLegs = + [ TransferLeg with + transferLegId + sender = vestingLock.allocation.authorizer + receiver = vestingLock.allocation.authorizer + amount = availableWithdrawAmount + instrumentId + meta = emptyMetadata + ] + allocations = + [ FinalizedAllocation with + allocationCid = vestingLockCid + extraTransferLegSides = + [ TransferLegSide with + transferLegId + side = SenderSide + otherside = vestingLock.allocation.authorizer + amount = remainingVestingAmount + instrumentId + meta = emptyMetadata + ] + nextIterationFunding = Some $ TM.singleton instrumentId remainingVestingAmount + ] + + pure () From ecadfda3418732ece072c67b606d3118be99991c Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Mon, 20 Jul 2026 21:21:09 +0000 Subject: [PATCH 15/30] WIP Start adding VestingLock Testing --- .../Splice/Scripts/TestAggregateLocks.daml | 34 ++++++++++++++++--- .../daml/Splice/AggregateLock.daml | 19 ++++++++--- .../TestTokenV2/TestAllocationHappyV2.daml | 26 -------------- 3 files changed, 43 insertions(+), 36 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index 8a7968e8c2..46ab6785ca 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -25,6 +25,7 @@ import DA.Assert import DA.Optional import DA.Functor import DA.Foldable (mapA_, sequence_) +import DA.List (last) import qualified DA.TextMap as TM import Splice.Scripts.TokenStandard.TestAmuletTokenStandardTestEnv @@ -54,11 +55,13 @@ lockForAggregate : TestEnv -> Decimal -> Party -> ContractId AggregateLock -> Sc lockForAggregate te amount = lockForGovernance te (TM.fromList [(te.instrId.id, amount)]) $ Metadata $ TM.fromList [ ("cip-105/type", "aggregateLock") ] -lockForVesting : Time -> TestEnv -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult -lockForVesting now te = lockForGovernance te TM.empty $ Metadata $ TM.fromList +lockForVesting : Decimal -> Time -> TestEnv -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult +lockForVesting initialAmount now te = lockForGovernance te TM.empty $ Metadata $ TM.fromList [ ("cip-105/type", "vestingLock") , ("cip-105/vestingLock.startDate", encodeTime now) - , ("cip-105/vestingLock.endDate", encodeTime $ addRelTime now $ days 365 + hours 6) ] + , ("cip-105/vestingLock.endDate", encodeTime $ addRelTime now $ days 365 + hours 6) + , ("cip-105/vestingLock.initialAmount", show initialAmount) + ] testAggregateLockHappyPath : Script () testAggregateLockHappyPath = do @@ -79,7 +82,8 @@ testAggregateLockHappyPath = do -- Check total for the aggregate; needs to be implemented. now <- getTime - AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting (addRelTime now $ minutes 5) env bob aggLock + let initialAmountToUnlock = 100.0 + AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting initialAmountToUnlock (addRelTime now $ minutes 5) env bob aggLock -- use getSettlementFactory to get the extraArgs and disclosures to call AggregateLock_Unlock enriched <- getSettlementFactory registriesEnv.amuletV2 $ SettlementFactory_SettleBatch with @@ -98,7 +102,7 @@ testAggregateLockHappyPath = do lockedCid = locked withdrawToCid = vestingInput authorizers = [ bob ] - amount = 100.0 + amount = initialAmountToUnlock extraArgs = enriched.arg.extraArgs allocations <- query @AmuletAllocationV2 bob @@ -109,3 +113,23 @@ testAggregateLockHappyPath = do -- Need to check other than via inspection that the two allocations actually exist with correct values. + -- TODO: Temporary, bad to do this + let (vestingLockAllocationCid, _) = last allocations + + -- Immediate withdraw attempt causes transaction to fail due to the current + -- eligible withdraw amount being zero (no time has passed since locking yet) + submitMustFail (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with + factoryCid = enriched.factoryCid + authorizers = [ bob ] + vestingLockCid = toInterfaceContractId vestingLockAllocationCid + + -- Time needs to pass to be able to withdraw fron the VestedAmulet + passTime (days 10) + + submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with + factoryCid = enriched.factoryCid + authorizers = [ bob ] + vestingLockCid = toInterfaceContractId vestingLockAllocationCid + +-- assertEq False True + pure () diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index e77a5dd610..0ce9708ef4 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -175,7 +175,7 @@ template AggregateLock ] -- Choice temporarily lives here and it will be moved, testing/draft purposes atm -- Note: this whole choice is WIP - nonconsuming choice VestingLock_Withdraw : () -- TODO: Return type possibly AllocationResult + nonconsuming choice VestingLock_Withdraw : AllocationResult with factoryCid : ContractId SettlementFactory authorizers : [Party] @@ -211,12 +211,12 @@ template AggregateLock let info = SettlementInfo with executors = [ dso ] - id = "VestingLock_Withdraw" - cid = Some $ coerceContractId vestingLockCid + id = "AggregateLock" + cid = Some $ coerceContractId self meta = emptyMetadata transferLegId = "withdraw" - exercise factoryCid $ SettlementFactory_SettleBatch with + batchResults <- exercise factoryCid $ SettlementFactory_SettleBatch with settlement = info actors = [ dso ] extraArgs = ExtraArgs emptyChoiceContext emptyMetadata @@ -240,9 +240,18 @@ template AggregateLock amount = remainingVestingAmount instrumentId meta = emptyMetadata + , TransferLegSide with + transferLegId + side = ReceiverSide + otherside = vestingLock.allocation.authorizer + amount = remainingVestingAmount + instrumentId + meta = emptyMetadata ] nextIterationFunding = Some $ TM.singleton instrumentId remainingVestingAmount ] + -- TODO: Fix hacky way potentially + let (allocationResult::_) = batchResults.allocationSettleResults - pure () + pure allocationResult diff --git a/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml b/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml index 9fc600beaa..c106baad90 100644 --- a/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml +++ b/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml @@ -25,7 +25,6 @@ import Splice.Testing.Tokens.TestTokenV2 qualified as TestTokenV2 import Splice.Testing.Utils import Splice.Testing.Registries.TestTokenV2_RegistryV2 qualified as TestTokenRegistryV2 -import Splice.TokenStandard.Utils.Internal.Conversions (encodeTime) import Splice.Testing.TokenStandard.RegistryApiV2 qualified as V2 import Splice.Testing.TokenStandard.WalletClientV2 qualified as WalletClientV2 import Splice.Testing.TokenStandard.MultiRegistry qualified as MultiRegistry @@ -47,31 +46,6 @@ test_allocation_WithdrawV2 = test_allocation_withdrawCancel_generic $ \TestEnv { meta = emptyMetadata pure () --- This is a temporary test script -test_vesting_lock_WithdrawV2 : Script () -test_vesting_lock_WithdrawV2 = do - TestEnv {..} <- setupTest - now <- getTime - let endDate : Time = addRelTime now $ (days 365) + (hours 6) - vestingInitialAmount : Decimal = 3652.5 - - let allocationV2 = V2.AllocationSpecification with - admin = instrId.admin - authorizer = TSU.basicAccount alice - transferLegSides = [] - committed = False - nextIterationFunding = Some $ TextMap.fromList [(instrId.id, vestingInitialAmount)] - settlementDeadline = None - meta = Metadata with - values = TextMap.fromList - [ ("cip-105/type", "vestingLock") - , ("cip-105/vestingLock.initialAmount", show vestingInitialAmount) - , ("cip-105/vestingLock.startDate", encodeTime now) - , ("cip-105/vestingLock.endDate", encodeTime endDate) - ] - - pure () - -- TODO(tech-debt): add support for dealing with stale references to locked tokens -- -- Handle them analogous to how Amulet handles them and copy the relevant tests from Amulet. From a54f6d59ee0432887c42eeb13593b8eba5257d76 Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Tue, 21 Jul 2026 18:25:21 +0000 Subject: [PATCH 16/30] WIP Flush out vestingUnlock tests more --- .../Splice/Scripts/TestAggregateLocks.daml | 32 ++++++++++++++++--- .../daml/Splice/AggregateLock.daml | 10 +++--- 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index 46ab6785ca..6d0faab17e 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -16,6 +16,7 @@ import Splice.Testing.Registries.AmuletRegistryV2 import Splice.Api.Token.MetadataV1 import Splice.Api.Token.AllocationV2 import Splice.Api.Token.AllocationInstructionV2 +import Splice.Api.Token.HoldingV2 import Splice.AmuletAllocationV2 import Splice.Testing.Utils @@ -25,7 +26,7 @@ import DA.Assert import DA.Optional import DA.Functor import DA.Foldable (mapA_, sequence_) -import DA.List (last) +import DA.List (head) import qualified DA.TextMap as TM import Splice.Scripts.TokenStandard.TestAmuletTokenStandardTestEnv @@ -82,7 +83,7 @@ testAggregateLockHappyPath = do -- Check total for the aggregate; needs to be implemented. now <- getTime - let initialAmountToUnlock = 100.0 + let initialAmountToUnlock = 365.25 AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting initialAmountToUnlock (addRelTime now $ minutes 5) env bob aggLock -- use getSettlementFactory to get the extraArgs and disclosures to call AggregateLock_Unlock @@ -114,7 +115,7 @@ testAggregateLockHappyPath = do -- Need to check other than via inspection that the two allocations actually exist with correct values. -- TODO: Temporary, bad to do this - let (vestingLockAllocationCid, _) = last allocations + let vestingLockAllocationCid = head [cid | (cid, a) <- allocations, TM.member "cip-105/vestingLock.initialAmount" a.allocation.meta.values] -- Immediate withdraw attempt causes transaction to fail due to the current -- eligible withdraw amount being zero (no time has passed since locking yet) @@ -122,14 +123,37 @@ testAggregateLockHappyPath = do factoryCid = enriched.factoryCid authorizers = [ bob ] vestingLockCid = toInterfaceContractId vestingLockAllocationCid + extraArgs = enriched.arg.extraArgs -- Time needs to pass to be able to withdraw fron the VestedAmulet passTime (days 10) - submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with + (AllocationResult vestingAllocResult tmHoldingCids _) <- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with factoryCid = enriched.factoryCid authorizers = [ bob ] vestingLockCid = toInterfaceContractId vestingLockAllocationCid + extraArgs = enriched.arg.extraArgs + + -- Time needs to pass to be able to withdraw fron the VestedAmulet + passTime (days 365) + + let holdingCids = fromSome $ TM.lookup env.instrId.id tmHoldingCids + debug holdingCids + + holdings <- queryInterface @Holding bob + debug holdings + let [(_, (Some unlockedHolding))] = filter (\(hcid, (Some h)) -> isNone h.lock && hcid `elem` holdingCids) holdings + debug unlockedHolding + + let tolerance = 0.01 + assert $ (abs $ unlockedHolding.amount - 10.0) < tolerance + +-- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with +-- factoryCid = enriched.factoryCid +-- authorizers = [ bob ] +-- vestingLockCid = toInterfaceContractId vestingLockAllocationCid +-- extraArgs = enriched.arg.extraArgs +-- -- assertEq False True pure () diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 0ce9708ef4..26dbacd7c1 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -180,6 +180,7 @@ template AggregateLock factoryCid : ContractId SettlementFactory authorizers : [Party] vestingLockCid : ContractId Allocation + extraArgs : ExtraArgs where controller authorizers do @@ -195,6 +196,7 @@ template AggregateLock let mNextIterationFunding = TM.lookup instrumentId $ fromSome vestingLock.allocation.nextIterationFunding require ("The instrumentId " <> show instrumentId <> ", does not exist under the nextIterationFunding") $ isSome mNextIterationFunding + -- TODO: DOUBLE we get the right type in meta values require "There must be an initialAmount set for the vestingLock" $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values @@ -219,7 +221,7 @@ template AggregateLock batchResults <- exercise factoryCid $ SettlementFactory_SettleBatch with settlement = info actors = [ dso ] - extraArgs = ExtraArgs emptyChoiceContext emptyMetadata + extraArgs transferLegs = [ TransferLeg with transferLegId @@ -237,14 +239,14 @@ template AggregateLock transferLegId side = SenderSide otherside = vestingLock.allocation.authorizer - amount = remainingVestingAmount + amount = availableWithdrawAmount instrumentId meta = emptyMetadata , TransferLegSide with transferLegId side = ReceiverSide otherside = vestingLock.allocation.authorizer - amount = remainingVestingAmount + amount = availableWithdrawAmount instrumentId meta = emptyMetadata ] @@ -252,6 +254,6 @@ template AggregateLock ] -- TODO: Fix hacky way potentially - let (allocationResult::_) = batchResults.allocationSettleResults + let [allocationResult] = batchResults.allocationSettleResults pure allocationResult From b6e5eec199e49c7216fb9a2eb7e6ff9eb74f0a7c Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Tue, 21 Jul 2026 20:56:05 +0000 Subject: [PATCH 17/30] Finish basic happy test for vestingUnlock --- .../Splice/Scripts/TestAggregateLocks.daml | 29 ++++++++++++------- .../daml/Splice/AggregateLock.daml | 5 +++- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index 6d0faab17e..83ac4e4849 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -133,27 +133,34 @@ testAggregateLockHappyPath = do authorizers = [ bob ] vestingLockCid = toInterfaceContractId vestingLockAllocationCid extraArgs = enriched.arg.extraArgs + debug vestingAllocResult -- Time needs to pass to be able to withdraw fron the VestedAmulet passTime (days 365) let holdingCids = fromSome $ TM.lookup env.instrId.id tmHoldingCids - debug holdingCids - holdings <- queryInterface @Holding bob - debug holdings + -- The holdings would include both locked/unlocked, so we filter let [(_, (Some unlockedHolding))] = filter (\(hcid, (Some h)) -> isNone h.lock && hcid `elem` holdingCids) holdings debug unlockedHolding let tolerance = 0.01 assert $ (abs $ unlockedHolding.amount - 10.0) < tolerance --- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with --- factoryCid = enriched.factoryCid --- authorizers = [ bob ] --- vestingLockCid = toInterfaceContractId vestingLockAllocationCid --- extraArgs = enriched.arg.extraArgs + (AllocationResult vestingAllocResult' tmHoldingCids' _) <- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with + factoryCid = enriched.factoryCid + authorizers = [ bob ] + vestingLockCid = fromSome $ vestingAllocResult.nextIterationAllocationCid + extraArgs = enriched.arg.extraArgs + + debug vestingAllocResult' + -- We should have no more remaining amount vesting, once the full period has passed + assertEq None $ vestingAllocResult'.nextIterationAllocationCid + + let holdingCids' = fromSome $ TM.lookup env.instrId.id tmHoldingCids' + holdings' <- queryInterface @Holding bob + -- The holdings would include both locked/unlocked, so we filter + let [(_, (Some unlockedHolding'))] = filter (\(hcid, (Some h)) -> isNone h.lock && hcid `elem` holdingCids') holdings' + debug unlockedHolding' --- --- assertEq False True - pure () + assertEq initialAmountToUnlock $ unlockedHolding.amount + unlockedHolding'.amount diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 26dbacd7c1..d971eb6fcd 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -217,6 +217,9 @@ template AggregateLock cid = Some $ coerceContractId self meta = emptyMetadata transferLegId = "withdraw" + nextIterationFunding + | remainingVestingAmount <= 0.0 = None + | otherwise = Some $ TM.singleton instrumentId remainingVestingAmount batchResults <- exercise factoryCid $ SettlementFactory_SettleBatch with settlement = info @@ -250,7 +253,7 @@ template AggregateLock instrumentId meta = emptyMetadata ] - nextIterationFunding = Some $ TM.singleton instrumentId remainingVestingAmount + nextIterationFunding = nextIterationFunding ] -- TODO: Fix hacky way potentially From a6409724d6bbc1473acbca67531e1b3118bd944d Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Tue, 21 Jul 2026 22:01:14 +0000 Subject: [PATCH 18/30] Move passTime within vesting happy path test --- .../daml/Splice/Scripts/TestAggregateLocks.daml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index 83ac4e4849..c1ebd483d7 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -135,9 +135,6 @@ testAggregateLockHappyPath = do extraArgs = enriched.arg.extraArgs debug vestingAllocResult - -- Time needs to pass to be able to withdraw fron the VestedAmulet - passTime (days 365) - let holdingCids = fromSome $ TM.lookup env.instrId.id tmHoldingCids holdings <- queryInterface @Holding bob -- The holdings would include both locked/unlocked, so we filter @@ -147,6 +144,9 @@ testAggregateLockHappyPath = do let tolerance = 0.01 assert $ (abs $ unlockedHolding.amount - 10.0) < tolerance + -- Let's try to withdraw the rest (now we should be past endDate) + passTime (days 365) + (AllocationResult vestingAllocResult' tmHoldingCids' _) <- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with factoryCid = enriched.factoryCid authorizers = [ bob ] From d9af90f0f803ac29bdb6a1701efa8dbad5720410 Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Wed, 22 Jul 2026 16:28:28 -0400 Subject: [PATCH 19/30] Add a script which constructs a fake single package for speeding up development cycles by allowing the LSP to work cross-package when working on code. --- .gitignore | 2 ++ daml-ide-mono/README.md | 15 +++++++++++++++ daml-ide-mono/daml.yaml | 17 +++++++++++++++++ scripts/setup-mono-package.sh | 29 +++++++++++++++++++++++++++++ 4 files changed, 63 insertions(+) create mode 100644 daml-ide-mono/README.md create mode 100644 daml-ide-mono/daml.yaml create mode 100755 scripts/setup-mono-package.sh diff --git a/.gitignore b/.gitignore index 2c56be64b4..230671f341 100644 --- a/.gitignore +++ b/.gitignore @@ -22,6 +22,8 @@ _build/ **/metals.sbt **/.scala-build/* +daml-ide-mono/daml/ +daml-ide-mono/.vscode/ .vscode/* !.vscode/settings.json # Make sure test files are checkedin diff --git a/daml-ide-mono/README.md b/daml-ide-mono/README.md new file mode 100644 index 0000000000..4a24340200 --- /dev/null +++ b/daml-ide-mono/README.md @@ -0,0 +1,15 @@ +# What is this? + +This directory, along with its fake `daml.yaml` can be populated with symlinks by +`./scripts/setup-mono-package.sh` to serve as a fake single-dar package containing all the daml in +Splice such that cross-package changes can be worked on with a tighter feedback loop using the +Daml Language Server (LSP) in VS Code or other editors, e.g. by running `dpm studio` in this directory +after having run the script. + +You'll also have to remember to re-run the script if you add new `.daml` files to any package. + +You should still verify that everything builds/tests for real once you're done of course, but this mode +of interaction can be very useful to eliminate 12-20 second build cycles and instead get immediate +feedback from the VS Code extension when working on tests and making changes that would otherwise be in +their upstream DAR dependencies, for example. + diff --git a/daml-ide-mono/daml.yaml b/daml-ide-mono/daml.yaml new file mode 100644 index 0000000000..e998fdd9a9 --- /dev/null +++ b/daml-ide-mono/daml.yaml @@ -0,0 +1,17 @@ +sdk-version: 3.5.2 +name: splice-mono-ide +source: daml +version: 0.0.1 +dependencies: + - daml-prim + - daml-stdlib + - daml-script +build-options: + - --ghc-option=-Wunused-binds + - --ghc-option=-Wunused-matches + - --target=2.1 + - -Wno-upgrade-exceptions + - -Wno-deprecated-exceptions + - -Wno-template-interface-depends-on-daml-script + - -Wno-upgrade-interfaces + - --force-utility-package=no diff --git a/scripts/setup-mono-package.sh b/scripts/setup-mono-package.sh new file mode 100755 index 0000000000..d12b164336 --- /dev/null +++ b/scripts/setup-mono-package.sh @@ -0,0 +1,29 @@ +#!/usr/bin/env bash +# Populate daml-ide-mono/daml/ with per-file symlinks into every workspace +# Daml package's source tree. The synthesised daml-ide-mono/daml.yaml is +# checked in and static - this script only regenerates the source tree +# so that VS Code can work on the union as a single package. +# +# Re-run this any time you add a new .daml file to the workspace or add +# a new workspace package. Symlinks are relative, so `mv`-ing the repo +# leaves them working. +set -euo pipefail + +repo=$(cd "$(dirname "$0")/.." && pwd) +dest="$repo/daml-ide-mono/daml" + +rm -rf "$dest" +mkdir -p "$dest" + +for pkg in "$repo"/daml/*/daml.yaml \ + "$repo"/token-standard/*/daml.yaml \ + "$repo"/token-standard/examples/*/daml.yaml; do + src=$(dirname "$pkg")/daml + [ -d "$src" ] || continue + ( cd "$src" && find . -name '*.daml' -printf '%P\n' ) | + while IFS= read -r rel; do + link="$dest/$rel" + mkdir -p "$(dirname "$link")" + ln -sfn "$src/$rel" "$link" + done +done From cd652f1f3427d29e5aa1bebca77d0b7854d708bc Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Wed, 22 Jul 2026 20:47:35 +0000 Subject: [PATCH 20/30] Fix some issues related to PR comments for VestingLock --- .../Splice/Scripts/TestAggregateLocks.daml | 4 +- .../daml/Splice/AggregateLock.daml | 42 +++++++++++-------- .../TestTokenV2/TestAllocationHappyV2.daml | 1 - 3 files changed, 26 insertions(+), 21 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index c1ebd483d7..acd13f9c5c 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -71,7 +71,7 @@ testAggregateLockHappyPath = do AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 - aggLock <- submit (actAs [alice, dso]) $ createCmd AggregateLock with + aggLock <- submit (actAs dso) $ createCmd AggregateLock with dso instrumentId = env.instrId.id vestingSchedule = VestingSchedule_SV @@ -125,7 +125,7 @@ testAggregateLockHappyPath = do vestingLockCid = toInterfaceContractId vestingLockAllocationCid extraArgs = enriched.arg.extraArgs - -- Time needs to pass to be able to withdraw fron the VestedAmulet + -- Time needs to pass to be able to withdraw from the VestingLock passTime (days 10) (AllocationResult vestingAllocResult tmHoldingCids _) <- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index d971eb6fcd..da63f3dea2 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -3,10 +3,12 @@ module Splice.AggregateLock where import Splice.Api.Token.AllocationV2 as V2 import Splice.Api.Token.MetadataV1 import Splice.TokenStandard.Utils.Internal.Conversions (decodeTime) +import Splice.Types (ForDso(..)) import Splice.Util import DA.Optional import DA.Text +import qualified DA.List as L import qualified DA.TextMap as TM import DA.Time @@ -28,7 +30,6 @@ isValidVestingLockedDestination dso alloc = , alloc.expiresAt == Some maxBound , TM.member "cip-105/vestingLock.startDate" metaValues , TM.member "cip-105/vestingLock.endDate" metaValues - -- TODO: Check the period is valid, check startDate < endDate ] where metaValues = alloc.allocation.meta.values @@ -110,8 +111,8 @@ template AggregateLock where controller authorizers do - locked <- view <$> fetch lockedCid - withdrawTo <- view <$> fetch withdrawToCid + locked <- view <$> fetchCheckedInterface (ForDso with dso) lockedCid + withdrawTo <- view <$> fetchCheckedInterface (ForDso with dso) withdrawToCid ownerParty <- whenNone locked.allocation.authorizer.owner $ assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta locked.meta ownerParty @@ -184,26 +185,29 @@ template AggregateLock where controller authorizers do - -- remainingLocked stays in nextIterationFunding - vestingLock <- view <$> fetch vestingLockCid + vestingLock <- view <$> fetchCheckedInterface (ForDso with dso) vestingLockCid now <- getTime + ownerParty <- whenNone vestingLock.allocation.authorizer.owner $ + assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" - -- TODO: Probably add valid unlockController set check? - -- TODO: Potentially do case statement with nextIterationFunding optionals - require "There are no remaining funds to withdraw" - $ isSome vestingLock.allocation.nextIterationFunding - - let mNextIterationFunding = TM.lookup instrumentId $ fromSome vestingLock.allocation.nextIterationFunding - require ("The instrumentId " <> show instrumentId <> ", does not exist under the nextIterationFunding") - $ isSome mNextIterationFunding - -- TODO: DOUBLE we get the right type in meta values + require "Must be a valid vesting unlock allocation" $ isValidVestingLockedDestination dso vestingLock require "There must be an initialAmount set for the vestingLock" $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values + let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta vestingLock.meta ownerParty + require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets + + let mNextIterationFunding = case vestingLock.allocation.nextIterationFunding of + None -> None + Some nextIterationFundingTM -> + TM.lookup instrumentId nextIterationFundingTM + require ("VestingLock's nextIterationFunding should have remaining funds to withdraw for instrumentId " <> show instrumentId) + $ isSome mNextIterationFunding + let nextIterationFundingAmount = fromSome mNextIterationFunding - let (availableWithdrawAmount, remainingVestingAmount) : (Decimal, Decimal) = calculateAvailableWithdrawAmount now vestingLock - $ fromSome mNextIterationFunding + let (availableWithdrawAmount, remainingVestingAmount) : (Decimal, Decimal) = + calculateAvailableWithdrawAmount now vestingLock nextIterationFundingAmount - require ("Current eligible withdraw amount for vesting lock is not greater than 0.0. " + require ("Current eligible withdraw amount for vesting lock should be greater than 0.0. " <> "currentEligibleWithdrawableAmount came back = '" <> show availableWithdrawAmount <> "'." @@ -256,7 +260,9 @@ template AggregateLock nextIterationFunding = nextIterationFunding ] - -- TODO: Fix hacky way potentially + -- We should have one result from settleBatch + require "VestingUnlock_Withdraw should result in one allocation result. " $ + L.length batchResults.allocationSettleResults == 1 let [allocationResult] = batchResults.allocationSettleResults pure allocationResult diff --git a/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml b/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml index c106baad90..43cb979150 100644 --- a/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml +++ b/token-standard/examples/splice-test-token-v2-test/daml/Splice/Testing/Tokens/TestTokenV2/TestAllocationHappyV2.daml @@ -10,7 +10,6 @@ import DA.Assert import DA.List (sort) import DA.Map qualified as Map import DA.TextMap qualified as TextMap -import DA.Time (addRelTime, days, hours) import Daml.Script From 126abd344f0eb5b4c2b57ae7ddf30e45a0662462 Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Fri, 24 Jul 2026 19:08:10 +0000 Subject: [PATCH 21/30] Address some CIP-0105 PR comments --- .../Splice/Scripts/TestAggregateLocks.daml | 10 ++---- .../daml/Splice/AggregateLock.daml | 34 +++++++++---------- .../Utils/Internal/Conversions.daml | 1 - 3 files changed, 19 insertions(+), 26 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index acd13f9c5c..c3c69b5919 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -84,7 +84,7 @@ testAggregateLockHappyPath = do now <- getTime let initialAmountToUnlock = 365.25 - AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting initialAmountToUnlock (addRelTime now $ minutes 5) env bob aggLock + AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting initialAmountToUnlock now env bob aggLock -- use getSettlementFactory to get the extraArgs and disclosures to call AggregateLock_Unlock enriched <- getSettlementFactory registriesEnv.amuletV2 $ SettlementFactory_SettleBatch with @@ -108,7 +108,6 @@ testAggregateLockHappyPath = do allocations <- query @AmuletAllocationV2 bob - debug allocations assert $ length allocations == 2 @@ -133,16 +132,13 @@ testAggregateLockHappyPath = do authorizers = [ bob ] vestingLockCid = toInterfaceContractId vestingLockAllocationCid extraArgs = enriched.arg.extraArgs - debug vestingAllocResult let holdingCids = fromSome $ TM.lookup env.instrId.id tmHoldingCids holdings <- queryInterface @Holding bob -- The holdings would include both locked/unlocked, so we filter let [(_, (Some unlockedHolding))] = filter (\(hcid, (Some h)) -> isNone h.lock && hcid `elem` holdingCids) holdings - debug unlockedHolding - let tolerance = 0.01 - assert $ (abs $ unlockedHolding.amount - 10.0) < tolerance + assertEq unlockedHolding.amount 10.0000000105 -- Let's try to withdraw the rest (now we should be past endDate) passTime (days 365) @@ -153,7 +149,6 @@ testAggregateLockHappyPath = do vestingLockCid = fromSome $ vestingAllocResult.nextIterationAllocationCid extraArgs = enriched.arg.extraArgs - debug vestingAllocResult' -- We should have no more remaining amount vesting, once the full period has passed assertEq None $ vestingAllocResult'.nextIterationAllocationCid @@ -161,6 +156,5 @@ testAggregateLockHappyPath = do holdings' <- queryInterface @Holding bob -- The holdings would include both locked/unlocked, so we filter let [(_, (Some unlockedHolding'))] = filter (\(hcid, (Some h)) -> isNone h.lock && hcid `elem` holdingCids') holdings' - debug unlockedHolding' assertEq initialAmountToUnlock $ unlockedHolding.amount + unlockedHolding'.amount diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index da63f3dea2..ba6f1edc05 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -1,11 +1,13 @@ module Splice.AggregateLock where +import Splice.Amulet.TokenApiUtils import Splice.Api.Token.AllocationV2 as V2 import Splice.Api.Token.MetadataV1 import Splice.TokenStandard.Utils.Internal.Conversions (decodeTime) import Splice.Types (ForDso(..)) import Splice.Util +import DA.Either import DA.Optional import DA.Text import qualified DA.List as L @@ -36,7 +38,7 @@ isValidVestingLockedDestination dso alloc = type ControllerSets = [[Party]] partiesFromText : Text -> Optional [Party] -partiesFromText = mapA partyFromText . splitOn "," +partiesFromText = eitherToOptional . parseCommaSeparated "Parties" partyFromText controllerSetFromMeta : Text -> Optional ControllerSets controllerSetFromMeta = mapA partiesFromText . splitOn ";" @@ -63,7 +65,8 @@ validateVestingSchedule VestingSchedule_SV now meta = start = decodeTime $ fromSomeNote "start must exist" (TM.lookup "cip-105/vestingLock.startDate" meta.values) end = decodeTime $ fromSomeNote "end must exist" (TM.lookup "cip-105/vestingLock.endDate" meta.values) in - now < start && end `subTime` start == days 365 + hours 6 + -- CIP-0105 states the SV vesting period be 365.25 days + now <= start && end `subTime` start == days 365 + hours 6 validateVestingSchedule VestingSchedule_Immediate _ _ = True -- TODO: Potentially make return type, it's own data type? @@ -174,8 +177,7 @@ template AggregateLock ] nextIterationFunding = Some $ TM.singleton instrumentId amount ] - -- Choice temporarily lives here and it will be moved, testing/draft purposes atm - -- Note: this whole choice is WIP + -- Note: Choice temporarily lives here and it will be moved, testing/draft purposes atm nonconsuming choice VestingLock_Withdraw : AllocationResult with factoryCid : ContractId SettlementFactory @@ -196,13 +198,13 @@ template AggregateLock let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta vestingLock.meta ownerParty require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets - let mNextIterationFunding = case vestingLock.allocation.nextIterationFunding of - None -> None - Some nextIterationFundingTM -> - TM.lookup instrumentId nextIterationFundingTM - require ("VestingLock's nextIterationFunding should have remaining funds to withdraw for instrumentId " <> show instrumentId) - $ isSome mNextIterationFunding - let nextIterationFundingAmount = fromSome mNextIterationFunding + let mNextIterationFunding = do + fundingMap <- vestingLock.allocation.nextIterationFunding + TM.lookup instrumentId fundingMap + + nextIterationFundingAmount <- case mNextIterationFunding of + None -> abort ("VestingLock's nextIterationFunding should have remaining funds to withdraw for instrumentId " <> show instrumentId) + Some amount -> pure amount let (availableWithdrawAmount, remainingVestingAmount) : (Decimal, Decimal) = calculateAvailableWithdrawAmount now vestingLock nextIterationFundingAmount @@ -260,9 +262,7 @@ template AggregateLock nextIterationFunding = nextIterationFunding ] - -- We should have one result from settleBatch - require "VestingUnlock_Withdraw should result in one allocation result. " $ - L.length batchResults.allocationSettleResults == 1 - let [allocationResult] = batchResults.allocationSettleResults - - pure allocationResult + -- We should have one result from settleBatch + case batchResults.allocationSettleResults of + [allocationResult] -> pure allocationResult + _ -> abort "VestingUnlock_Withdraw should result in one allocation result. " diff --git a/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml b/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml index 1e70ba6c5c..60c19fb477 100644 --- a/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml +++ b/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml @@ -27,7 +27,6 @@ module Splice.TokenStandard.Utils.Internal.Conversions ( partiesToMeta, dropMeta, validateNoMeta, - -- TODO: Is exporting the below cool? encodeTime, decodeTime, From d655a87aa44180bdf0154be8edda69f7133d5f13 Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Mon, 27 Jul 2026 17:14:21 +0000 Subject: [PATCH 22/30] Revert "Add a script which constructs a fake single package for speeding up development cycles by allowing the LSP to work cross-package when working on code." This reverts commit 15dfa701bdbf30093e66fc2c205883b0990ecdf7. --- .gitignore | 2 -- daml-ide-mono/README.md | 15 --------------- daml-ide-mono/daml.yaml | 17 ----------------- scripts/setup-mono-package.sh | 29 ----------------------------- 4 files changed, 63 deletions(-) delete mode 100644 daml-ide-mono/README.md delete mode 100644 daml-ide-mono/daml.yaml delete mode 100755 scripts/setup-mono-package.sh diff --git a/.gitignore b/.gitignore index 230671f341..2c56be64b4 100644 --- a/.gitignore +++ b/.gitignore @@ -22,8 +22,6 @@ _build/ **/metals.sbt **/.scala-build/* -daml-ide-mono/daml/ -daml-ide-mono/.vscode/ .vscode/* !.vscode/settings.json # Make sure test files are checkedin diff --git a/daml-ide-mono/README.md b/daml-ide-mono/README.md deleted file mode 100644 index 4a24340200..0000000000 --- a/daml-ide-mono/README.md +++ /dev/null @@ -1,15 +0,0 @@ -# What is this? - -This directory, along with its fake `daml.yaml` can be populated with symlinks by -`./scripts/setup-mono-package.sh` to serve as a fake single-dar package containing all the daml in -Splice such that cross-package changes can be worked on with a tighter feedback loop using the -Daml Language Server (LSP) in VS Code or other editors, e.g. by running `dpm studio` in this directory -after having run the script. - -You'll also have to remember to re-run the script if you add new `.daml` files to any package. - -You should still verify that everything builds/tests for real once you're done of course, but this mode -of interaction can be very useful to eliminate 12-20 second build cycles and instead get immediate -feedback from the VS Code extension when working on tests and making changes that would otherwise be in -their upstream DAR dependencies, for example. - diff --git a/daml-ide-mono/daml.yaml b/daml-ide-mono/daml.yaml deleted file mode 100644 index e998fdd9a9..0000000000 --- a/daml-ide-mono/daml.yaml +++ /dev/null @@ -1,17 +0,0 @@ -sdk-version: 3.5.2 -name: splice-mono-ide -source: daml -version: 0.0.1 -dependencies: - - daml-prim - - daml-stdlib - - daml-script -build-options: - - --ghc-option=-Wunused-binds - - --ghc-option=-Wunused-matches - - --target=2.1 - - -Wno-upgrade-exceptions - - -Wno-deprecated-exceptions - - -Wno-template-interface-depends-on-daml-script - - -Wno-upgrade-interfaces - - --force-utility-package=no diff --git a/scripts/setup-mono-package.sh b/scripts/setup-mono-package.sh deleted file mode 100755 index d12b164336..0000000000 --- a/scripts/setup-mono-package.sh +++ /dev/null @@ -1,29 +0,0 @@ -#!/usr/bin/env bash -# Populate daml-ide-mono/daml/ with per-file symlinks into every workspace -# Daml package's source tree. The synthesised daml-ide-mono/daml.yaml is -# checked in and static - this script only regenerates the source tree -# so that VS Code can work on the union as a single package. -# -# Re-run this any time you add a new .daml file to the workspace or add -# a new workspace package. Symlinks are relative, so `mv`-ing the repo -# leaves them working. -set -euo pipefail - -repo=$(cd "$(dirname "$0")/.." && pwd) -dest="$repo/daml-ide-mono/daml" - -rm -rf "$dest" -mkdir -p "$dest" - -for pkg in "$repo"/daml/*/daml.yaml \ - "$repo"/token-standard/*/daml.yaml \ - "$repo"/token-standard/examples/*/daml.yaml; do - src=$(dirname "$pkg")/daml - [ -d "$src" ] || continue - ( cd "$src" && find . -name '*.daml' -printf '%P\n' ) | - while IFS= read -r rel; do - link="$dest/$rel" - mkdir -p "$(dirname "$link")" - ln -sfn "$src/$rel" "$link" - done -done From c676d091e835bca9df49ba833b185469fc1d65bb Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Mon, 27 Jul 2026 06:48:28 -0400 Subject: [PATCH 23/30] Add a script which constructs a fake single package for speeding up dev cycles (#6523) --------- Signed-off-by: Cale Gibbard --- .gitignore | 2 ++ daml/daml-ide-mono/README.md | 15 +++++++++++++++ daml/daml-ide-mono/daml.yaml | 17 +++++++++++++++++ docs/gen-daml-docs.sh | 1 + scripts/rename.sh | 2 +- scripts/setup-mono-package.sh | 34 ++++++++++++++++++++++++++++++++++ 6 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 daml/daml-ide-mono/README.md create mode 100644 daml/daml-ide-mono/daml.yaml create mode 100755 scripts/setup-mono-package.sh diff --git a/.gitignore b/.gitignore index 2c56be64b4..fae017aaa8 100644 --- a/.gitignore +++ b/.gitignore @@ -22,6 +22,8 @@ _build/ **/metals.sbt **/.scala-build/* +daml/daml-ide-mono/daml/ +daml/daml-ide-mono/.vscode/ .vscode/* !.vscode/settings.json # Make sure test files are checkedin diff --git a/daml/daml-ide-mono/README.md b/daml/daml-ide-mono/README.md new file mode 100644 index 0000000000..4a24340200 --- /dev/null +++ b/daml/daml-ide-mono/README.md @@ -0,0 +1,15 @@ +# What is this? + +This directory, along with its fake `daml.yaml` can be populated with symlinks by +`./scripts/setup-mono-package.sh` to serve as a fake single-dar package containing all the daml in +Splice such that cross-package changes can be worked on with a tighter feedback loop using the +Daml Language Server (LSP) in VS Code or other editors, e.g. by running `dpm studio` in this directory +after having run the script. + +You'll also have to remember to re-run the script if you add new `.daml` files to any package. + +You should still verify that everything builds/tests for real once you're done of course, but this mode +of interaction can be very useful to eliminate 12-20 second build cycles and instead get immediate +feedback from the VS Code extension when working on tests and making changes that would otherwise be in +their upstream DAR dependencies, for example. + diff --git a/daml/daml-ide-mono/daml.yaml b/daml/daml-ide-mono/daml.yaml new file mode 100644 index 0000000000..e998fdd9a9 --- /dev/null +++ b/daml/daml-ide-mono/daml.yaml @@ -0,0 +1,17 @@ +sdk-version: 3.5.2 +name: splice-mono-ide +source: daml +version: 0.0.1 +dependencies: + - daml-prim + - daml-stdlib + - daml-script +build-options: + - --ghc-option=-Wunused-binds + - --ghc-option=-Wunused-matches + - --target=2.1 + - -Wno-upgrade-exceptions + - -Wno-deprecated-exceptions + - -Wno-template-interface-depends-on-daml-script + - -Wno-upgrade-interfaces + - --force-utility-package=no diff --git a/docs/gen-daml-docs.sh b/docs/gen-daml-docs.sh index ac5e208f7f..1fd1c1818e 100755 --- a/docs/gen-daml-docs.sh +++ b/docs/gen-daml-docs.sh @@ -47,6 +47,7 @@ DAML_PROJECT_FILES="\ -not -ipath '*splitwell*' \ -not -ipath '*app-manager*' \ -not -ipath '*dummy-holding*' \ + -not -ipath '*daml-ide-mono*' \ -print)" DAML_PROJECT_FILES=$(printf "%s\n" "$DAML_PROJECT_FILES" | grep -vf <(printf "%s\n" "${NON_COMPILED_DAML_PROJECTS[@]}" | xargs -n1 basename)) diff --git a/scripts/rename.sh b/scripts/rename.sh index 92ff142232..8fc9397d5e 100755 --- a/scripts/rename.sh +++ b/scripts/rename.sh @@ -1216,7 +1216,7 @@ function subcmd_no_illegal_daml_references() { ) for pattern in "${illegal_patterns[@]}"; do echo "Checking for occurences of '$pattern' (case sensitive, in code other than splitwell)" - if rg -P "$pattern" daml/ token-standard/ -g '!*/splitwell/*' -g '!*/splitwell-test/*' -g '!daml/dars.lock' -g '!token-standard/README.md' -g '!token-standard/V2_VALIDATION.md' -g '!token-standard/TOKEN_STANDARD_V2_DEVNET.md' -g '!*.json' -g '!token-standard/dependencies/*' -g '!**/target/'; then + if rg -P "$pattern" daml/ token-standard/ -g '!*/splitwell/*' -g '!*/splitwell-test/*' -g '!daml/dars.lock' -g '!token-standard/README.md' -g '!token-standard/V2_VALIDATION.md' -g '!token-standard/TOKEN_STANDARD_V2_DEVNET.md' -g'!daml/daml-ide-mono/README.md' -g '!*.json' -g '!token-standard/dependencies/*' -g '!**/target/'; then echo "$pattern occurs in Daml code (other than splitwell), remove all references" exit 1 fi diff --git a/scripts/setup-mono-package.sh b/scripts/setup-mono-package.sh new file mode 100755 index 0000000000..d7e8cc34f8 --- /dev/null +++ b/scripts/setup-mono-package.sh @@ -0,0 +1,34 @@ +#!/usr/bin/env bash + +# Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved. +# SPDX-License-Identifier: Apache-2.0 + +# Populate daml/daml-ide-mono/daml/ with per-file symlinks into every +# workspace Daml package's source tree. daml/daml-ide-mono/daml.yaml is +# checked in and static - this script only regenerates the source tree +# so that VS Code can work on the union as a single package. +# +# Re-run this any time a .daml file is added or removed anywhere in the +# workspace. + +set -euo pipefail + +repo=$(cd "$(dirname "$0")/.." && pwd) +dest="$repo/daml/daml-ide-mono/daml" + +rm -rf "$dest" +mkdir -p "$dest" + +for pkg in "$repo"/daml/*/daml.yaml \ + "$repo"/token-standard/*/daml.yaml \ + "$repo"/token-standard/examples/*/daml.yaml; do + src=$(dirname "$pkg")/daml + [ -d "$src" ] || continue + ( cd "$src" && find . -name '*.daml' -printf '%P\n' ) | + while IFS= read -r rel; do + link="$dest/$rel" + mkdir -p "$(dirname "$link")" + target=$(realpath --relative-to="$(dirname "$link")" "$src/$rel") + ln -sfn "$target" "$link" + done +done From 930c26f262da9bea33af8a4787b74affb9559177 Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Tue, 28 Jul 2026 12:19:28 +0000 Subject: [PATCH 24/30] WIP: hook the withdraw-like operations to withdraw. --- .../Splice/Scripts/TestAggregateLocks.daml | 82 +++- .../daml/Splice/AggregateLock.daml | 362 ++++++++++-------- .../daml/Splice/AmuletAllocationV2.daml | 15 +- .../Utils/Internal/Allocations.daml | 14 +- .../Testing/Registries/AmuletRegistryV2.daml | 4 + 5 files changed, 301 insertions(+), 176 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index c3c69b5919..717a9e6a02 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Splice.Scripts.TestAggregateLocks where import DA.Time @@ -10,6 +11,7 @@ import Splice.Expiry import Splice.Scripts.Util import Splice.TokenStandard.Utils qualified as TSU import Splice.Api.Token.AllocationV2 qualified as V2 +import Splice.Api.Token.HoldingV2 qualified as V2 import Splice.Testing.TokenStandard.RegistryApiV2 import Splice.Testing.TokenStandard.WalletClientV2 qualified as WalletClientV2 import Splice.Testing.Registries.AmuletRegistryV2 @@ -28,20 +30,34 @@ import DA.Functor import DA.Foldable (mapA_, sequence_) import DA.List (head) import qualified DA.TextMap as TM +import qualified DA.Map as M import Splice.Scripts.TokenStandard.TestAmuletTokenStandardTestEnv import Splice.Testing.Registries.AmuletRegistryV2 qualified as AmuletRegistryV2 import Splice.TokenStandard.Utils.Internal.Conversions (encodeTime) - -lockForGovernance : TestEnv -> TM.TextMap Decimal -> Metadata -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult -lockForGovernance (TestEnv {..}) amounts meta party aggCid = do - WalletClientV2.allocateV2 registries bob lockSettlementInfo lockAllocation +newtype AmuletRegistryExtraWithdrawContext = AmuletRegistryExtraWithdrawContext { unExtra : AmuletRegistry } + +instance RegistryApi AmuletRegistryExtraWithdrawContext where + getTransferFactory = getTransferFactory . unExtra + getAllocationFactory = getAllocationFactory . unExtra + getSettlementFactory = getSettlementFactory . unExtra + getAllocation_WithdrawContext = getAllocation_WithdrawContext . unExtra + getAllocation_CancelContext = getAllocation_CancelContext . unExtra + getAllocationInstruction_WithdrawContext = getAllocationInstruction_WithdrawContext . unExtra + getAllocationInstruction_AcceptContext = getAllocationInstruction_AcceptContext . unExtra + getTransferInstruction_AcceptContext = getTransferInstruction_AcceptContext . unExtra + getTransferInstruction_RejectContext = getTransferInstruction_RejectContext . unExtra + getTransferInstruction_WithdrawContext = getTransferInstruction_WithdrawContext . unExtra + +lockForGovernance : TestEnv -> TM.TextMap Decimal -> Metadata -> Party -> Script AllocationInstructionResult +lockForGovernance (TestEnv {..}) amounts meta party = do + WalletClientV2.allocateV2 registries party lockSettlementInfo lockAllocation where lockSettlementInfo = V2.SettlementInfo with executors = [ instrId.admin ] id = "AggregateLock" - cid = Some $ coerceContractId aggCid + cid = None -- Some $ coerceContractId aggCid meta = emptyMetadata lockAllocation = V2.AllocationSpecification with admin = instrId.admin @@ -49,14 +65,17 @@ lockForGovernance (TestEnv {..}) amounts meta party aggCid = do transferLegSides = [] committed = True nextIterationFunding = Some $ amounts -- TM.fromList [(instrId.id, amount)] - settlementDeadline = Some maxBound + settlementDeadline = Some maxComparableTime meta -lockForAggregate : TestEnv -> Decimal -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult -lockForAggregate te amount = lockForGovernance te (TM.fromList [(te.instrId.id, amount)]) $ Metadata $ TM.fromList - [ ("cip-105/type", "aggregateLock") ] +lockForAggregate : TestEnv -> Decimal -> Text -> Party -> Script AllocationInstructionResult +lockForAggregate te amount lockName = lockForGovernance te (TM.fromList [(te.instrId.id, amount)]) $ Metadata $ TM.fromList + [ ("cip-105/type", "aggregateLock") + , ("cip-105/for-benefit-of", lockName) + , ("cip-105/vestingSchedule", "SV") + ] -lockForVesting : Decimal -> Time -> TestEnv -> Party -> ContractId AggregateLock -> Script AllocationInstructionResult +lockForVesting : Decimal -> Time -> TestEnv -> Party -> Script AllocationInstructionResult lockForVesting initialAmount now te = lockForGovernance te TM.empty $ Metadata $ TM.fromList [ ("cip-105/type", "vestingLock") , ("cip-105/vestingLock.startDate", encodeTime now) @@ -69,18 +88,52 @@ testAggregateLockHappyPath = do env@TestEnv{..} <- setupTest let dso = env.instrId.admin + let + addAggregateWithdrawContext : Script OpenApiChoiceContext -> Script OpenApiChoiceContext + addAggregateWithdrawContext a = do + baseCtxt <- a + extraContext <- getExternalPartyConfigStateContext registriesEnv.amuletV2 + pure $ baseCtxt <> extraContext + updateApi api = api { ggetAllocation_WithdrawContext = \a -> addAggregateWithdrawContext . api.ggetAllocation_WithdrawContext a } + newRegistries = flip fmap registries $ \reg -> + reg { v2Api = fmap updateApi reg.v2Api } + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 - aggLock <- submit (actAs dso) $ createCmd AggregateLock with + {- + aggLock <- submit (actAs [alice, dso]) $ createCmd AggregateLock with dso instrumentId = env.instrId.id vestingSchedule = VestingSchedule_SV - Some aggLockDisclosure <- queryDisclosure dso aggLock + -- Some aggLockDisclosure <- queryDisclosure dso aggLock + -} -- Lock some funds for the aggregate - AllocationInstructionResult { output = AllocationInstructionResult_Completed locked } <- lockForAggregate env 1000.0 bob aggLock + AllocationInstructionResult { output = AllocationInstructionResult_Completed locked } <- lockForAggregate env 1000.0 "alice-supervalidator" bob + + Some lockedView <- queryInterfaceContractId bob locked + + allocs <- queryInterface @V2.Allocation dso + let filtered = filter (isValidAggregateLockedAllocation dso) $ fromSome . snd <$> allocs + toKeyAndAmount alloc = ("cip-105/for-benefit-of" `TM.lookup` alloc.allocation.meta.values, fromOptional 0.0 $ alloc.allocation.nextIterationFunding >>= TM.lookup env.instrId.id) + totals = M.fromListWith (+) $ toKeyAndAmount <$> filtered + + assertEq (Some 1000.0) (Some "alice-supervalidator" `M.lookup` totals) + + WalletClientV2.withdrawAllocationV2 newRegistries bob (locked, lockedView) + + let bobAcct = V2.Account with + owner = Some bob + provider = Some dso + id = "" + + allocs <- WalletClientV2.listAllocationsV2 bobAcct bob + + -- unlockResult <- WalletClientV2.withdrawAllocationV2 newRegistries bob $ head allocs + + pure () - -- Check total for the aggregate; needs to be implemented. + {- now <- getTime let initialAmountToUnlock = 365.25 @@ -112,6 +165,7 @@ testAggregateLockHappyPath = do assert $ length allocations == 2 -- Need to check other than via inspection that the two allocations actually exist with correct values. + -} -- TODO: Temporary, bad to do this let vestingLockAllocationCid = head [cid | (cid, a) <- allocations, TM.member "cip-105/vestingLock.initialAmount" a.allocation.meta.values] diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index ba6f1edc05..fed0fc6d3f 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -2,25 +2,31 @@ module Splice.AggregateLock where import Splice.Amulet.TokenApiUtils import Splice.Api.Token.AllocationV2 as V2 +import qualified Splice.Api.Token.AllocationInstructionV2 as V2 import Splice.Api.Token.MetadataV1 -import Splice.TokenStandard.Utils.Internal.Conversions (decodeTime) import Splice.Types (ForDso(..)) +import Splice.TokenStandard.Utils (fromAnyContractId, maxTime) +import Splice.TokenStandard.Utils.Internal.Allocations (settlementFactoryV2_settleBatchDefaultImplNoSelf) +import Splice.TokenStandard.Utils.Internal.Conversions (decodeTime, encodeTime) import Splice.Util import DA.Either import DA.Optional import DA.Text -import qualified DA.List as L +import DA.List import qualified DA.TextMap as TM import DA.Time +maxComparableTime : Time +maxComparableTime = addRelTime maxTime $ microseconds (-1) + isValidAggregateLockedAllocation : Party -> V2.AllocationView -> Bool isValidAggregateLockedAllocation dso alloc = and [ alloc.allocation.admin == dso , alloc.allocation.committed , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "aggregateLock" - , alloc.expiresAt == Some maxBound + , alloc.expiresAt == Some maxComparableTime ] isValidVestingLockedDestination : Party -> V2.AllocationView -> Bool @@ -29,7 +35,7 @@ isValidVestingLockedDestination dso alloc = , alloc.allocation.committed , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "vestingLock" - , alloc.expiresAt == Some maxBound + , alloc.expiresAt == Some maxTime , TM.member "cip-105/vestingLock.startDate" metaValues , TM.member "cip-105/vestingLock.endDate" metaValues ] @@ -46,14 +52,37 @@ controllerSetFromMeta = mapA partiesFromText . splitOn ";" data GovernanceLockedControllers = GovernanceLockedControllers with unlockControllerSets : ControllerSets substituteControllerSets : ControllerSets + withdrawControllerSets : ControllerSets governanceLockedControllersFromMeta : Metadata -> Party -> GovernanceLockedControllers governanceLockedControllersFromMeta meta acctParty = GovernanceLockedControllers with unlockControllerSets = controllerSetFromMetaMap "cip-105/unlockControllerSets" substituteControllerSets = controllerSetFromMetaMap "cip-105/substituteControllerSets" + withdrawControllerSets = controllerSetFromMetaMap "cip-105/withdrawControllerSets" where controllerSetFromMetaMap key = fromOptional [[acctParty]] $ controllerSetFromMeta =<< key `TM.lookup` meta.values +checkControllerSet : [Party] -> ControllerSets -> Update () +checkControllerSet parties set = + require "Controllers must be one of the listed options" $ any (\conj -> all (`elem` parties) conj && all (`elem` conj) parties) set + +governanceLockedWithdrawImpl + : HasToInterface a V2.Allocation + => (a -> Time -> Metadata -> Update (ContractId V2.Allocation)) + -> a + -> ContractId a + -> V2.Allocation_Withdraw + -> Update V2.AllocationResult +governanceLockedWithdrawImpl newEmptyAllocation a acid arg@(V2.Allocation_Withdraw{..}) = + case TM.lookup "cip-105/type" allocView.allocation.meta.values of + Some "aggregateLock" -> do + aggregateLockUnlock newEmptyAllocation a acid arg + Some "vestingLock" -> + vestingLockWithdraw a acid arg + _ -> assertFail "Invalid cip-105/type field." + where + allocView = view $ toInterface @V2.Allocation a + data VestingSchedule = VestingSchedule_SV | VestingSchedule_Immediate @@ -96,173 +125,188 @@ calculateAvailableWithdrawAmount currentDateTime alloc nextIterationFundAmount = -- vesting to be in a separate dar from amulet only needed for SVs and -- interested observers. -template AggregateLock +{-template AggregateLock with dso: Party instrumentId : Text vestingSchedule : VestingSchedule where signatory dso - nonconsuming choice AggregateLock_Unlock : SettlementFactory_SettleBatchResult - with - factoryCid : ContractId SettlementFactory - lockedCid : ContractId Allocation - withdrawToCid : ContractId Allocation - authorizers : [ Party ] - amount : Decimal - extraArgs : ExtraArgs - where - controller authorizers - do - locked <- view <$> fetchCheckedInterface (ForDso with dso) lockedCid - withdrawTo <- view <$> fetchCheckedInterface (ForDso with dso) withdrawToCid - ownerParty <- whenNone locked.allocation.authorizer.owner $ - assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" - let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta locked.meta ownerParty - require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets - require "Not allowed to unlock to a different party than locked the funds" $ locked.allocation.authorizer == withdrawTo.allocation.authorizer - require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation dso locked - require "Must be a valid empty vesting unlock allocation" $ isValidVestingLockedDestination dso withdrawTo - require "Must have amounts reserved within the next settlement iteration" $ isSome locked.allocation.nextIterationFunding - now <- getTime - require "Vesting allocation must have a correct schedule configuration" $ validateVestingSchedule vestingSchedule now withdrawTo.allocation.meta - let - info = SettlementInfo with - executors = [ dso ] - id = "AggregateLock" - cid = Some $ coerceContractId self - meta = emptyMetadata - transferLegId = "unlock" - - currentLockedAmount <- whenNone (locked.allocation.nextIterationFunding >>= TM.lookup instrumentId) $ - assertFail "The requirement 'Must have amounts reserved within the next settlement iteration' was not met" - let newLockedAmount = currentLockedAmount - amount - - exercise factoryCid $ SettlementFactory_SettleBatch with - settlement = info - actors = [ dso ] - extraArgs - transferLegs = - [ TransferLeg with +-} + +aggregateLockUnlock : (HasToInterface a V2.Allocation) => (a -> Time -> Metadata -> Update (ContractId V2.Allocation)) -> a -> ContractId a -> Allocation_Withdraw -> Update V2.AllocationResult +aggregateLockUnlock newEmptyAllocation a aCid arg = do + let alloc = view $ toInterface @V2.Allocation a + allocCid = toInterfaceContractId @V2.Allocation aCid + + (instrumentId, currentLockedAmount) <- case TM.toList <$> alloc.allocation.nextIterationFunding of + Some [a] -> pure a + _ -> assertFail "The requirement 'Must reserve a single amount of a single token' was not met" + + vestingSchedule <- decodeVestingSchedule arg.extraArgs.meta alloc.allocation.meta + + let dso = alloc.allocation.admin + + ownerParty <- whenNone alloc.allocation.authorizer.owner $ + assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" + + let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta alloc.meta ownerParty + checkControllerSet arg.actors unlockControllerSets + + require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation dso alloc + + now <- getTime + let endTime = getEndTimeFromVestingSchedule vestingSchedule now + transferLegId = "unlock" + + let alternateAmount = TM.lookup "cip-105/withdraw-amount" arg.extraArgs.meta.values >>= parseDecimal + amount = fromOptional currentLockedAmount alternateAmount + newLockedAmount = currentLockedAmount - amount + + -- Not easy to call directly into amulet_allocationFactoryV2_allocateImpl or the like here as that would make a circular dependency. + withdrawTo <- newEmptyAllocation a now $ Metadata $ TM.fromList + [ ("cip-105/type", "vestingLock") + , ("cip-105/vestingLock.startDate", encodeTime $ now) + , ("cip-105/vestingLock.endDate", encodeTime $ endTime) + ] + + -- settlementFactoryV2_settleBatchDefaultImpl does not use it's third argument, so we pass undefined rather than require a contract ID for ExternalPartyAmuletRules. + settleBatchResult <- settlementFactoryV2_settleBatchDefaultImplNoSelf (\_ _ -> pure arg.extraArgs) dso $ SettlementFactory_SettleBatch with + settlement = alloc.settlement + actors = [ dso ] + extraArgs = arg.extraArgs + transferLegs = + [ TransferLeg with + transferLegId + sender = alloc.allocation.authorizer + receiver = alloc.allocation.authorizer + amount + instrumentId + meta = emptyMetadata + ] + allocations = + [ FinalizedAllocation with + allocationCid = allocCid + extraTransferLegSides = + [ TransferLegSide with + transferLegId + side = SenderSide + otherside = alloc.allocation.authorizer + amount + instrumentId + meta = emptyMetadata + ] + nextIterationFunding = Some $ TM.singleton instrumentId newLockedAmount + , FinalizedAllocation with + allocationCid = withdrawTo + extraTransferLegSides = + [ TransferLegSide with + transferLegId + side = ReceiverSide + otherside = alloc.allocation.authorizer + amount + instrumentId + meta = emptyMetadata + ] + nextIterationFunding = Some $ TM.singleton instrumentId amount + ] + pure $ head settleBatchResult.allocationSettleResults + where + getEndTimeFromVestingSchedule VestingSchedule_SV now = addRelTime now $ days 365 + hours 6 + getEndTimeFromVestingSchedule VestingSchedule_Immediate now = now + +-- vestingLockWithdraw : V2.AllocationView -> ContractId V2.Allocation -> Allocation_Withdraw -> Update V2.AllocationResult +vestingLockWithdraw : (HasToInterface a V2.Allocation) => a -> ContractId a -> Allocation_Withdraw -> Update V2.AllocationResult +vestingLockWithdraw a aCid arg = do + let vestingLock = view $ toInterface @V2.Allocation a + vestingLockCid = toInterfaceContractId @V2.Allocation aCid + now <- getTime + + require "Must be a valid vesting unlock allocation" $ isValidVestingLockedDestination dso vestingLock + require "There must be an initialAmount set for the vestingLock" + $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values + + ownerParty <- whenNone vestingLock.allocation.authorizer.owner $ + assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" + let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta vestingLock.meta ownerParty + + checkControllerSet arg.actors withdrawControllerSets + + -- TODO: Potentially do case statement with nextIterationFunding optionals + require "There are remaining funds to withdraw" + $ isSome vestingLock.allocation.nextIterationFunding + + (instrumentId, nextIterationFunding) <- case TM.toList <$> vestingLock.allocation.nextIterationFunding of + Some [a] -> pure a + _ -> assertFail "The requirement 'Must reserve a single amount of a single token' was not met" + require "There must be an initialAmount set for the vestingLock" + $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values + + let (availableWithdrawAmount, remainingVestingAmount) : (Decimal, Decimal) = + calculateAvailableWithdrawAmount now vestingLock nextIterationFunding + + require ("Current eligible withdraw amount for vesting lock is not greater than 0.0. " + <> "currentEligibleWithdrawableAmount came back = '" + <> show availableWithdrawAmount + <> "'." + ) + $ availableWithdrawAmount > 0.0 + + let + info = SettlementInfo with + executors = [ vestingLock.allocation.admin ] + id = "VestingLock_Withdraw" + cid = Some $ coerceContractId vestingLockCid + meta = emptyMetadata + transferLegId = "withdraw" + nextIterationFunding + | remainingVestingAmount <= 0.0 = None + | otherwise = Some $ TM.singleton instrumentId remainingVestingAmount + + settleResult <- settlementFactoryV2_settleBatchDefaultImplNoSelf (\_ _ -> pure arg.extraArgs) vestingLock.allocation.admin $ SettlementFactory_SettleBatch with + settlement = info + actors = [ vestingLock.allocation.admin ] + extraArgs = ExtraArgs emptyChoiceContext emptyMetadata + transferLegs = + [ TransferLeg with + transferLegId + sender = vestingLock.allocation.authorizer + receiver = vestingLock.allocation.authorizer + amount = availableWithdrawAmount + instrumentId + meta = emptyMetadata + ] + allocations = + [ FinalizedAllocation with + allocationCid = vestingLockCid + extraTransferLegSides = + [ TransferLegSide with transferLegId - sender = locked.allocation.authorizer - receiver = withdrawTo.allocation.authorizer - amount + side = SenderSide + otherside = vestingLock.allocation.authorizer + amount = remainingVestingAmount instrumentId meta = emptyMetadata - ] - allocations = - [ FinalizedAllocation with - allocationCid = lockedCid - extraTransferLegSides = - [ TransferLegSide with - transferLegId - side = SenderSide - otherside = withdrawTo.allocation.authorizer - amount - instrumentId - meta = emptyMetadata - ] - nextIterationFunding = Some $ TM.singleton instrumentId newLockedAmount - , FinalizedAllocation with - allocationCid = withdrawToCid - extraTransferLegSides = - [ TransferLegSide with - transferLegId - side = ReceiverSide - otherside = locked.allocation.authorizer - amount - instrumentId - meta = emptyMetadata - ] - nextIterationFunding = Some $ TM.singleton instrumentId amount - ] - -- Note: Choice temporarily lives here and it will be moved, testing/draft purposes atm - nonconsuming choice VestingLock_Withdraw : AllocationResult - with - factoryCid : ContractId SettlementFactory - authorizers : [Party] - vestingLockCid : ContractId Allocation - extraArgs : ExtraArgs - where - controller authorizers - do - vestingLock <- view <$> fetchCheckedInterface (ForDso with dso) vestingLockCid - now <- getTime - ownerParty <- whenNone vestingLock.allocation.authorizer.owner $ - assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" - - require "Must be a valid vesting unlock allocation" $ isValidVestingLockedDestination dso vestingLock - require "There must be an initialAmount set for the vestingLock" - $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values - let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta vestingLock.meta ownerParty - require "Unlock controller must be one of the options" $ any (\conj -> all (`elem` authorizers) conj) unlockControllerSets - - let mNextIterationFunding = do - fundingMap <- vestingLock.allocation.nextIterationFunding - TM.lookup instrumentId fundingMap - - nextIterationFundingAmount <- case mNextIterationFunding of - None -> abort ("VestingLock's nextIterationFunding should have remaining funds to withdraw for instrumentId " <> show instrumentId) - Some amount -> pure amount - - let (availableWithdrawAmount, remainingVestingAmount) : (Decimal, Decimal) = - calculateAvailableWithdrawAmount now vestingLock nextIterationFundingAmount - - require ("Current eligible withdraw amount for vesting lock should be greater than 0.0. " - <> "currentEligibleWithdrawableAmount came back = '" - <> show availableWithdrawAmount - <> "'." - ) - $ availableWithdrawAmount > 0.0 - - let - info = SettlementInfo with - executors = [ dso ] - id = "AggregateLock" - cid = Some $ coerceContractId self - meta = emptyMetadata - transferLegId = "withdraw" - nextIterationFunding - | remainingVestingAmount <= 0.0 = None - | otherwise = Some $ TM.singleton instrumentId remainingVestingAmount - - batchResults <- exercise factoryCid $ SettlementFactory_SettleBatch with - settlement = info - actors = [ dso ] - extraArgs - transferLegs = - [ TransferLeg with + , TransferLegSide with transferLegId - sender = vestingLock.allocation.authorizer - receiver = vestingLock.allocation.authorizer + side = ReceiverSide + otherside = vestingLock.allocation.authorizer amount = availableWithdrawAmount instrumentId meta = emptyMetadata ] - allocations = - [ FinalizedAllocation with - allocationCid = vestingLockCid - extraTransferLegSides = - [ TransferLegSide with - transferLegId - side = SenderSide - otherside = vestingLock.allocation.authorizer - amount = availableWithdrawAmount - instrumentId - meta = emptyMetadata - , TransferLegSide with - transferLegId - side = ReceiverSide - otherside = vestingLock.allocation.authorizer - amount = availableWithdrawAmount - instrumentId - meta = emptyMetadata - ] - nextIterationFunding = nextIterationFunding - ] + nextIterationFunding + ] + + -- We should have one result from settleBatch + case batchResults.allocationSettleResults of + [allocationResult] -> pure allocationResult + _ -> abort "VestingUnlock_Withdraw should result in one allocation result. " + +-- Takes the choice metadata as well to enable override to allow quick unlock +decodeVestingSchedule : Metadata -> Metadata -> Update VestingSchedule +decodeVestingSchedule _withdrawMeta lockMeta = do + case TM.lookup "cip-105/vestingSchedule" lockMeta.values of + Some "SV" -> pure VestingSchedule_SV + _ -> assertFail "Must have a valid vesting schedule" - -- We should have one result from settleBatch - case batchResults.allocationSettleResults of - [allocationResult] -> pure allocationResult - _ -> abort "VestingUnlock_Withdraw should result in one allocation result. " diff --git a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml index 088455e03f..806dbd054b 100644 --- a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml +++ b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml @@ -23,6 +23,7 @@ import Splice.Api.Token.HoldingV2 qualified as V2 import Splice.Api.Token.AllocationV2 qualified as V2 import Splice.TokenStandard.Utils hiding (require) +import Splice.AggregateLock import Splice.Amulet import Splice.AmuletConfig (TransferConfigV2, getTokenStandardMaxTTL) import Splice.AmuletRules @@ -76,6 +77,8 @@ template AmuletAllocationV2 allocation_cancelExtraObservers _arg = observer this allocation_withdrawExtraObservers _arg = observer this + allocation_withdrawImpl self arg | isGovernanceLocked this = + governanceLockedWithdrawImpl emptyCloneWithMeta this (fromInterfaceContractId self) arg allocation_withdrawImpl self arg@(V2.Allocation_Withdraw{..}) = do archiveAndCheckActors self arg.actors [[accountPrincipal allocation.admin allocation.authorizer]] ensureWithdrawIsAllowed allocation @@ -230,14 +233,22 @@ computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline = | maxTime `subTime` oldExpiresAt <= maxTTL = maxTime | otherwise = oldExpiresAt `addRelTime` maxTTL --- FIXME: the exception to allow Some maxBound is for infinite-duration governance locks, and should probably be limited more explicitly to only those cases. +-- FIXME: the exception to allow Some maxTime is for infinite-duration governance locks, and should probably be limited more explicitly to only those cases. computeAllocationExpiry : TransferConfigV2 Amulet -> Time -> Optional Time -> Update Time -computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline | settlementDeadline == Some maxBound = pure maxBound +computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline | settlementDeadline == Some maxComparableTime = pure maxComparableTime computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline = do let expiresAt = computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline assertWithinDeadline "allocation.expiresAt" expiresAt pure expiresAt +isGovernanceLocked alloc = TextMap.member "cip-105/type" alloc.allocation.meta.values + +emptyCloneWithMeta : AmuletAllocationV2 -> Time -> Metadata -> Update (ContractId V2.Allocation) +emptyCloneWithMeta src now meta = toInterfaceContractId <$> create src with + lockedAmulet = None + createdAt = now + allocation = src.allocation with + meta -- instances ------------ diff --git a/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Allocations.daml b/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Allocations.daml index 9ce6ef72f6..2085a3ae4e 100644 --- a/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Allocations.daml +++ b/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Allocations.daml @@ -53,6 +53,7 @@ module Splice.TokenStandard.Utils.Internal.Allocations ( -- ** SettlementFactory template implementations settlementFactoryV2_settleBatchDefaultImpl, + settlementFactoryV2_settleBatchDefaultImplNoSelf, fetchAndValidateAllocations, validateNextIterationArgs, @@ -374,7 +375,18 @@ settlementFactoryV2_settleBatchDefaultImpl -> ContractId AllocationV2.SettlementFactory -> AllocationV2.SettlementFactory_SettleBatch -> Update AllocationV2.SettlementFactory_SettleBatchResult -settlementFactoryV2_settleBatchDefaultImpl getFilteredExtraArgs admin self arg = do +settlementFactoryV2_settleBatchDefaultImpl getFilteredExtraArgs admin self arg = + settlementFactoryV2_settleBatchDefaultImplNoSelf getFilteredExtraArgs admin arg + +settlementFactoryV2_settleBatchDefaultImplNoSelf + : (AllocationV2.AllocationView -> AllocationV2.Allocation_Settle -> Update ExtraArgs) + -- ^ Function to compute the actual extra argument to use for settling an allocation. + -- Use this for example to redact unrelated choice-context data from the extra arguments. + -> Party + -- ^ Admin of the allocations and the settlement factory + -> AllocationV2.SettlementFactory_SettleBatch + -> Update AllocationV2.SettlementFactory_SettleBatchResult +settlementFactoryV2_settleBatchDefaultImplNoSelf getFilteredExtraArgs admin arg = do let AllocationV2.SettlementFactory_SettleBatch {..} = arg checkActors actors [settlement.executors] diff --git a/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/Registries/AmuletRegistryV2.daml b/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/Registries/AmuletRegistryV2.daml index 04a7817fff..92492103db 100644 --- a/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/Registries/AmuletRegistryV2.daml +++ b/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/Registries/AmuletRegistryV2.daml @@ -30,6 +30,10 @@ module Splice.Testing.Registries.AmuletRegistryV2 , getActiveOpenRoundsSorted , advanceToNextRoundChange , convertAllFeaturedAppActivityMarkers + + -- + , getExtAmuletRulesWithDisclosures + , getExternalPartyConfigStateContext ) where import DA.Action (unless, when) From 8eb418b01100f58f4884a7e43c85d8c80778045a Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Tue, 28 Jul 2026 16:18:06 +0000 Subject: [PATCH 25/30] Fixes to rebase and update tests --- .../Splice/Scripts/TestAggregateLocks.daml | 335 ++++++++++-------- .../daml/Splice/AggregateLock.daml | 20 +- .../daml/Splice/AmuletAllocationV2.daml | 11 +- 3 files changed, 194 insertions(+), 172 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index 717a9e6a02..e46429c7d5 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -1,54 +1,31 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Splice.Scripts.TestAggregateLocks where +import DA.Assert +import DA.Optional import DA.Time +import qualified DA.Map as M +import qualified DA.TextMap as TM + import Daml.Script -import Splice.Amulet + import Splice.AggregateLock -import Splice.AmuletRules -import Splice.Expiry -import Splice.Scripts.Util -import Splice.TokenStandard.Utils qualified as TSU +import Splice.Api.Token.AllocationInstructionV2 +import Splice.Api.Token.AllocationV2 import Splice.Api.Token.AllocationV2 qualified as V2 import Splice.Api.Token.HoldingV2 qualified as V2 -import Splice.Testing.TokenStandard.RegistryApiV2 -import Splice.Testing.TokenStandard.WalletClientV2 qualified as WalletClientV2 -import Splice.Testing.Registries.AmuletRegistryV2 import Splice.Api.Token.MetadataV1 -import Splice.Api.Token.AllocationV2 -import Splice.Api.Token.AllocationInstructionV2 -import Splice.Api.Token.HoldingV2 -import Splice.AmuletAllocationV2 -import Splice.Testing.Utils - -import Splice.ExternalPartyAmuletRules - -import DA.Assert -import DA.Optional -import DA.Functor -import DA.Foldable (mapA_, sequence_) -import DA.List (head) -import qualified DA.TextMap as TM -import qualified DA.Map as M - import Splice.Scripts.TokenStandard.TestAmuletTokenStandardTestEnv +import Splice.Testing.Registries.AmuletRegistryV2 import Splice.Testing.Registries.AmuletRegistryV2 qualified as AmuletRegistryV2 +import Splice.Testing.TokenStandard.MultiRegistry qualified as MultiRegistry +import Splice.Testing.TokenStandard.RegistryApiV2 +import Splice.Testing.TokenStandard.WalletClientV2 qualified as WalletClientV2 +import Splice.Util.Token.Wallet.BatchingUtilityV2 qualified as BatchingUtilityV2 +import Splice.Testing.Utils +import Splice.TokenStandard.Utils qualified as TSU import Splice.TokenStandard.Utils.Internal.Conversions (encodeTime) -newtype AmuletRegistryExtraWithdrawContext = AmuletRegistryExtraWithdrawContext { unExtra : AmuletRegistry } - -instance RegistryApi AmuletRegistryExtraWithdrawContext where - getTransferFactory = getTransferFactory . unExtra - getAllocationFactory = getAllocationFactory . unExtra - getSettlementFactory = getSettlementFactory . unExtra - getAllocation_WithdrawContext = getAllocation_WithdrawContext . unExtra - getAllocation_CancelContext = getAllocation_CancelContext . unExtra - getAllocationInstruction_WithdrawContext = getAllocationInstruction_WithdrawContext . unExtra - getAllocationInstruction_AcceptContext = getAllocationInstruction_AcceptContext . unExtra - getTransferInstruction_AcceptContext = getTransferInstruction_AcceptContext . unExtra - getTransferInstruction_RejectContext = getTransferInstruction_RejectContext . unExtra - getTransferInstruction_WithdrawContext = getTransferInstruction_WithdrawContext . unExtra lockForGovernance : TestEnv -> TM.TextMap Decimal -> Metadata -> Party -> Script AllocationInstructionResult lockForGovernance (TestEnv {..}) amounts meta party = do @@ -57,14 +34,14 @@ lockForGovernance (TestEnv {..}) amounts meta party = do lockSettlementInfo = V2.SettlementInfo with executors = [ instrId.admin ] id = "AggregateLock" - cid = None -- Some $ coerceContractId aggCid + cid = None meta = emptyMetadata lockAllocation = V2.AllocationSpecification with admin = instrId.admin - authorizer = TSU.basicAccount bob + authorizer = TSU.basicAccount party transferLegSides = [] committed = True - nextIterationFunding = Some $ amounts -- TM.fromList [(instrId.id, amount)] + nextIterationFunding = Some amounts settlementDeadline = Some maxComparableTime meta @@ -75,140 +52,184 @@ lockForAggregate te amount lockName = lockForGovernance te (TM.fromList [(te.ins , ("cip-105/vestingSchedule", "SV") ] +-- | Directly create a vesting lock allocation funded with @initialAmount@, +-- bypassing the aggregate-lock unlock path. Used to exercise the vesting +-- withdrawal flow in isolation. lockForVesting : Decimal -> Time -> TestEnv -> Party -> Script AllocationInstructionResult -lockForVesting initialAmount now te = lockForGovernance te TM.empty $ Metadata $ TM.fromList - [ ("cip-105/type", "vestingLock") - , ("cip-105/vestingLock.startDate", encodeTime now) - , ("cip-105/vestingLock.endDate", encodeTime $ addRelTime now $ days 365 + hours 6) - , ("cip-105/vestingLock.initialAmount", show initialAmount) - ] +lockForVesting initialAmount now te = + lockForGovernance te (TM.fromList [(te.instrId.id, initialAmount)]) $ Metadata $ TM.fromList + [ ("cip-105/type", "vestingLock") + , ("cip-105/vestingLock.startDate", encodeTime now) + , ("cip-105/vestingLock.endDate", encodeTime $ addRelTime now $ days 365 + hours 6) + , ("cip-105/vestingLock.initialAmount", show initialAmount) + ] + +-- | Enrich the wallet-side withdraw context with the external party config +-- state disclosure, which AmuletAllocationV2's settle path reads when the +-- governance-lock withdraw fans out through the settlement factory. +withAggregateWithdrawContext : TestEnv -> MultiRegistry.MultiRegistry -> MultiRegistry.MultiRegistry +withAggregateWithdrawContext env registries = + flip fmap registries $ \reg -> + reg { v2Api = fmap updateApi reg.v2Api } + where + addContext a = do + baseCtxt <- a + extraContext <- getExternalPartyConfigStateContext env.registriesEnv.amuletV2 + pure $ baseCtxt <> extraContext + updateApi api = + api { ggetAllocation_WithdrawContext = \a -> addContext . api.ggetAllocation_WithdrawContext a } -testAggregateLockHappyPath : Script () -testAggregateLockHappyPath = do +-- | Verify that locking funds for a "for-benefit-of" name aggregates over +-- separate lock allocations sharing the same name. +testAggregateLockTotals : Script () +testAggregateLockTotals = do env@TestEnv{..} <- setupTest let dso = env.instrId.admin - let - addAggregateWithdrawContext : Script OpenApiChoiceContext -> Script OpenApiChoiceContext - addAggregateWithdrawContext a = do - baseCtxt <- a - extraContext <- getExternalPartyConfigStateContext registriesEnv.amuletV2 - pure $ baseCtxt <> extraContext - updateApi api = api { ggetAllocation_WithdrawContext = \a -> addAggregateWithdrawContext . api.ggetAllocation_WithdrawContext a } - newRegistries = flip fmap registries $ \reg -> - reg { v2Api = fmap updateApi reg.v2Api } - AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 - - {- - aggLock <- submit (actAs [alice, dso]) $ createCmd AggregateLock with - dso - instrumentId = env.instrId.id - vestingSchedule = VestingSchedule_SV - -- Some aggLockDisclosure <- queryDisclosure dso aggLock - -} - - -- Lock some funds for the aggregate - AllocationInstructionResult { output = AllocationInstructionResult_Completed locked } <- lockForAggregate env 1000.0 "alice-supervalidator" bob - Some lockedView <- queryInterfaceContractId bob locked + _ <- lockForAggregate env 400.0 "alice-supervalidator" bob + _ <- lockForAggregate env 600.0 "alice-supervalidator" bob + _ <- lockForAggregate env 300.0 "charlie-supervalidator" bob allocs <- queryInterface @V2.Allocation dso - let filtered = filter (isValidAggregateLockedAllocation dso) $ fromSome . snd <$> allocs - toKeyAndAmount alloc = ("cip-105/for-benefit-of" `TM.lookup` alloc.allocation.meta.values, fromOptional 0.0 $ alloc.allocation.nextIterationFunding >>= TM.lookup env.instrId.id) - totals = M.fromListWith (+) $ toKeyAndAmount <$> filtered + let aggregateLocks = + filter (isValidAggregateLockedAllocation dso) $ fromSome . snd <$> allocs + benefitOfAmount alloc = + ( "cip-105/for-benefit-of" `TM.lookup` alloc.allocation.meta.values + , fromOptional 0.0 $ alloc.allocation.nextIterationFunding >>= TM.lookup env.instrId.id + ) + totals = M.fromListWithR (+) $ benefitOfAmount <$> aggregateLocks assertEq (Some 1000.0) (Some "alice-supervalidator" `M.lookup` totals) - - WalletClientV2.withdrawAllocationV2 newRegistries bob (locked, lockedView) - - let bobAcct = V2.Account with - owner = Some bob - provider = Some dso - id = "" - - allocs <- WalletClientV2.listAllocationsV2 bobAcct bob - - -- unlockResult <- WalletClientV2.withdrawAllocationV2 newRegistries bob $ head allocs - - pure () - - {- - - now <- getTime - let initialAmountToUnlock = 365.25 - AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingInput } <- lockForVesting initialAmountToUnlock now env bob aggLock - - -- use getSettlementFactory to get the extraArgs and disclosures to call AggregateLock_Unlock - enriched <- getSettlementFactory registriesEnv.amuletV2 $ SettlementFactory_SettleBatch with - settlement = SettlementInfo with - executors = [ dso ] - id = "AggregateLock" - cid = None - meta = emptyMetadata - actors = [ dso ] - extraArgs = emptyExtraArgs - transferLegs = [] - allocations = [] + assertEq (Some 300.0) (Some "charlie-supervalidator" `M.lookup` totals) - submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ AggregateLock_Unlock with - factoryCid = enriched.factoryCid - lockedCid = locked - withdrawToCid = vestingInput - authorizers = [ bob ] - amount = initialAmountToUnlock - extraArgs = enriched.arg.extraArgs +-- | Withdrawing an aggregate-lock allocation moves the locked funds into a +-- fresh vesting-lock destination for the same owner. +testAggregateLockUnlockCreatesVestingLock : Script () +testAggregateLockUnlockCreatesVestingLock = do + env@TestEnv{..} <- setupTest + let dso = env.instrId.admin + newRegistries = withAggregateWithdrawContext env registries - allocations <- query @AmuletAllocationV2 bob + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 + AllocationInstructionResult { output = AllocationInstructionResult_Completed locked } <- + lockForAggregate env 1000.0 "alice-supervalidator" bob + Some lockedView <- queryInterfaceContractId bob locked - assert $ length allocations == 2 + _ <- WalletClientV2.withdrawAllocationV2 newRegistries bob (locked, lockedView) + + liveAllocs <- fmap (fromSome . snd) . filter (isSome . snd) <$> + queryInterface @V2.Allocation bob + length liveAllocs === 2 + + let aggregates = filter (isValidAggregateLockedAllocation dso) liveAllocs + vestings = filter (isValidVestingLockedDestination dso) liveAllocs + length aggregates === 1 + length vestings === 1 + + let [aggregate] = aggregates + [vesting] = vestings + fromOptional 0.0 (aggregate.allocation.nextIterationFunding >>= TM.lookup instrId.id) === 0.0 + fromOptional 0.0 (vesting.allocation.nextIterationFunding >>= TM.lookup instrId.id) === 1000.0 + + -- Metadata carried over correctly: same owner and DSO on both sides. + aggregate.allocation.authorizer === vesting.allocation.authorizer + aggregate.allocation.admin === vesting.allocation.admin + + -- The vesting destination records its start/end dates. + assertMsg "vesting destination must record startDate" $ + TM.member "cip-105/vestingLock.startDate" vesting.allocation.meta.values + assertMsg "vesting destination must record endDate" $ + TM.member "cip-105/vestingLock.endDate" vesting.allocation.meta.values + +-- | Withdrawing from a vesting-lock allocation vests funds linearly over the +-- lock's start/end period. This exercises the flow against a vesting lock +-- created directly by 'lockForVesting'; the round-trip through +-- 'aggregateLockUnlock' + 'vestingLockWithdraw' isn't tested here because +-- 'aggregateLockUnlock' doesn't (yet) populate the destination's +-- @cip-105/vestingLock.initialAmount@ metadata. +testVestingLockWithdraw : Script () +testVestingLockWithdraw = do + env@TestEnv{..} <- setupTest + let newRegistries = withAggregateWithdrawContext env registries + initialAmount = 365.25 -- one unit per day of the 365 day + 6 hour vesting period - -- Need to check other than via inspection that the two allocations actually exist with correct values. - -} + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 - -- TODO: Temporary, bad to do this - let vestingLockAllocationCid = head [cid | (cid, a) <- allocations, TM.member "cip-105/vestingLock.initialAmount" a.allocation.meta.values] + vestStart <- getTime + AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingLockCid } <- + lockForVesting initialAmount vestStart env bob + Some vestingLockView <- queryInterfaceContractId bob vestingLockCid - -- Immediate withdraw attempt causes transaction to fail due to the current - -- eligible withdraw amount being zero (no time has passed since locking yet) - submitMustFail (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with - factoryCid = enriched.factoryCid - authorizers = [ bob ] - vestingLockCid = toInterfaceContractId vestingLockAllocationCid - extraArgs = enriched.arg.extraArgs + -- Withdrawing immediately fails: nothing has vested yet. + vestingLockView.allocation.admin `submitMustFailWithdraw` (vestingLockCid, vestingLockView) $ newRegistries - -- Time needs to pass to be able to withdraw from the VestingLock + -- After some time passes a proportional amount can be withdrawn. passTime (days 10) + vestingResult1 <- extractAllocationResult <$> + WalletClientV2.withdrawAllocationV2 newRegistries bob (vestingLockCid, vestingLockView) + + let holdingCids1 = fromSome $ TM.lookup instrId.id vestingResult1.authorizerHoldingCids + amount1 <- unlockedAmountOf bob holdingCids1 + amount1 === 10.0000000105 + + -- The vesting-lock is settled iteratively, so a new allocation contract + -- carries the remaining vesting balance. + case vestingResult1.output of + AllocationResult_Settled { nextIterationAllocationCid = Some nextCid } -> do + -- After the full period has elapsed the remainder becomes withdrawable. + passTime (days 365) + Some nextView <- queryInterfaceContractId bob nextCid + vestingResult2 <- extractAllocationResult <$> + WalletClientV2.withdrawAllocationV2 newRegistries bob (nextCid, nextView) + + let holdingCids2 = fromSome $ TM.lookup instrId.id vestingResult2.authorizerHoldingCids + amount2 <- unlockedAmountOf bob holdingCids2 + amount1 + amount2 === initialAmount + other -> + fail $ "expected AllocationResult_Settled with a next-iteration allocation, got: " <> show other + +-- | Attempt an @Allocation_Withdraw@ that should fail; asserts the submit +-- fails and does not leak the underlying error. +submitMustFailWithdraw + : Party -- ^ admin party (needed to read the enriched choice context) + -> (ContractId V2.Allocation, V2.AllocationView) + -> MultiRegistry.MultiRegistry + -> Script () +submitMustFailWithdraw admin (allocCid, _allocView) registries = do + registry <- MultiRegistry.getRegistryApiV2 registries admin + context <- getAllocation_WithdrawContext registry allocCid emptyMetadata + Some owner <- pure =<< + fmap ((.allocation.authorizer.owner) . fromSome) (queryInterfaceContractId admin allocCid) + submitMustFail (actAs owner <> discloseMany' context.disclosures) $ + exerciseCmd allocCid V2.Allocation_Withdraw with + actors = [owner] + extraArgs = ExtraArgs with + context = context.choiceContext + meta = emptyMetadata + +-- | Extract the underlying @AllocationResult@ from a wallet-client batch result. +extractAllocationResult : BatchingUtilityV2.TokenStandardActionResult -> V2.AllocationResult +extractAllocationResult (BatchingUtilityV2.TSAR_AllocationResultV2 r) = r +extractAllocationResult other = + error $ "expected TSAR_AllocationResultV2, got: " <> show other + +-- | Sum the amounts of the given (unlocked) holding contracts owned by @p@. +unlockedAmountOf : Party -> [ContractId V2.Holding] -> Script Decimal +unlockedAmountOf p wantedCids = do + holdings <- queryInterface @V2.Holding p + let matching = + [ h + | (cid, Some h) <- holdings + , cid `elem` wantedCids + , isNone h.lock + ] + pure $ sum (fmap (.amount) matching) - (AllocationResult vestingAllocResult tmHoldingCids _) <- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with - factoryCid = enriched.factoryCid - authorizers = [ bob ] - vestingLockCid = toInterfaceContractId vestingLockAllocationCid - extraArgs = enriched.arg.extraArgs - - let holdingCids = fromSome $ TM.lookup env.instrId.id tmHoldingCids - holdings <- queryInterface @Holding bob - -- The holdings would include both locked/unlocked, so we filter - let [(_, (Some unlockedHolding))] = filter (\(hcid, (Some h)) -> isNone h.lock && hcid `elem` holdingCids) holdings - - assertEq unlockedHolding.amount 10.0000000105 - - -- Let's try to withdraw the rest (now we should be past endDate) - passTime (days 365) - - (AllocationResult vestingAllocResult' tmHoldingCids' _) <- submit (actAs bob <> disclose aggLockDisclosure <> discloseMany' enriched.disclosures ) $ exerciseCmd aggLock $ VestingLock_Withdraw with - factoryCid = enriched.factoryCid - authorizers = [ bob ] - vestingLockCid = fromSome $ vestingAllocResult.nextIterationAllocationCid - extraArgs = enriched.arg.extraArgs - - -- We should have no more remaining amount vesting, once the full period has passed - assertEq None $ vestingAllocResult'.nextIterationAllocationCid - - let holdingCids' = fromSome $ TM.lookup env.instrId.id tmHoldingCids' - holdings' <- queryInterface @Holding bob - -- The holdings would include both locked/unlocked, so we filter - let [(_, (Some unlockedHolding'))] = filter (\(hcid, (Some h)) -> isNone h.lock && hcid `elem` holdingCids') holdings' - - assertEq initialAmountToUnlock $ unlockedHolding.amount + unlockedHolding'.amount +testAggregateLockHappyPath : Script () +testAggregateLockHappyPath = do + testAggregateLockTotals + testAggregateLockUnlockCreatesVestingLock + testVestingLockWithdraw diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index fed0fc6d3f..b0d1e30670 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -35,7 +35,7 @@ isValidVestingLockedDestination dso alloc = , alloc.allocation.committed , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "vestingLock" - , alloc.expiresAt == Some maxTime + , alloc.expiresAt == Some maxComparableTime , TM.member "cip-105/vestingLock.startDate" metaValues , TM.member "cip-105/vestingLock.endDate" metaValues ] @@ -138,7 +138,7 @@ aggregateLockUnlock : (HasToInterface a V2.Allocation) => (a -> Time -> Metadata aggregateLockUnlock newEmptyAllocation a aCid arg = do let alloc = view $ toInterface @V2.Allocation a allocCid = toInterfaceContractId @V2.Allocation aCid - + (instrumentId, currentLockedAmount) <- case TM.toList <$> alloc.allocation.nextIterationFunding of Some [a] -> pure a _ -> assertFail "The requirement 'Must reserve a single amount of a single token' was not met" @@ -152,24 +152,24 @@ aggregateLockUnlock newEmptyAllocation a aCid arg = do let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta alloc.meta ownerParty checkControllerSet arg.actors unlockControllerSets - + require "Must be a valid governance-locked allocation" $ isValidAggregateLockedAllocation dso alloc now <- getTime let endTime = getEndTimeFromVestingSchedule vestingSchedule now transferLegId = "unlock" - + let alternateAmount = TM.lookup "cip-105/withdraw-amount" arg.extraArgs.meta.values >>= parseDecimal amount = fromOptional currentLockedAmount alternateAmount newLockedAmount = currentLockedAmount - amount - + -- Not easy to call directly into amulet_allocationFactoryV2_allocateImpl or the like here as that would make a circular dependency. withdrawTo <- newEmptyAllocation a now $ Metadata $ TM.fromList [ ("cip-105/type", "vestingLock") , ("cip-105/vestingLock.startDate", encodeTime $ now) , ("cip-105/vestingLock.endDate", encodeTime $ endTime) ] - + -- settlementFactoryV2_settleBatchDefaultImpl does not use it's third argument, so we pass undefined rather than require a contract ID for ExternalPartyAmuletRules. settleBatchResult <- settlementFactoryV2_settleBatchDefaultImplNoSelf (\_ _ -> pure arg.extraArgs) dso $ SettlementFactory_SettleBatch with settlement = alloc.settlement @@ -221,8 +221,8 @@ vestingLockWithdraw a aCid arg = do let vestingLock = view $ toInterface @V2.Allocation a vestingLockCid = toInterfaceContractId @V2.Allocation aCid now <- getTime - - require "Must be a valid vesting unlock allocation" $ isValidVestingLockedDestination dso vestingLock + + require "Must be a valid vesting unlock allocation" $ isValidVestingLockedDestination vestingLock.allocation.admin vestingLock require "There must be an initialAmount set for the vestingLock" $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values @@ -298,8 +298,8 @@ vestingLockWithdraw a aCid arg = do nextIterationFunding ] - -- We should have one result from settleBatch - case batchResults.allocationSettleResults of + -- We should have one result from settleBatch + case settleResult.allocationSettleResults of [allocationResult] -> pure allocationResult _ -> abort "VestingUnlock_Withdraw should result in one allocation result. " diff --git a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml index 806dbd054b..aefff68139 100644 --- a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml +++ b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml @@ -235,11 +235,12 @@ computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline = -- FIXME: the exception to allow Some maxTime is for infinite-duration governance locks, and should probably be limited more explicitly to only those cases. computeAllocationExpiry : TransferConfigV2 Amulet -> Time -> Optional Time -> Update Time -computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline | settlementDeadline == Some maxComparableTime = pure maxComparableTime -computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline = do - let expiresAt = computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline - assertWithinDeadline "allocation.expiresAt" expiresAt - pure expiresAt +computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline + | settlementDeadline == Some maxComparableTime = pure maxComparableTime + | otherwise = do + let expiresAt = computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline + assertWithinDeadline "allocation.expiresAt" expiresAt + pure expiresAt isGovernanceLocked alloc = TextMap.member "cip-105/type" alloc.allocation.meta.values From eb0b131cb18d0a78b7227aa5b48e90ca587c71d9 Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Tue, 28 Jul 2026 17:35:57 +0000 Subject: [PATCH 26/30] Fix tests and a couple bugs in vesting withdraw. --- .../daml/Splice/Scripts/TestAggregateLocks.daml | 17 ++--------------- .../daml/Splice/AggregateLock.daml | 9 ++------- .../Testing/TokenStandard/WalletClientV2.daml | 7 +++++++ 3 files changed, 11 insertions(+), 22 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index e46429c7d5..effb4c0831 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -21,7 +21,6 @@ import Splice.Testing.Registries.AmuletRegistryV2 qualified as AmuletRegistryV2 import Splice.Testing.TokenStandard.MultiRegistry qualified as MultiRegistry import Splice.Testing.TokenStandard.RegistryApiV2 import Splice.Testing.TokenStandard.WalletClientV2 qualified as WalletClientV2 -import Splice.Util.Token.Wallet.BatchingUtilityV2 qualified as BatchingUtilityV2 import Splice.Testing.Utils import Splice.TokenStandard.Utils qualified as TSU import Splice.TokenStandard.Utils.Internal.Conversions (encodeTime) @@ -168,7 +167,7 @@ testVestingLockWithdraw = do -- After some time passes a proportional amount can be withdrawn. passTime (days 10) - vestingResult1 <- extractAllocationResult <$> + vestingResult1 <- WalletClientV2.extractAllocationResult <$> WalletClientV2.withdrawAllocationV2 newRegistries bob (vestingLockCid, vestingLockView) let holdingCids1 = fromSome $ TM.lookup instrId.id vestingResult1.authorizerHoldingCids @@ -182,7 +181,7 @@ testVestingLockWithdraw = do -- After the full period has elapsed the remainder becomes withdrawable. passTime (days 365) Some nextView <- queryInterfaceContractId bob nextCid - vestingResult2 <- extractAllocationResult <$> + vestingResult2 <- WalletClientV2.extractAllocationResult <$> WalletClientV2.withdrawAllocationV2 newRegistries bob (nextCid, nextView) let holdingCids2 = fromSome $ TM.lookup instrId.id vestingResult2.authorizerHoldingCids @@ -210,12 +209,6 @@ submitMustFailWithdraw admin (allocCid, _allocView) registries = do context = context.choiceContext meta = emptyMetadata --- | Extract the underlying @AllocationResult@ from a wallet-client batch result. -extractAllocationResult : BatchingUtilityV2.TokenStandardActionResult -> V2.AllocationResult -extractAllocationResult (BatchingUtilityV2.TSAR_AllocationResultV2 r) = r -extractAllocationResult other = - error $ "expected TSAR_AllocationResultV2, got: " <> show other - -- | Sum the amounts of the given (unlocked) holding contracts owned by @p@. unlockedAmountOf : Party -> [ContractId V2.Holding] -> Script Decimal unlockedAmountOf p wantedCids = do @@ -227,9 +220,3 @@ unlockedAmountOf p wantedCids = do , isNone h.lock ] pure $ sum (fmap (.amount) matching) - -testAggregateLockHappyPath : Script () -testAggregateLockHappyPath = do - testAggregateLockTotals - testAggregateLockUnlockCreatesVestingLock - testVestingLockWithdraw diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index b0d1e30670..1f9ec277c8 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -253,18 +253,13 @@ vestingLockWithdraw a aCid arg = do $ availableWithdrawAmount > 0.0 let - info = SettlementInfo with - executors = [ vestingLock.allocation.admin ] - id = "VestingLock_Withdraw" - cid = Some $ coerceContractId vestingLockCid - meta = emptyMetadata transferLegId = "withdraw" nextIterationFunding | remainingVestingAmount <= 0.0 = None | otherwise = Some $ TM.singleton instrumentId remainingVestingAmount settleResult <- settlementFactoryV2_settleBatchDefaultImplNoSelf (\_ _ -> pure arg.extraArgs) vestingLock.allocation.admin $ SettlementFactory_SettleBatch with - settlement = info + settlement = vestingLock.settlement actors = [ vestingLock.allocation.admin ] extraArgs = ExtraArgs emptyChoiceContext emptyMetadata transferLegs = @@ -284,7 +279,7 @@ vestingLockWithdraw a aCid arg = do transferLegId side = SenderSide otherside = vestingLock.allocation.authorizer - amount = remainingVestingAmount + amount = availableWithdrawAmount instrumentId meta = emptyMetadata , TransferLegSide with diff --git a/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml b/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml index 1327fc43e7..811786435e 100644 --- a/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml +++ b/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml @@ -73,6 +73,7 @@ module Splice.Testing.TokenStandard.WalletClientV2 -- ** Allocations extractNextIterationAllocationCid, + extractAllocationResult, mkAllocationFactory_AllocateV2, mkAllocationInstruction_AcceptV2, @@ -469,6 +470,12 @@ withdrawAllocationV2 registries actor alloc = do batch <- mkAllocation_WithdrawV2 registries actor alloc executeSingletonTSABatch registries actor batch +-- | Extract the underlying @AllocationResult@ from a wallet-client batch result. +extractAllocationResult : BatchingUtilityV2.TokenStandardActionResult -> V2.AllocationResult +extractAllocationResult (BatchingUtilityV2.TSAR_AllocationResultV2 r) = r +extractAllocationResult other = + error $ "expected TSAR_AllocationResultV2, got: " <> show other + -- | Simulate a V2 wallet withdrawing an allocation from a V1 app. withdrawAllocationV1 : MultiRegistry.MultiRegistry -> Party -> (ContractId V1.Allocation, V1.AllocationView) From 032d059b99c9aa7aef079cdfa70d5084cc0d65a7 Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Tue, 28 Jul 2026 20:21:53 +0000 Subject: [PATCH 27/30] Fixes and test updates. --- .../Splice/Scripts/TestAggregateLocks.daml | 73 ++++++++++++++++++- .../daml/Splice/AggregateLock.daml | 15 ++-- .../Testing/TokenStandard/WalletClientV2.daml | 16 +++- 3 files changed, 90 insertions(+), 14 deletions(-) diff --git a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml index effb4c0831..43fc641f00 100644 --- a/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -85,8 +85,10 @@ testAggregateLockTotals = do env@TestEnv{..} <- setupTest let dso = env.instrId.admin + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 alice 1200.0 AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 + _ <- lockForAggregate env 300.0 "alice-supervalidator" alice _ <- lockForAggregate env 400.0 "alice-supervalidator" bob _ <- lockForAggregate env 600.0 "alice-supervalidator" bob _ <- lockForAggregate env 300.0 "charlie-supervalidator" bob @@ -100,7 +102,7 @@ testAggregateLockTotals = do ) totals = M.fromListWithR (+) $ benefitOfAmount <$> aggregateLocks - assertEq (Some 1000.0) (Some "alice-supervalidator" `M.lookup` totals) + assertEq (Some 1300.0) (Some "alice-supervalidator" `M.lookup` totals) assertEq (Some 300.0) (Some "charlie-supervalidator" `M.lookup` totals) -- | Withdrawing an aggregate-lock allocation moves the locked funds into a @@ -119,19 +121,55 @@ testAggregateLockUnlockCreatesVestingLock = do _ <- WalletClientV2.withdrawAllocationV2 newRegistries bob (locked, lockedView) + liveAllocs <- fmap (fromSome . snd) . filter (isSome . snd) <$> + queryInterface @V2.Allocation bob + length liveAllocs === 1 + + let aggregates = filter (isValidAggregateLockedAllocation dso) liveAllocs + vestings = filter (isValidVestingLockedDestination dso) liveAllocs + + length aggregates === 0 + length vestings === 1 + + let [vesting] = vestings + fromOptional 0.0 (vesting.allocation.nextIterationFunding >>= TM.lookup instrId.id) === 1000.0 + + -- The vesting destination records its start/end dates. + assertMsg "vesting destination must record startDate" $ + TM.member "cip-105/vestingLock.startDate" vesting.allocation.meta.values + assertMsg "vesting destination must record endDate" $ + TM.member "cip-105/vestingLock.endDate" vesting.allocation.meta.values + +-- | Partially withdrawing an aggregate-lock allocation moves only that amount +-- of the locked funds into a fresh vesting-lock destination for the same owner. +testAggregateLockPartialWithdraw : Script () +testAggregateLockPartialWithdraw = do + env@TestEnv{..} <- setupTest + let dso = env.instrId.admin + newRegistries = withAggregateWithdrawContext env registries + + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 + + AllocationInstructionResult { output = AllocationInstructionResult_Completed locked } <- + lockForAggregate env 1000.0 "alice-supervalidator" bob + Some lockedView <- queryInterfaceContractId bob locked + + _ <- WalletClientV2.withdrawAllocationV2Meta newRegistries bob (locked, lockedView) $ Metadata $ TM.singleton "cip-105/withdraw-amount" "500.0" + liveAllocs <- fmap (fromSome . snd) . filter (isSome . snd) <$> queryInterface @V2.Allocation bob length liveAllocs === 2 let aggregates = filter (isValidAggregateLockedAllocation dso) liveAllocs vestings = filter (isValidVestingLockedDestination dso) liveAllocs + length aggregates === 1 length vestings === 1 let [aggregate] = aggregates [vesting] = vestings - fromOptional 0.0 (aggregate.allocation.nextIterationFunding >>= TM.lookup instrId.id) === 0.0 - fromOptional 0.0 (vesting.allocation.nextIterationFunding >>= TM.lookup instrId.id) === 1000.0 + fromOptional 0.0 (aggregate.allocation.nextIterationFunding >>= TM.lookup instrId.id) === 500.0 + fromOptional 0.0 (vesting.allocation.nextIterationFunding >>= TM.lookup instrId.id) === 500.0 -- Metadata carried over correctly: same owner and DSO on both sides. aggregate.allocation.authorizer === vesting.allocation.authorizer @@ -190,6 +228,35 @@ testVestingLockWithdraw = do other -> fail $ "expected AllocationResult_Settled with a next-iteration allocation, got: " <> show other +testVestingLockTotalWithdraw : Script () +testVestingLockTotalWithdraw = do + env@TestEnv{..} <- setupTest + let newRegistries = withAggregateWithdrawContext env registries + initialAmount = 365.25 -- one unit per day of the 365 day + 6 hour vesting period + + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 + + vestStart <- getTime + AllocationInstructionResult { output = AllocationInstructionResult_Completed vestingLockCid } <- + lockForVesting initialAmount vestStart env bob + Some vestingLockView <- queryInterfaceContractId bob vestingLockCid + + -- Withdrawing immediately fails: nothing has vested yet. + vestingLockView.allocation.admin `submitMustFailWithdraw` (vestingLockCid, vestingLockView) $ newRegistries + + -- After some time passes a proportional amount can be withdrawn. + passTime (days 366) + vestingResult1 <- WalletClientV2.extractAllocationResult <$> + WalletClientV2.withdrawAllocationV2 newRegistries bob (vestingLockCid, vestingLockView) + + let holdingCids1 = fromSome $ TM.lookup instrId.id vestingResult1.authorizerHoldingCids + amount1 <- unlockedAmountOf bob holdingCids1 + amount1 === 365.25 + + liveAllocs <- fmap (fromSome . snd) . filter (isSome . snd) <$> + queryInterface @V2.Allocation bob + length liveAllocs === 0 + -- | Attempt an @Allocation_Withdraw@ that should fail; asserts the submit -- fails and does not leak the underlying error. submitMustFailWithdraw diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 1f9ec277c8..fcf303fa04 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -147,7 +147,7 @@ aggregateLockUnlock newEmptyAllocation a aCid arg = do let dso = alloc.allocation.admin - ownerParty <- whenNone alloc.allocation.authorizer.owner $ + ownerParty <- whenNone alloc.allocation.authorizer.owner $ -- Mostly to safely get ownerParty assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta alloc.meta ownerParty @@ -162,6 +162,9 @@ aggregateLockUnlock newEmptyAllocation a aCid arg = do let alternateAmount = TM.lookup "cip-105/withdraw-amount" arg.extraArgs.meta.values >>= parseDecimal amount = fromOptional currentLockedAmount alternateAmount newLockedAmount = currentLockedAmount - amount + newLockedNextIterationFunding + | newLockedAmount == 0.0 = None + | otherwise = Some $ TM.singleton instrumentId newLockedAmount -- Not easy to call directly into amulet_allocationFactoryV2_allocateImpl or the like here as that would make a circular dependency. withdrawTo <- newEmptyAllocation a now $ Metadata $ TM.fromList @@ -170,7 +173,6 @@ aggregateLockUnlock newEmptyAllocation a aCid arg = do , ("cip-105/vestingLock.endDate", encodeTime $ endTime) ] - -- settlementFactoryV2_settleBatchDefaultImpl does not use it's third argument, so we pass undefined rather than require a contract ID for ExternalPartyAmuletRules. settleBatchResult <- settlementFactoryV2_settleBatchDefaultImplNoSelf (\_ _ -> pure arg.extraArgs) dso $ SettlementFactory_SettleBatch with settlement = alloc.settlement actors = [ dso ] @@ -196,7 +198,7 @@ aggregateLockUnlock newEmptyAllocation a aCid arg = do instrumentId meta = emptyMetadata ] - nextIterationFunding = Some $ TM.singleton instrumentId newLockedAmount + nextIterationFunding = newLockedNextIterationFunding , FinalizedAllocation with allocationCid = withdrawTo extraTransferLegSides = @@ -215,7 +217,6 @@ aggregateLockUnlock newEmptyAllocation a aCid arg = do getEndTimeFromVestingSchedule VestingSchedule_SV now = addRelTime now $ days 365 + hours 6 getEndTimeFromVestingSchedule VestingSchedule_Immediate now = now --- vestingLockWithdraw : V2.AllocationView -> ContractId V2.Allocation -> Allocation_Withdraw -> Update V2.AllocationResult vestingLockWithdraw : (HasToInterface a V2.Allocation) => a -> ContractId a -> Allocation_Withdraw -> Update V2.AllocationResult vestingLockWithdraw a aCid arg = do let vestingLock = view $ toInterface @V2.Allocation a @@ -226,16 +227,12 @@ vestingLockWithdraw a aCid arg = do require "There must be an initialAmount set for the vestingLock" $ TM.member "cip-105/vestingLock.initialAmount" vestingLock.allocation.meta.values - ownerParty <- whenNone vestingLock.allocation.authorizer.owner $ + ownerParty <- whenNone vestingLock.allocation.authorizer.owner $ -- Mostly to safely get ownerParty assertFail "The requirement 'governance locked allocations must be owned by basic accounts' was not met" let GovernanceLockedControllers{..} = governanceLockedControllersFromMeta vestingLock.meta ownerParty checkControllerSet arg.actors withdrawControllerSets - -- TODO: Potentially do case statement with nextIterationFunding optionals - require "There are remaining funds to withdraw" - $ isSome vestingLock.allocation.nextIterationFunding - (instrumentId, nextIterationFunding) <- case TM.toList <$> vestingLock.allocation.nextIterationFunding of Some [a] -> pure a _ -> assertFail "The requirement 'Must reserve a single amount of a single token' was not met" diff --git a/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml b/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml index 811786435e..d15c0d0010 100644 --- a/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml +++ b/token-standard/splice-token-standard-v2-test/daml/Splice/Testing/TokenStandard/WalletClientV2.daml @@ -55,6 +55,7 @@ module Splice.Testing.TokenStandard.WalletClientV2 acceptAllocationInstructionV2, withdrawAllocationInstructionV2, withdrawAllocationV2, + withdrawAllocationV2Meta, allocateV1, withdrawAllocationInstructionV1, @@ -470,6 +471,14 @@ withdrawAllocationV2 registries actor alloc = do batch <- mkAllocation_WithdrawV2 registries actor alloc executeSingletonTSABatch registries actor batch +-- | Simulate a V2 wallet withdrawing an allocation from a V2 app, with extra metadata +withdrawAllocationV2Meta + : MultiRegistry.MultiRegistry -> Party -> (ContractId V2.Allocation, V2.AllocationView) -> Metadata + -> Script BatchingUtilityV2.TokenStandardActionResult +withdrawAllocationV2Meta registries actor alloc meta = do + batch <- mkAllocation_WithdrawV2Meta registries actor alloc meta + executeSingletonTSABatch registries actor batch + -- | Extract the underlying @AllocationResult@ from a wallet-client batch result. extractAllocationResult : BatchingUtilityV2.TokenStandardActionResult -> V2.AllocationResult extractAllocationResult (BatchingUtilityV2.TSAR_AllocationResultV2 r) = r @@ -819,7 +828,10 @@ mkAllocationFactory_AllocateV2 registryV2 actor settlement allocation = do disclosures = enrichedChoice.disclosures mkAllocation_WithdrawV2 : MultiRegistry.MultiRegistry -> Party -> (ContractId V2.Allocation, V2.AllocationView) -> Script TSABatch -mkAllocation_WithdrawV2 registries actor (allocCid, allocView) = do +mkAllocation_WithdrawV2 registries actor (allocCid, allocView) = mkAllocation_WithdrawV2Meta registries actor (allocCid, allocView) emptyMetadata + +mkAllocation_WithdrawV2Meta : MultiRegistry.MultiRegistry -> Party -> (ContractId V2.Allocation, V2.AllocationView) -> Metadata -> Script TSABatch +mkAllocation_WithdrawV2Meta registries actor (allocCid, allocView) meta = do registry <- MultiRegistry.getRegistryApiV2 registries allocView.allocation.admin context <- V2.getAllocation_WithdrawContext registry allocCid emptyMetadata let withdrawRequest = BatchingUtilityV2.TSA_Allocation_WithdrawV2 BatchingUtilityV2.ChoiceCall with @@ -827,7 +839,7 @@ mkAllocation_WithdrawV2 registries actor (allocCid, allocView) = do arg = V2.Allocation_Withdraw with extraArgs = ExtraArgs with context = context.choiceContext - meta = emptyMetadata + meta actors = [actor] pure TSABatch with actions = [withdrawRequest] From fee0bda07e85b9c0709083c0d776ddfc85d6aa1c Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Wed, 29 Jul 2026 13:29:27 +0000 Subject: [PATCH 28/30] Check executors in isValid checks. --- daml/splice-amulet/daml/Splice/AggregateLock.daml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index fcf303fa04..976a08dbc6 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -23,6 +23,7 @@ maxComparableTime = addRelTime maxTime $ microseconds (-1) isValidAggregateLockedAllocation : Party -> V2.AllocationView -> Bool isValidAggregateLockedAllocation dso alloc = and [ alloc.allocation.admin == dso + , alloc.settlement.executors == [dso] , alloc.allocation.committed , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "aggregateLock" @@ -32,6 +33,7 @@ isValidAggregateLockedAllocation dso alloc = isValidVestingLockedDestination : Party -> V2.AllocationView -> Bool isValidVestingLockedDestination dso alloc = and [ alloc.allocation.admin == dso + , alloc.settlement.executors == [dso] , alloc.allocation.committed , null alloc.allocation.transferLegSides , TM.lookup "cip-105/type" alloc.allocation.meta.values == Some "vestingLock" From ae4421a9ee7db723162029373aa3e01fed12faa1 Mon Sep 17 00:00:00 2001 From: "Jonathan D.K. Gibbons" Date: Wed, 29 Jul 2026 13:34:15 +0000 Subject: [PATCH 29/30] Remove commented out AggregateLock template. --- .../splice-amulet/daml/Splice/AggregateLock.daml | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml index 976a08dbc6..b6bf85fd49 100644 --- a/daml/splice-amulet/daml/Splice/AggregateLock.daml +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -120,22 +120,6 @@ calculateAvailableWithdrawAmount currentDateTime alloc nextIterationFundAmount = withdrawnAmount = initialAmount - nextIterationFundAmount --- | The intention is to treat the overall aggregate lock for a SV as if it is --- "the settlement" for the allocations locked to it, and use iterated --- settlement to execute updates on the committed allocations as needed. --- This approach would permit most of the specific governance locking and --- vesting to be in a separate dar from amulet only needed for SVs and --- interested observers. - -{-template AggregateLock - with - dso: Party - instrumentId : Text - vestingSchedule : VestingSchedule - where - signatory dso --} - aggregateLockUnlock : (HasToInterface a V2.Allocation) => (a -> Time -> Metadata -> Update (ContractId V2.Allocation)) -> a -> ContractId a -> Allocation_Withdraw -> Update V2.AllocationResult aggregateLockUnlock newEmptyAllocation a aCid arg = do let alloc = view $ toInterface @V2.Allocation a From d2b93f25cecdc8a13cb5e77ebe6b0411a104bfe1 Mon Sep 17 00:00:00 2001 From: Deepak Birdi Date: Fri, 31 Jul 2026 20:20:58 +0000 Subject: [PATCH 30/30] Add initial SvRewardMintReceipt template and issuance --- daml/splice-amulet/daml/Splice/Amulet.daml | 9 ++++++ .../daml/Splice/AmuletRules.daml | 30 ++++++++++++++++++- 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/daml/splice-amulet/daml/Splice/Amulet.daml b/daml/splice-amulet/daml/Splice/Amulet.daml index 2473529d5b..f8f086ee40 100644 --- a/daml/splice-amulet/daml/Splice/Amulet.daml +++ b/daml/splice-amulet/daml/Splice/Amulet.daml @@ -618,6 +618,15 @@ template UnclaimedActivityRecord pure UnclaimedActivityRecord_DsoExpireResult with unclaimedRewardCid +template SvRewardMintReceipt with + dso : Party + amount : Decimal + beneficiary : Party + where + signatory dso + + + -- Support code --------------- diff --git a/daml/splice-amulet/daml/Splice/AmuletRules.daml b/daml/splice-amulet/daml/Splice/AmuletRules.daml index f1292fa96f..9d24baf3be 100644 --- a/daml/splice-amulet/daml/Splice/AmuletRules.daml +++ b/daml/splice-amulet/daml/Splice/AmuletRules.daml @@ -1138,6 +1138,15 @@ executeTransfer' config csum dso t = do isum <- summarizeAndConsumeInputs csum dso t.sender t.inputs osum <- preprocessOutputs csum.config t.outputs summary <- summarizeTransfer t.sender csum.openRoundNumber csum.amuletPrice csum.config isum osum + + case isum.mintedRewardMap of + None -> pure () + Some m -> forA_ (Map.toList m) $ \(beneficiary, amount) -> + create SvRewardMintReceipt with + dso + amount + beneficiary + -- check that overall transfer constraints are satisfied case checkTransferConstraints t summary csum.config of Left failureStatus -> failWithStatus failureStatus @@ -1245,6 +1254,9 @@ data TransferInputsSummary = TransferInputsSummary with totalDevelopmentFundAmount : Optional Decimal -- ^ Note: Same rationale as above — made optional to ensure compatibility with -- the upgrade checker on package upload because `TransferInputsSummary` is serializable. + mintedRewardMap : Optional (Map Party Decimal) + -- ^ Note: This is a map from the beneficiaries of unclaimed activity records, and reward coupons to + -- the amounts minted for them, used to produce receipts. deriving (Eq, Show) type TransferOutputsSummary = [PreprocessedTransferOutput] @@ -1351,6 +1363,11 @@ summarizeAndConsumeInputs csum dso sender inps = do changeToHoldingFeesRate = 0.0 totalUnclaimedActivityRecordAmount = Some 0.0 totalDevelopmentFundAmount = Some 0.0 + mintedRewardMap = Some Map.empty + + addMintedReward : Party -> Decimal -> Optional (Map Party Decimal) -> Optional (Map Party Decimal) + addMintedReward beneficiary amount None = Some $ Map.singleton beneficiary amount + addMintedReward beneficiary amount (Some m) = Some $ Map.insertWith (+) beneficiary amount m summarizeAndConsumeInput _round s (InputAmulet amuletCid) = do amulet <- fetchAndArchive forOwner amuletCid @@ -1368,6 +1385,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero + getValueAsOfRound0 amulet.amount changeToHoldingFeesRate = s.changeToHoldingFeesRate - amulet.amount.ratePerRound.rate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = s.mintedRewardMap summarizeAndConsumeInput _round s (InputAppRewardCoupon couponCid) = do coupon <- fetchAndArchive forOwner couponCid @@ -1387,6 +1405,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = s.mintedRewardMap summarizeAndConsumeInput _round s (InputValidatorRewardCoupon couponCid) = do -- we must and do use the validator right to archive the coupon of the user @@ -1409,6 +1428,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = s.mintedRewardMap summarizeAndConsumeInput _round s (InputSvRewardCoupon couponCid) = do -- we use the SvRewardCoupon_ArchiveAsBeneficiary choice to signal the archival of the coupon @@ -1417,17 +1437,20 @@ summarizeAndConsumeInputs csum dso sender inps = do exercise couponCid SvRewardCoupon_ArchiveAsBeneficiary -- compute balance change miningRound <- getIssuingMiningRound csum coupon.round + let currentSvRewardCouponAmount = intToDecimal coupon.weight * miningRound.issuancePerSvRewardCoupon + return TransferInputsSummary with totalAmuletAmount = s.totalAmuletAmount totalAppRewardAmount = s.totalAppRewardAmount totalValidatorRewardAmount = s.totalValidatorRewardAmount totalUnclaimedActivityRecordAmount = s.totalUnclaimedActivityRecordAmount totalValidatorFaucetAmount = s.totalValidatorFaucetAmount - totalSvRewardAmount = s.totalSvRewardAmount + intToDecimal coupon.weight * miningRound.issuancePerSvRewardCoupon + totalSvRewardAmount = s.totalSvRewardAmount + currentSvRewardCouponAmount totalHoldingFees = s.totalHoldingFees amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = addMintedReward coupon.beneficiary currentSvRewardCouponAmount s.mintedRewardMap summarizeAndConsumeInput _round s (InputValidatorLivenessActivityRecord recordCid) = do record <- fetchAndArchive forOwner recordCid @@ -1445,6 +1468,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = s.mintedRewardMap summarizeAndConsumeInput _round s (ExtTransferInput _dummyUnitField optInputValidatorFaucetCoupon) = do optional (pure s) (summarizeAndConsumeValidatorFaucetInput s) optInputValidatorFaucetCoupon @@ -1464,6 +1488,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = addMintedReward unclaimedActivityRecord.beneficiary unclaimedActivityRecord.amount s.mintedRewardMap summarizeAndConsumeInput _round s (InputDevelopmentFundCoupon couponCid) = do coupon <- fetchAndArchive forOwner couponCid @@ -1479,6 +1504,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = (+ coupon.amount) <$> s.totalDevelopmentFundAmount + mintedRewardMap = s.mintedRewardMap summarizeAndConsumeInput _round s (InputRewardCouponV2 couponCid) = do coupon <- fetchAndArchive forOwner couponCid @@ -1496,6 +1522,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = s.mintedRewardMap summarizeAndConsumeValidatorFaucetInput s couponCid = do coupon <- fetchAndArchive forOwner couponCid @@ -1513,6 +1540,7 @@ summarizeAndConsumeInputs csum dso sender inps = do amountArchivedAsOfRoundZero = s.amountArchivedAsOfRoundZero changeToHoldingFeesRate = s.changeToHoldingFeesRate totalDevelopmentFundAmount = s.totalDevelopmentFundAmount + mintedRewardMap = s.mintedRewardMap -- | Deduplicate lock-holders to store them and charge for them at most once dedupOutputLockHolders : TransferOutput -> TransferOutput