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..2a0f941b85 --- /dev/null +++ b/daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml @@ -0,0 +1,300 @@ +{-# LANGUAGE ApplicativeDo #-} +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.AggregateLock +import Splice.AmuletAllocationV2 (AmuletAllocationV2) +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.Api.Token.MetadataV1 +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.Testing.Utils +import Splice.TokenStandard.Utils qualified as TSU + + +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 = None + meta = emptyMetadata + lockAllocation = V2.AllocationSpecification with + admin = instrId.admin + authorizer = TSU.basicAccount party + transferLegSides = [] + committed = True + nextIterationFunding = Some amounts + settlementDeadline = Some maxComparableTime + meta + +lockForAggregate : TestEnv -> Decimal -> Text -> Party -> Script AllocationInstructionResult +lockForAggregate te amount lockSubject = lockForGovernance te (TM.fromList [(te.instrId.id, amount)]) $ Metadata $ TM.fromList + [ (typeKey, "svLock") + , (beneficiaryKey, lockSubject) + ] + +withGovernanceWithdrawContext : RelTime -> TestEnv -> MultiRegistry.MultiRegistry -> MultiRegistry.MultiRegistry +withGovernanceWithdrawContext effectiveAtOffset env registries = + flip fmap registries $ \reg -> + reg { v2Api = fmap updateApi reg.v2Api } + where + addContext a = do + baseCtxt <- a + extraContext <- getExternalPartyConfigStateContext env.registriesEnv.amuletV2 + now <- getTime + let effectiveAtContext = OpenApiChoiceContext with + choiceContext = ChoiceContext with + values = TM.singleton effectiveAtKey (AV_Time (now `addRelTime` effectiveAtOffset)) + disclosures = mempty + pure $ baseCtxt <> extraContext <> effectiveAtContext + updateApi api = + api { ggetAllocation_WithdrawContext = \a -> addContext . api.ggetAllocation_WithdrawContext a } + +withAggregateWithdrawContext : TestEnv -> MultiRegistry.MultiRegistry -> MultiRegistry.MultiRegistry +withAggregateWithdrawContext = withGovernanceWithdrawContext (microseconds 1) + +withVestingWithdrawContext : TestEnv -> MultiRegistry.MultiRegistry -> MultiRegistry.MultiRegistry +withVestingWithdrawContext = withGovernanceWithdrawContext (microseconds 0) + +aggregateLocksOf : Party -> Script [(ContractId V2.Allocation, AmuletAllocationV2, AggregatedLock)] +aggregateLocksOf p = do + allocs <- query @AmuletAllocationV2 p + pure + [ (toInterfaceContractId cid, alloc, lock) + | (cid, alloc) <- allocs + , Some (GovernanceLock_SVLocked lock) <- [alloc.governanceLock] + ] + +vestingLocksOf : Party -> Script [(ContractId V2.Allocation, AmuletAllocationV2, VestingLock)] +vestingLocksOf p = do + allocs <- query @AmuletAllocationV2 p + pure + [ (toInterfaceContractId cid, alloc, lock) + | (cid, alloc) <- allocs + , Some (GovernanceLock_VestingLocked lock) <- [alloc.governanceLock] + ] + +getNextIterationFunding : TestEnv -> AmuletAllocationV2 -> Decimal +getNextIterationFunding te alloc = + fromOptional 0.0 $ alloc.allocation.nextIterationFunding >>= TM.lookup te.instrId.id + +createVestingLock + : TestEnv -> Decimal -> Party + -> Script (ContractId V2.Allocation, V2.AllocationView, VestingLock) +createVestingLock env amount party = do + AllocationInstructionResult { output = AllocationInstructionResult_Completed aggregateCid } <- + lockForAggregate env amount "alice-supervalidator" party + + Some aggregateView <- queryInterfaceContractId party aggregateCid + _ <- WalletClientV2.withdrawAllocationV2 + (withAggregateWithdrawContext env env.registries) party (aggregateCid, aggregateView) + + [(vestingCid, _, lock)] <- vestingLocksOf party + Some vestingView <- queryInterfaceContractId party vestingCid + + pure (vestingCid, vestingView, lock) + +-- | Verify that locking funds for a lock subject aggregates over separate lock allocations +-- sharing the same subject. +testAggregateLockTotals : Script () +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 + + aggregates <- aggregateLocksOf dso + let totals = M.fromListWithR (+) + [ (lock.lockSubject, getNextIterationFunding env alloc) | (_, alloc, lock) <- aggregates ] + + M.lookup "alice-supervalidator" totals === Some 1300.0 + M.lookup "charlie-supervalidator" totals === Some 300.0 + +-- | 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 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 + + -- Withdraw from governanceLock to initiate vesting + _ <- WalletClientV2.withdrawAllocationV2 newRegistries bob (locked, lockedView) + + liveAllocs <- fmap (fromSome . snd) . filter (isSome . snd) <$> + queryInterface @V2.Allocation bob + length liveAllocs === 1 + + aggregates <- aggregateLocksOf bob + vestings <- vestingLocksOf bob + length aggregates === 0 + length vestings === 1 + + let [(_, vestingAlloc, vesting)] = vestings + -- Check locked amount + getNextIterationFunding env vestingAlloc === 1000.0 + vesting.initialAmount === 1000.0 + +-- | 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 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 + + let amountToWithdraw = 500.0 + _ <- WalletClientV2.withdrawAllocationV2Meta newRegistries bob (locked, lockedView) $ + Metadata $ TM.singleton withdrawAmountKey $ show amountToWithdraw + + liveAllocs <- fmap (fromSome . snd) . filter (isSome . snd) <$> + queryInterface @V2.Allocation bob + length liveAllocs === 2 + + aggregates <- aggregateLocksOf bob + vestings <- vestingLocksOf bob + length aggregates === 1 + length vestings === 1 + + let [(_, aggregateAlloc, aggregate)] = aggregates + [(_, vestingAlloc, vesting)] = vestings + getNextIterationFunding env aggregateAlloc === 500.0 + getNextIterationFunding env vestingAlloc === 500.0 + + -- Check lockSubject and vestedAmount + aggregate.lockSubject === "alice-supervalidator" + vesting.initialAmount === amountToWithdraw + +-- | Withdrawing from a vesting-lock allocation vests funds linearly over the +-- lock's start/end period. +testVestingLockWithdraw : Script () +testVestingLockWithdraw = do + env@TestEnv{..} <- setupTest + let newRegistries = withVestingWithdrawContext env registries + initialAmount = 365.25 -- one unit per day of the 365 day + 6 hour vesting period + + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 + + (vestingLockCid, vestingLockView, vestingLock) <- createVestingLock env initialAmount bob + vestingLock.initialAmount === initialAmount + + -- 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 10) + vestingResult1 <- WalletClientV2.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 <- WalletClientV2.extractAllocationResult <$> + WalletClientV2.withdrawAllocationV2 newRegistries bob (nextCid, nextView) + + let holdingCids2 = fromSome $ TM.lookup instrId.id vestingResult2.authorizerHoldingCids + amount2 <- unlockedAmountOf bob holdingCids2 + + -- The full amount should now be withdrawn + amount1 + amount2 === initialAmount + other -> + fail $ "expected AllocationResult_Settled with a next-iteration allocation, got: " <> show other + +testVestingLockTotalWithdraw : Script () +testVestingLockTotalWithdraw = do + env@TestEnv{..} <- setupTest + let newRegistries = withVestingWithdrawContext env registries + initialAmount = 365.25 -- one unit per day of the 365 day + 6 hour vesting period + + AmuletRegistryV2.tapFaucet registriesEnv.amuletV2 bob 1800.0 + + (vestingLockCid, vestingLockView, _) <- createVestingLock env initialAmount bob + + -- Withdrawing immediately fails: nothing has vested yet. + vestingLockView.allocation.admin `submitMustFailWithdraw` (vestingLockCid, vestingLockView) $ newRegistries + + -- Once the whole vesting period has elapsed, everything can be withdrawn at once. + 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 + + -- Nothing is left to vest, so no follow-up allocation is created. + 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 + : 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 + +-- | 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) diff --git a/daml/splice-amulet/daml/Splice/AggregateLock.daml b/daml/splice-amulet/daml/Splice/AggregateLock.daml new file mode 100644 index 0000000000..a254a99939 --- /dev/null +++ b/daml/splice-amulet/daml/Splice/AggregateLock.daml @@ -0,0 +1,375 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +module Splice.AggregateLock where + +import Splice.Amulet.TokenApiUtils +import Splice.Api.Token.AllocationV2 as V2 +import Splice.Api.Token.AllocationInstructionV2 as V2 +import Splice.Api.Token.MetadataV1 +import Splice.TokenStandard.Utils (maxTime, regularAccountOwner) +import Splice.TokenStandard.Utils.Internal.Allocations (settlementFactoryV2_settleBatchDefaultImplNoSelf) +import Splice.TokenStandard.Utils.Internal.Conversions (timeFromMeta) +import Splice.Util + +import DA.Action hiding (mapA) +import DA.Assert (assertWithinDeadline) +import DA.Either +import DA.Optional +import qualified DA.Set as S +import DA.Text as T +import DA.List hiding (concat) +import qualified DA.TextMap as TM +import DA.Time +import DA.Traversable (mapA) +import Prelude hiding (mapA, concat) + +-- Lock management +-- =============== + +class GovernanceAllocation a where + getGovernanceLock : a -> Optional GovernanceLock + createUnfundedGovernanceAllocation : GovernanceLock -> V2.AllocationFactory_Allocate -> Update (ContractId a, V2.AllocationInstructionResult) + -- ^ uses ContractId a to avoid an ambiguous type. There's probably a better way to hook into settlement-like funds movement than to use this and settleBatch. + +data GovernanceLock + = GovernanceLock_SVLocked AggregatedLock + | GovernanceLock_VestingLocked VestingLock + deriving (Eq, Show, Serializable) + +data AggregatedLock = + AggregatedLock with + lockSubject : Text + controllers : GovernanceLockControllers + deriving (Eq, Show, Serializable) + +data VestingLock = + VestingLock with + startDate : Time + endDate : Time + initialAmount : Decimal + -- ^ The initial amount represents the total that was locked initially when thrown into vesting state + controllers : GovernanceLockControllers + deriving (Eq, Show, Serializable) + +typeKey : Text +typeKey = "cip-105/type" + +beneficiaryKey : Text +beneficiaryKey = "cip-105/lock-subject" + +startDateKey : Text +startDateKey = "cip-105/start-date" + +endDateKey : Text +endDateKey = "cip-105/end-date" + +initialAmountKey : Text +initialAmountKey = "cip-105/initial-amount" + +-- TODO: Simon mentioned to rename this within PR obsidiansystems/splice/pull/12 +effectiveAtKey : Text +effectiveAtKey = "cip-105/effective-at" + +unlockControllerKey : Text +unlockControllerKey = "cip-105/unlock-controllers" + +withdrawControllerKey : Text +withdrawControllerKey = "cip-105/withdraw-controllers" + +substituteControllerKey : Text +substituteControllerKey = "cip-105/substitute-controllers" + +withdrawAmountKey : Text +withdrawAmountKey = "cip-105/withdraw-amount" + + +governanceMetadataKeys : Metadata -> S.Set Text +governanceMetadataKeys meta = S.fromList $ fst <$> TM.toList ( TM.filterWithKey ( \a _ -> "cip-105/" `T.isPrefixOf` a ) meta.values ) + +isGovernanceAllocationArgument : V2.AllocationFactory_Allocate -> Bool +isGovernanceAllocationArgument arg = not ( S.null $ governanceMetadataKeys arg.allocation.meta ) + || not (TM.null ( TM.filterWithKey ( \a _ -> "cip-105/" `T.isPrefixOf` a ) arg.extraArgs.context.values)) + +checkGovernanceMetadataKeys : (CanAssert m) => S.Set Text -> Metadata -> m () +checkGovernanceMetadataKeys knownKeys = + require "Only known metadata keys are supplied under cip-105/" . (`S.isSubsetOf` knownKeys) . governanceMetadataKeys + +controllerKeys = [unlockControllerKey, withdrawControllerKey, substituteControllerKey] +aggregatedLockKeys = S.fromList $ typeKey::beneficiaryKey::controllerKeys +vestingLockKeys = S.fromList $ typeKey::startDateKey::endDateKey::initialAmountKey::controllerKeys + + +class CanAssert m => ParseLockDataFromMeta m a where + parseFromMetadata : Metadata -> m a + +class CanAssert m => ParseLockDataFromText m a where + parseFromText : Text -> m a + +governanceLockToMeta _ = Metadata $ TM.singleton "cip-105/gov-lock-flag" "true" -- FIXME: actually serialize to metadata, this just lets allocateImplCore work. + +instance CanAssert m => ParseLockDataFromMeta m (Optional GovernanceLock) where + parseFromMetadata meta + | S.null $ governanceMetadataKeys meta = pure None + | otherwise = do + case "cip-105/type" `TM.lookup` meta.values of + Some "svLock" -> Some . GovernanceLock_SVLocked <$> parseFromMetadata meta + Some "vestingLock" -> Some . GovernanceLock_VestingLocked <$> parseFromMetadata meta + _ -> assertFail "Unknown governance lock type" + +requireSome : CanAssert m => Text -> Optional a -> m a +requireSome msg a = + case a of + None -> assertFail $ "The requirement '" <> msg <> "' was not met." + Some a -> pure a + +instance CanAssert m => ParseLockDataFromMeta m AggregatedLock where + parseFromMetadata meta = do + lockSubject <- requireSome "has a lockSubject field in metadata" $ "cip-105/lock-subject" `TM.lookup` meta.values + controllers <- parseFromMetadata meta + checkGovernanceMetadataKeys aggregatedLockKeys meta + pure $ AggregatedLock with .. + +instance CanAssert m => ParseLockDataFromMeta m VestingLock where + parseFromMetadata meta = do + startDate <- requireSome "has a valid startDate field in metadata" $ timeFromMeta startDateKey meta + endDate <- requireSome "has a valid endDate field in metadata" $ timeFromMeta endDateKey meta + initialAmount <- requireSome "has a valid initialAmount field in metadata" $ initialAmountKey `TM.lookup` meta.values >>= parseDecimal + checkGovernanceMetadataKeys vestingLockKeys meta + controllers <- parseFromMetadata meta + pure $ VestingLock with .. + +-- | Parsing entry point + +parseAndValidateGovernanceLock : CanAssert m => Bool -> Party -> V2.AllocationFactory_Allocate -> m (Optional GovernanceLock) +parseAndValidateGovernanceLock fromAllocate dso alloc = do + lock <- parseFromMetadata alloc.allocation.meta + case lock of + Some _ -> do + require "must have the DSO as admin" $ alloc.allocation.admin == dso + require "must have the DSO as executors" $ alloc.settlement.executors == [dso] + require "must be a committed allocation" alloc.allocation.committed + require "must not have specified transfer leg sides" $ null alloc.allocation.transferLegSides + require "must not expire" $ alloc.allocation.settlementDeadline == Some maxComparableTime + -- Lock expiry also simply forced to max in computeAllocationExpiry when governance locked. + -- Note: instrument id of only amulet and non-zero allocation are already checked by AmuletAllocationV2 ensure clause. + pure lock + None -> pure None + +governanceLock_rules (GovernanceLock_VestingLocked _) + = assertFail "Creating vesting locks from an allocation instruction is not permitted" +governanceLock_rules _ = pure () + +maxComparableTime : Time +maxComparableTime = addRelTime maxTime $ microseconds (-1) + +type ControllerSpecification = [[Party]] + +defaultControllerSpecification : Party -> ControllerSpecification +defaultControllerSpecification owner = [[owner]] + + +data GovernanceLockControllers = GovernanceLockControllers with + unlock : Optional ControllerSpecification + withdraw : Optional ControllerSpecification + substitute : Optional ControllerSpecification + deriving (Eq, Show, Serializable) + +instance CanAssert m => ParseLockDataFromText m ControllerSpecification where + parseFromText = mapA parseFromText . splitOn ";" + +instance CanAssert m => ParseLockDataFromText m [Party] where + parseFromText = mapA (requireSome "party can be converted from text" . partyFromText) . splitOn "," + +instance CanAssert m => ParseLockDataFromMeta m GovernanceLockControllers where + parseFromMetadata meta = do + unlock <- mapA parseFromText $ unlockControllerKey `TM.lookup` meta.values + withdraw <- mapA parseFromText $ withdrawControllerKey `TM.lookup` meta.values + substitute <- mapA parseFromText $ substituteControllerKey `TM.lookup` meta.values + pure $ GovernanceLockControllers with .. + +-- TODO / FIXME: Expose the error message from parseGovernanceLock +partiesFromText : Text -> Optional [Party] +partiesFromText = eitherToOptional . parseCommaSeparated "Parties" partyFromText + +checkControllerSpecification : [Party] -> ControllerSpecification -> Update () +checkControllerSpecification actors set = + require "Controllers must be one of the listed options" $ + any actorsMatch set + where + actorsMatch : [Party] -> Bool + actorsMatch set + = all (\s -> any ((==) s) actors) set + && all (\a -> any (a ==) set) actors + + +-- This will also need to get a configuration template to set the vesting period and potentially other settings. +-- TODO: The above should be passed in via `ExternalPartyConfigState` as mentioned under PR #6815 + +governanceLockedWithdrawImpl + : (HasToInterface a V2.Allocation, GovernanceAllocation a) + => a + -> ContractId a + -> V2.Allocation_Withdraw + -> Update V2.AllocationResult +governanceLockedWithdrawImpl this self arg@(V2.Allocation_Withdraw{..}) = + case getGovernanceLock this of + Some (GovernanceLock_SVLocked lock) -> aggregateLockUnlock lock this self arg + Some (GovernanceLock_VestingLocked lock) -> vestingLockWithdraw lock this self arg + _ -> assertFail "governanceLockedWithdrawImpl called witha a non-governance lock" + + +aggregateLockUnlock : forall a. (HasToInterface a V2.Allocation, GovernanceAllocation a) => AggregatedLock -> a -> ContractId a -> Allocation_Withdraw -> Update V2.AllocationResult +aggregateLockUnlock lock a aCid arg = do + let alloc = view $ toInterface @V2.Allocation a + allocCid = toInterfaceContractId @V2.Allocation aCid + + -- That this is a singleton with the amulet insturment ID is enforced by AmuletAllocationV2, but not encoded in the types we see here. + (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" + + let ownerParty = regularAccountOwner alloc.allocation.authorizer + + checkControllerSpecification arg.actors $ fromOptional (defaultControllerSpecification ownerParty) lock.controllers.unlock + + now <- getFromContextU arg.extraArgs.context effectiveAtKey -- FIXME: read from metadata not context. + assertWithinDeadline "effectiveAt must not be in the past" now + + let endDate = getEndTime now + transferLegId = "unlock" + + let alternateAmount = TM.lookup withdrawAmountKey arg.extraArgs.meta.values >>= parseDecimal + amount = fromOptional currentLockedAmount alternateAmount + newLockedAmount = currentLockedAmount - amount + newLockedNextIterationFunding + | newLockedAmount == 0.0 = None + | otherwise = Some $ TM.singleton instrumentId newLockedAmount + vestingGovernanceLock = GovernanceLock_VestingLocked $ VestingLock with + startDate = now + endDate + initialAmount = amount + controllers = lock.controllers + + -- Not easy to call directly into amulet_allocationFactoryV2_allocateImpl or the like here as that would make a circular dependency. + (withdrawTo : ContractId a, _) <- createUnfundedGovernanceAllocation vestingGovernanceLock $ V2.AllocationFactory_Allocate with + settlement = alloc.settlement + allocation = AllocationSpecification with + admin = alloc.allocation.admin + authorizer = alloc.allocation.authorizer + transferLegSides = [] + settlementDeadline = Some maxComparableTime + nextIterationFunding = Some TM.empty -- Iterated settlement enabled, with no funding + committed = True + meta = emptyMetadata -- governance settings passed in the dedicated argument to createGovernanceAllocation + requestedAt = now + inputHoldingCids = [] + extraArgs = ExtraArgs with + meta = emptyMetadata + context = emptyChoiceContext + actors = [ ownerParty ] + + settleBatchResult <- settlementFactoryV2_settleBatchDefaultImplNoSelf (\_ _ -> pure arg.extraArgs) alloc.allocation.admin $ SettlementFactory_SettleBatch with + settlement = alloc.settlement + actors = [ alloc.allocation.admin ] + 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 = newLockedNextIterationFunding + , FinalizedAllocation with + allocationCid = toInterfaceContractId 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 + getEndTime now = addRelTime now $ days 365 + hours 6 + + +-- TODO: Potentially make return type, it's own data type? +calculateAvailableWithdrawAmount : Time -> VestingLock -> Decimal -> (Decimal, Decimal) +calculateAvailableWithdrawAmount vestUntil (VestingLock {..}) nextIterationFundAmount = availAmount + where + availAmount = max (0.0, 0.0) $ if vestUntil >= endDate + then (nextIterationFundAmount, 0.0) + else (availableWithdrawAmount, remainingVestingAmount) + availableWithdrawAmount = (initialAmount * totalVestedRatioElapsed) - withdrawnAmount + remainingVestingAmount = nextIterationFundAmount - availableWithdrawAmount + totalUnlockPeriod : Decimal = intToDecimal . convertRelTimeToMicroseconds $ subTime endDate startDate + unlockPeriodElapsed : Decimal = intToDecimal . convertRelTimeToMicroseconds $ subTime vestUntil startDate + totalVestedRatioElapsed : Decimal = unlockPeriodElapsed / totalUnlockPeriod + withdrawnAmount = initialAmount - nextIterationFundAmount + + +vestingLockWithdraw : (HasToInterface a V2.Allocation) => VestingLock -> a -> ContractId a -> Allocation_Withdraw -> Update V2.AllocationResult +vestingLockWithdraw lock a aCid arg = do + let vestingLock = view $ toInterface @V2.Allocation a + vestingLockCid = toInterfaceContractId @V2.Allocation aCid + + now <- getFromContextU arg.extraArgs.context effectiveAtKey -- FIXME: read from metadata, not context. + isLedgerTimeGE now >>= require "effectiveAt must not be in the future" + + -- Removed withdraw controllers for the moment on vesting locks, it seems significantly more questionable to restrict withdrawal of conceptually unlocked amulet. + + -- That this is a singleton with the amulet insturment ID is enforced by AmuletAllocationV2, but not encoded in the types we see here. + (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" + + let (availableWithdrawAmount, remainingVestingAmount) : (Decimal, Decimal) = + calculateAvailableWithdrawAmount now lock nextIterationFunding + + require ("Current eligible withdraw amount for vesting lock is not greater than 0.0. " + <> "currentEligibleWithdrawableAmount came back = '" + <> show availableWithdrawAmount + <> "'." + ) + $ availableWithdrawAmount > 0.0 + + let + 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 = vestingLock.settlement + actors = [ vestingLock.allocation.admin ] + extraArgs = ExtraArgs emptyChoiceContext emptyMetadata + transferLegs = [] + allocations = + [ FinalizedAllocation with + allocationCid = vestingLockCid + extraTransferLegSides = [] + nextIterationFunding + ] + + -- We should have one result from settleBatch + case settleResult.allocationSettleResults of + [allocationResult] -> pure allocationResult + _ -> abort "VestingUnlock_Withdraw should result in one allocation result. " \ No newline at end of file diff --git a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml index 469ede68f2..a4b1300605 100644 --- a/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml +++ b/daml/splice-amulet/daml/Splice/AmuletAllocationV2.daml @@ -9,6 +9,7 @@ module Splice.AmuletAllocationV2 ( validateAmuletTransferLegSides, computeAllocationExpiry, computeAllocationExpiryInternal, + unlockAmuletAllocationV2, ) where import DA.Action @@ -21,8 +22,10 @@ import DA.Time import Splice.Api.Token.MetadataV1 import Splice.Api.Token.HoldingV2 qualified as V2 import Splice.Api.Token.AllocationV2 qualified as V2 +import Splice.Api.Token.AllocationInstructionV2 as V2 import Splice.TokenStandard.Utils hiding (require) +import Splice.AggregateLock import Splice.Amulet import Splice.AmuletConfig (TransferConfigV2, getTokenStandardMaxTTL) import Splice.AmuletRules @@ -47,6 +50,7 @@ template AmuletAllocationV2 expiresAt : Time numIterations : Int createdAt : Time + governanceLock : Optional GovernanceLock where signatory allocation.admin, allocation.authorizer.owner observer settlement.executors @@ -76,6 +80,9 @@ template AmuletAllocationV2 allocation_cancelExtraObservers _arg = observer this allocation_withdrawExtraObservers _arg = observer this + + allocation_withdrawImpl self arg | Some governanceLock <- this.governanceLock = + governanceLockedWithdrawImpl this (fromInterfaceContractId self) arg allocation_withdrawImpl self arg@(V2.Allocation_Withdraw{..}) = do archiveAndCheckActors self arg.actors [[accountPrincipal allocation.admin allocation.authorizer]] ensureWithdrawIsAllowed allocation @@ -137,7 +144,7 @@ template AmuletAllocationV2 -- Bump the allocation expiry using the old `expiresAt` as the "current time", -- which is safe to do as the traffic spend to iterate the allocation covers -- the cost of storing the allocation for the longer period. - newExpiresAt <- computeAllocationExpiry configAmulet expiresAt allocation.settlementDeadline + newExpiresAt <- computeAllocationExpiry configAmulet (isSome this.governanceLock) expiresAt allocation.settlementDeadline lockedAmulet <- if outputFundingAmount <= 0.0 then pure None else do lockedAmuletCid <- create LockedAmulet with @@ -163,6 +170,7 @@ template AmuletAllocationV2 expiresAt = newExpiresAt numIterations = numIterations + 1 createdAt + governanceLock pure (Some (toInterfaceContractId nextAllocationCid)) -- log the tx history v2 event @@ -230,15 +238,33 @@ computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline = | maxTime `subTime` oldExpiresAt <= maxTTL = maxTime | otherwise = oldExpiresAt `addRelTime` maxTTL -computeAllocationExpiry : TransferConfigV2 Amulet -> Time -> Optional Time -> Update Time -computeAllocationExpiry transferConfig oldExpiresAt settlementDeadline = do - let expiresAt = computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline - assertWithinDeadline "allocation.expiresAt" expiresAt - pure expiresAt - +computeAllocationExpiry : TransferConfigV2 Amulet -> Bool -> Time -> Optional Time -> Update Time +computeAllocationExpiry transferConfig isGovernance oldExpiresAt settlementDeadline + | isGovernance = pure maxComparableTime + | otherwise = do + let expiresAt = computeAllocationExpiryInternal transferConfig oldExpiresAt settlementDeadline + assertWithinDeadline "allocation.expiresAt" expiresAt + pure expiresAt -- instances ------------ instance HasCheckedFetch AmuletAllocationV2 ForDso where contractGroupId AmuletAllocationV2{..} = ForDso with dso = allocation.admin + +instance GovernanceAllocation AmuletAllocationV2 where + getGovernanceLock AmuletAllocationV2 { governanceLock } = governanceLock + createUnfundedGovernanceAllocation governanceLock V2.AllocationFactory_Allocate{..} = do + amuletAllocCid <- create AmuletAllocationV2 with + lockedAmulet = None + settlement + allocation + expiresAt = maxComparableTime + numIterations = 0 + createdAt = requestedAt + governanceLock = Some governanceLock + let allocInstrResult = AllocationInstructionResult with + output = AllocationInstructionResult_Completed with allocationCid = toInterfaceContractId amuletAllocCid + authorizerChangeCids = TextMap.empty + meta = emptyMetadata + pure (amuletAllocCid, allocInstrResult) \ No newline at end of file diff --git a/daml/splice-amulet/daml/Splice/ExternalPartyAmuletRules.daml b/daml/splice-amulet/daml/Splice/ExternalPartyAmuletRules.daml index ae95ae8d76..0e3d3a2b05 100644 --- a/daml/splice-amulet/daml/Splice/ExternalPartyAmuletRules.daml +++ b/daml/splice-amulet/daml/Splice/ExternalPartyAmuletRules.daml @@ -9,11 +9,13 @@ import DA.Assert import DA.Foldable (forA_) import DA.Optional import qualified DA.TextMap as TextMap +import qualified DA.Map as Map import DA.Time import Splice.Api.Token.MetadataV1 import Splice.Api.Token.TransferInstructionV1 qualified as Api.Token.TransferInstructionV1 import Splice.Api.Token.HoldingV1 qualified as V1 +import Splice.Api.Token.HoldingV2 qualified as V2 import Splice.Api.Token.AllocationInstructionV1 qualified as V1 import Splice.Api.Token.AllocationV2 qualified as V2 import Splice.Api.Token.AllocationInstructionV2 qualified as V2 @@ -21,6 +23,7 @@ import Splice.Api.Token.TransferInstructionV2 qualified as V2 import Splice.Api.Token.TransferEventsV2 qualified as TransferEventsV2 import Splice.TokenStandard.Utils hiding (require, reasonMetaKey) +import Splice.AggregateLock import Splice.Amulet import Splice.AmuletConfig (getTokenStandardMaxTTL) import Splice.Amulet.TokenApiUtils @@ -453,6 +456,8 @@ amulet_allocationFactoryV2_allocateImpl -> ContractId V2.AllocationFactory -> V2.AllocationFactory_Allocate -> Update V2.AllocationInstructionResult +amulet_allocationFactoryV2_allocateImpl _ _self arg + | isGovernanceAllocationArgument arg = governanceAllocateImpl arg amulet_allocationFactoryV2_allocateImpl externalAmuletRules _self arg = do let netTransferAmount = netAmuletCreditAmount arg.allocation.authorizer arg.allocation.transferLegSides outputFundingAmount <- validateAmuletNextIterationFunding arg.allocation.nextIterationFunding @@ -466,6 +471,7 @@ amulet_allocationFactoryV2_allocateImpl externalAmuletRules _self arg = do expiresAt createdAt = arg.requestedAt numIterations = 0 + governanceLock = None pure V2.AllocationInstructionResult with authorizerChangeCids = TextMap.fromList [(amuletInstrumentIdName, map upcast senderChangeCids)] output = V2.AllocationInstructionResult_Completed with allocationCid @@ -523,7 +529,7 @@ amulet_allocationFactoryV2_allocateImplCore externalAmuletRules arg fundingAmoun -- compute the allocation expiry time (_, configState) <- getExternalPartyConfigStateFromChoiceContext dso arg.extraArgs.context let configAmulet = transferConfigAmuletFromExternalPartyConfigState configState - expiresAt <- computeAllocationExpiry configAmulet requestedAt allocation.settlementDeadline + expiresAt <- computeAllocationExpiry configAmulet (isGovernanceAllocationArgument arg) requestedAt allocation.settlementDeadline -- create locked amulet if required if fundingAmount <= 0.0 @@ -601,3 +607,26 @@ requireExpectedAdminMatch expected actual = require ("Expected admin " <> show instance HasCheckedFetch ExternalPartyAmuletRules ForDso where contractGroupId ExternalPartyAmuletRules{..} = ForDso dso + +governanceAllocateImpl : V2.AllocationFactory_Allocate -> Update V2.AllocationInstructionResult +governanceAllocateImpl arg@V2.AllocationFactory_Allocate{..} = do + let dso = arg.allocation.admin + Some [ (_, allocationAmount) ] = TextMap.toList <$> allocation.nextIterationFunding -- Valid because of the ensure above, but FIXME: better reporting desirable. + Some lock <- parseAndValidateGovernanceLock True dso arg -- FIXME: change the return value now that we aren't calling in allocate + governanceLock_rules lock + + (lockedAmulet, senderChangeCids, expiresAt, meta) <- + amulet_allocationFactoryV2_allocateImplCore (ExternalPartyAmuletRules dso) arg allocationAmount + + allocationCid <- toInterfaceContractId <$> create AmuletAllocationV2 with + settlement = arg.settlement + allocation = arg.allocation + lockedAmulet + expiresAt + createdAt = arg.requestedAt + numIterations = 0 + governanceLock = Some lock + pure V2.AllocationInstructionResult with + authorizerChangeCids = TextMap.fromList [(amuletInstrumentIdName, map upcast senderChangeCids)] + output = V2.AllocationInstructionResult_Completed with allocationCid + meta \ No newline at end of file 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-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml b/token-standard/splice-token-standard-utils/daml/Splice/TokenStandard/Utils/Internal/Conversions.daml index 5fbcdd253a..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,6 +27,8 @@ module Splice.TokenStandard.Utils.Internal.Conversions ( partiesToMeta, dropMeta, validateNoMeta, + encodeTime, + decodeTime, -- * Transfer utils reasonMetaKey, 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 803e5ff2ce..71c2e3efc4 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,9 @@ module Splice.Testing.Registries.AmuletRegistryV2 , getActiveOpenRoundsSorted , advanceToNextRoundChange , convertAllFeaturedAppActivityMarkers + + -- + , getExternalPartyConfigStateContext ) where import DA.Action (unless, when) 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..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, @@ -73,6 +74,7 @@ module Splice.Testing.TokenStandard.WalletClientV2 -- ** Allocations extractNextIterationAllocationCid, + extractAllocationResult, mkAllocationFactory_AllocateV2, mkAllocationInstruction_AcceptV2, @@ -469,6 +471,20 @@ 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 +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) @@ -812,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 @@ -820,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]