Implement and test Amulet settlment with auth via Allocation

Author: bame-da

daml/splice-amulet/daml/Splice/Amulet/TwoStepTransfer.daml

@@ -38,8 +38,7 @@ import Splice.Util
 data TwoStepTransfer = TwoStepTransfer with
     dso : Party
     sender : Party
-    receiver : Party
-    amount : Decimal
+    outputs : [(Party, Decimal)]
     lockContext : Text
       -- ^ Context description of the lock. This is used to display the reason for
       -- the lock in wallets.
@@ -77,26 +76,29 @@ prepareTwoStepTransfer
 prepareTwoStepTransfer TwoStepTransfer{..} requestedAt inputHoldingCids paymentContext = do
   require "requestedAt < transferBefore" (requestedAt < transferBefore)
   -- over-approximate fees that will be due on the actual transfer
-  let receiverOutputForActualTransfer = TransferOutput with
-        receiver
-        amount
-        receiverFeeRatio = 0.0  -- all fees are paid by the sender
-        lock = None
-  [expectedTransferFees] <- exerciseComputeFees paymentContext sender [receiverOutputForActualTransfer]
+  let receiverOutputsForActualTransfer = map (\(receiver, amount) -> TransferOutput with
+          receiver
+          amount
+          receiverFeeRatio = 0.0  -- all fees are paid by the sender
+          lock = None
+        )
+        outputs
+  expectedTransferFees <- sum <$> exerciseComputeFees paymentContext sender receiverOutputsForActualTransfer
   openRound <- fetchChecked (ForDso with dso) paymentContext.context.openMiningRound
   let lockDuration = transferBefore `subTime` requestedAt
   let approximateHoldingFees = holdingFeesForDuration lockDuration openRound
   let feesReserveAmount = (expectedTransferFees + approximateHoldingFees) * feeReserveMultiplier
 
   -- lock the amulet
   transferInputs <- holdingToTransferInputs (ForOwner with dso; owner = sender) paymentContext inputHoldingCids
+  let totalAmount = sum $ (map snd outputs)
   let transfer = Splice.AmuletRules.Transfer with
         sender
         provider = sender -- the sender is serving as its own "app provider"
         outputs =
           [ TransferOutput with
               receiver = sender
-              amount = amount + feesReserveAmount
+              amount = totalAmount + feesReserveAmount
               receiverFeeRatio = 0.0 -- locking fees are paid by the sender
               lock = Some TimeLock with
                 expiresAt = transferBefore
@@ -134,16 +136,18 @@ executeTwoStepTransfer TwoStepTransfer{..} lockedAmuletCid extraArgs = do
   unlockResult <- exercise lockedAmuletCid LockedAmulet_Unlock with openRoundCid
   let amuletCid = unlockResult.amuletSum.amulet
   -- execute transfer
-  let receiverOutput = TransferOutput with
-        receiver = receiver
-        amount = amount
-        receiverFeeRatio = 0.0  -- all fees are paid by the sender
-        lock = None
+  let receiverOutputs = map (\(receiver, amount) -> TransferOutput with
+          receiver
+          amount
+          receiverFeeRatio = 0.0  -- all fees are paid by the sender
+          lock = None
+        )
+        outputs
   let amuletRulesTransfer = Splice.AmuletRules.Transfer with
         sender
         provider
         inputs = [InputAmulet amuletCid]
-        outputs = [receiverOutput]
+        outputs = receiverOutputs
         beneficiaries
   result <- exerciseCheckedPaymentTransfer dso paymentContext amuletRulesTransfer
   pure

daml/splice-amulet/daml/Splice/AmuletAllocation.daml

@@ -4,12 +4,13 @@
 module Splice.AmuletAllocation (
   AmuletAllocation(..),
   allocationToTwoStepTransfer,
-  allocationSender,
 ) where
 
+import DA.Assert((===), (=/=))
 import DA.Text as Text
 import DA.TextMap qualified as TextMap
-import DA.List (dedupSort)
+import DA.List ((\\), dedupSort)
+import DA.Optional(fromSome)
 
 import Splice.Api.Token.MetadataV1
 import Splice.Api.Token.HoldingV2
@@ -26,21 +27,32 @@ template AmuletAllocation
   with
     lockedAmulet : ContractId LockedAmulet -- ^ Locked amulet that holds the funds for the allocation
     allocation : AllocationSpecification
+    sender : Party
+    admin : Party
   where
-    signatory allocationInstrumentAdmin allocation, allocationSender allocation
+    signatory admin, sender
     observer allocation.settlement.executor
 
-    -- Only allow a single sender.
-    ensure all (\(_,tl) -> tl.sender == allocationSender allocation) (TextMap.toList allocation.transferLegs)
+    ensure 
+      all 
+        (\(_,tl) -> (
+            -- Sender needs to appear as sender or receiver of each leg.
+            sender `elem` [tl.sender, tl.receiver]) 
+            -- Only one admin Id allowed.
+            && tl.instrumentId.admin == admin) 
+        (TextMap.toList allocation.transferLegs)
 
     interface instance Allocation for AmuletAllocation where
       view = AllocationView with
         allocation
         holdingCids = [toInterfaceContractId lockedAmulet]
         meta = emptyMetadata
-        transferExtraAuth = [allocationSender allocation]
+        senders = [sender]
+        requiredReceiverAuth = (defaultAllocationControllers allocation) \\ (sender::allocationControllers allocation)
 
-      allocation_executeTransferImpl _self Allocation_ExecuteTransfer{..} = transferAmuletAllocation this extraArgs
+      allocation_executeTransferImpl self Allocation_ExecuteTransfer{..} = case extraAuth of
+        [] ->  transferAmuletAllocation this extraArgs
+        ea -> collectAuthAndSettle (fromInterfaceContractId self) extraArgs ea []
 
       allocation_withdrawImpl _self Allocation_Withdraw{..} = do
         senderHoldingCids <- unlockAmuletAllocation this extraArgs
@@ -56,7 +68,12 @@ template AmuletAllocation
             senderHoldingCids
             meta = emptyMetadata
 
-      allocation_executeAuthorizeIncomingImpl = error "unimplemented"
+      allocation_executeAuthorizeIncomingImpl _self Allocation_AuthorizeIncoming{..} = do
+        cid <- create AmuletAllocationTransferAuthorization with 
+          allocation
+          receiver = sender
+          admin
+        return $ toInterfaceContractId cid
 
     interface instance AllocationV1.Allocation for AmuletAllocation where
       view = allocation_view_v2_to_v1 (view (toInterface @Allocation this))
@@ -65,46 +82,53 @@ template AmuletAllocation
       AllocationV1.allocation_withdrawImpl = allocation_v1_withdrawImpl (toInterface @Allocation this)
       AllocationV1.allocation_cancelImpl = allocation_v1_cancelImpl (toInterface @Allocation this)
 
-allocationInstrumentAdmin : AllocationSpecification -> Party
-allocationInstrumentAdmin AllocationSpecification{..} =
-  let tl::_ = (TextMap.toList transferLegs)
-  in tl._2.instrumentId.admin
+    choice AmuletAllocation_InternalSettleWithExtraAuth : Allocation_ExecuteTransferResult
+      with
+        extraArgs : ExtraArgs
+        extraControllers : [Party]
+      controller extraControllers ++ allocationControllers allocation
+      do transferAmuletAllocation this extraArgs 
 
--- Amulet only supports a single sender!
-allocationSender : AllocationSpecification -> Party
-allocationSender AllocationSpecification{..} =
-  let tl::_ = (TextMap.toList transferLegs)
-  in tl._2.sender
 
-allocationInstrumentReceivers : AllocationSpecification -> [Party]
-allocationInstrumentReceivers AllocationSpecification{..} =
+
+allocationReceivers : AllocationSpecification -> [Party]
+allocationReceivers AllocationSpecification{..} =
   dedupSort $ map ((.receiver) . snd) (TextMap.toList transferLegs)
 
 -- Allocation usage
 -------------------
 
-allocationToTwoStepTransfer : AllocationSpecification -> TwoStepTransfer
-allocationToTwoStepTransfer allocation =
+allocationToTwoStepTransfer : Party -> Party -> AllocationSpecification -> TwoStepTransfer
+allocationToTwoStepTransfer sender admin allocation =
   TwoStepTransfer with
-    dso = transferLeg.instrumentId.admin
-    sender = transferLeg.sender
-    receiver = transferLeg.receiver
-    amount = transferLeg.amount
+    dso = admin
+    sender = sender
+    outputs
     provider = allocation.settlement.executor
     transferBefore = allocation.settlement.settleBefore
     transferBeforeDeadline = "allocation.settlement.settleBefore"
     allowFeaturing = True
     lockContext = Text.implode
       -- We don't show more context to avoid bloating the response here.
-      ["allocation for transfer leg ", show transferLegId, " to ", show transferLeg.receiver]
+      ["allocation for settlement ", allocation.settlement.settlementRef.id]
   where
-    (transferLegId, transferLeg) = case TextMap.toList allocation.transferLegs of
-      [tl] -> tl
-      _ -> error "Only one leg supported" -- TODO.
+    senderLegs = filter (\tl -> tl.sender == sender) $ map snd (TextMap.toList allocation.transferLegs)
+    outputs = map (\tl -> (tl.receiver, tl.amount)) senderLegs
+
+collectAuthAndSettle : ContractId AmuletAllocation -> ExtraArgs -> [ContractId AllocationTransferAuthorization] -> [Party] -> Update Allocation_ExecuteTransferResult
+collectAuthAndSettle allocationCid extraArgs extraAuth extraControllers = do
+  case extraAuth of
+    eaCid::eas -> exercise (fromInterfaceContractId @AmuletAllocationTransferAuthorization eaCid) AmuletAllocationTransferAuthorization_AuthorizeTransfer with
+      extraAuth = eas
+      extraControllers
+      ..
+    [] -> exercise allocationCid AmuletAllocation_InternalSettleWithExtraAuth with
+      extraArgs
+      extraControllers
 
 transferAmuletAllocation : AmuletAllocation -> ExtraArgs -> Update Allocation_ExecuteTransferResult
 transferAmuletAllocation amuletAllocation extraArgs = do
-  let twoStepTransfer = allocationToTwoStepTransfer amuletAllocation.allocation
+  let twoStepTransfer = allocationToTwoStepTransfer amuletAllocation.sender amuletAllocation.admin amuletAllocation.allocation
   (senderHoldingCids, receiverHoldingCids, meta) <-
     executeTwoStepTransfer twoStepTransfer amuletAllocation.lockedAmulet extraArgs
   pure Allocation_ExecuteTransferResult
@@ -115,5 +139,40 @@ transferAmuletAllocation amuletAllocation extraArgs = do
 
 unlockAmuletAllocation : AmuletAllocation -> ExtraArgs -> Update [ContractId Holding]
 unlockAmuletAllocation amuletAllocation extraArgs = do
-  let twoStepTransfer = allocationToTwoStepTransfer amuletAllocation.allocation
+  let twoStepTransfer = allocationToTwoStepTransfer amuletAllocation.sender amuletAllocation.admin amuletAllocation.allocation
   abortTwoStepTransfer twoStepTransfer amuletAllocation.lockedAmulet extraArgs
+
+template AmuletAllocationTransferAuthorization
+  with
+    allocation : AllocationSpecification
+    receiver : Party
+    admin : Party
+  where
+    signatory admin, receiver, allocation.settlement.executor     
+
+    interface instance AllocationTransferAuthorization for AmuletAllocationTransferAuthorization where
+      view = AllocationTransferAuthorizationView with 
+        allocation
+        receiver
+        admin
+
+    choice AmuletAllocationTransferAuthorization_AuthorizeTransfer : Allocation_ExecuteTransferResult
+      with
+        allocationCid : ContractId AmuletAllocation 
+        extraArgs : ExtraArgs
+        extraAuth : [ContractId AllocationTransferAuthorization]
+        extraControllers : [Party]
+      controller extraControllers ++ allocation.settlement.executor :: fromSome (allocation.settlement.controllerOverride) -- should never be None if this is called.
+      do
+        -- Validate that the receiver is only a receiver on a matching settlement
+        amuletAllocation <- fetch allocationCid
+        let allocation' = amuletAllocation.allocation
+        allocation === allocation'
+        admin === amuletAllocation.admin
+        receiver =/= amuletAllocation.sender
+        let receivers = allocationReceivers allocation
+        assertMsg ("Receiver " <> show receiver <> " not found in receivers " <> show receivers)
+          (receiver `elem` receivers)
+        -- Transfer with added authority.
+        collectAuthAndSettle allocationCid extraArgs extraAuth (receiver::extraControllers)
+

daml/splice-amulet/daml/Splice/AmuletTransferInstruction.daml

@@ -64,8 +64,7 @@ standardTransferToTwoStepTransfer transfer =
     dso = transfer.instrumentId.admin
     sender = transfer.sender
     provider = transfer.sender
-    receiver = transfer.receiver
-    amount = transfer.amount
+    outputs = [(transfer.receiver, transfer.amount)]
     transferBefore = transfer.executeBefore
     transferBeforeDeadline = "Transfer.executeBefore"
     allowFeaturing = False -- unfeatured as the sender is serving as its own "app provider"

daml/splice-amulet/daml/Splice/ExternalPartyAmuletRules.daml

@@ -365,7 +365,7 @@ amulet_allocationFactory_allocateImpl
   -> Update AllocationInstructionResult
 amulet_allocationFactory_allocateImpl externalAmuletRules _self arg = do
   let dso = externalAmuletRules.dso
-  let AllocationFactory_Allocate {allocation, requestedAt, inputHoldingCids, extraArgs} = arg
+  let AllocationFactory_Allocate {allocation, requestedAt, inputHoldingCids, extraArgs, creator} = arg
   -- validate call to factory and retrieve context
   requireExpectedAdminMatch arg.expectedAdmin dso
 
@@ -409,13 +409,16 @@ amulet_allocationFactory_allocateImpl externalAmuletRules _self arg = do
   require "At least one input holding must be provided" (not $ null inputHoldingCids)
 
   -- lock the funds
-  let twoStepTransfer = allocationToTwoStepTransfer arg.allocation
+  let sender = creator
+  let twoStepTransfer = allocationToTwoStepTransfer sender dso arg.allocation
   (lockedAmulet, senderChangeCids, meta) <-
     prepareTwoStepTransfer twoStepTransfer arg.requestedAt inputHoldingCids paymentContext
   -- create the amulet allocation
   allocationCid <- toInterfaceContractId <$> create AmuletAllocation with
     allocation = arg.allocation
     lockedAmulet
+    admin = dso
+    sender
 
   -- finaly done: return the result
   pure AllocationInstructionResult with

daml/splice-wallet-test/daml/Splice/Scripts/TestWallet.daml

@@ -1106,22 +1106,22 @@ testTokenStandardAllocate = script do
         meta = emptyMetadata
   let aliceLeg = mkTransfer alice alice 100.0
 
-  -- alice proposes trade with herself
-  proposalCid <- submit alice $ createCmd OTCTradeProposal with
+  -- provider proposes a trade for alice with herself
+  now <- getTime
+  let settleBefore = now `addRelTime` hours 2
+  proposalCid <- submit provider $ createCmd OTCTrade with
     venue = provider
-    tradeCid = None
     transferLegs = TextMap.fromList [("leg0", aliceLeg)]
-    approvers = [alice]
+    prepareUntil = now `addRelTime` hours 1
+    settleBefore
+    createdAt = now
+
 
   -- provider initiates settlement
-  now <- getTime
-  let settleBefore = now `addRelTime` hours 2
   _ <- submit provider $
-    exerciseCmd proposalCid OTCTradeProposal_InitiateSettlement with
-      prepareUntil = now `addRelTime` hours 1
-      settleBefore
+    exerciseCmd proposalCid OTCTrade_RequestAllocations with
 
-  [aliceAlloc] <- WalletClient.listRequestedAllocations alice amuletId
+  [aliceAlloc] <- WalletClient.listRequestedAllocationsForAdmin alice amuletId.admin
 
   holdingCid <- AmuletRegistry.tapFaucet registry alice 200.0
 
@@ -1131,6 +1131,7 @@ testTokenStandardAllocate = script do
     inputHoldingCids = [coerceInterfaceContractId holdingCid]
     requestedAt = now
     extraArgs = emptyExtraArgs
+    creator = alice
 
   result <- submitMulti [aliceValidator] [alice, registry.dso] $ exerciseCmd aliceInstall WalletAppInstall_AllocationFactory_Allocate with
     allocationFactory = enrichedChoice.factoryCid

daml/splice-wallet/daml/Splice/Wallet/Install.daml

@@ -15,7 +15,6 @@ import qualified Splice.Api.Token.AllocationV2
 import qualified Splice.Api.Token.AllocationInstructionV2
 import qualified Splice.Api.Token.TransferInstructionV2
 import Splice.Amulet
-import Splice.AmuletAllocation (allocationSender)
 import Splice.Amulet.TokenApiUtils
 import Splice.Types
 import Splice.AmuletRules
@@ -640,7 +639,8 @@ template WalletAppInstall
         withdrawArg : Splice.Api.Token.AllocationV2.Allocation_Withdraw
       controller validatorParty
       do allocation <- fetchCheckedInterface (ForDso dsoParty) allocationCid
-         let sender = allocationSender (view allocation).allocation
+          -- Amulet only supports a single sender per allocation
+         let [sender] = (view allocation).senders
          require ("sender " <> show sender <> " must match endUserParty " <> show endUserParty) (sender == endUserParty)
          exercise allocationCid withdrawArg
 

token-standard/splice-api-token-allocation-instruction-v2/daml/Splice/Api/Token/AllocationInstructionV2.daml

@@ -34,6 +34,9 @@ data AllocationInstructionView = AllocationInstructionView with
       -- ^ The holdings to be used to fund the allocation.
       --
       -- MAY be empty for registries that do not represent their holdings on-ledger.
+    senders : [Party]
+      -- ^ The senders of the allocation - who typically instructed the allocation instruction
+      -- and later appear on the Allocation as senders.
     meta : Metadata
       -- ^ Additional metadata specific to the allocation instruction, used for
       -- extensibility; e.g., more detailed status information.
@@ -57,7 +60,7 @@ interface AllocationInstruction where
     with
       extraArgs : ExtraArgs
         -- ^ Additional context required in order to exercise the choice.
-    controller allocationSenders (view this).allocation
+    controller (view this).senders
     do allocationInstruction_withdrawImpl this self arg
 
   choice AllocationInstruction_Update : AllocationInstructionResult
@@ -124,7 +127,8 @@ interface AllocationFactory where
         -- deliberate contention on holdings to prevent duplicate allocations.
       extraArgs : ExtraArgs
         -- ^ Additional choice arguments.
-    controller allocationSenders allocation
+      creator : Party
+    controller creator
     do allocationFactory_allocateImpl this self arg
 
   nonconsuming choice AllocationFactory_PublicFetch : AllocationFactoryView