WIP: cip 0105 externally implemented governance locks

daml/splice-amulet-test/daml/Splice/Scripts/TestAggregateLocks.daml

@@ -0,0 +1,289 @@
+{-# 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.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
+import Splice.TokenStandard.Utils.Internal.Conversions (encodeTime)
+
+
+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 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")
+  ]
+
+-- | 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.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 }
+
+-- | 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
+
+  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
+
+  allocs <- queryInterface @V2.Allocation dso
+  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 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
+-- fresh vesting-lock destination for the same owner.
+testAggregateLockUnlockCreatesVestingLock : Script ()
+testAggregateLockUnlockCreatesVestingLock = 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.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) === 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
+  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
+
+  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 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
+      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 = 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
+  : 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)