Batch with HTLC

src/main/daml/Daml/Finance/Settlement/Batch.daml

@@ -3,7 +3,7 @@
 
 module Daml.Finance.Settlement.Batch where
 
-import DA.Action (foldlA)
+import DA.Action (foldlA, when)
 import DA.Map qualified as Map (fromList, lookup)
 import DA.Optional (catOptionals, fromSomeNote)
 import DA.Set (Set)
@@ -14,6 +14,7 @@ import Daml.Finance.Interface.Settlement.Batch qualified as Batch (Cancel(..), I
 import Daml.Finance.Interface.Settlement.Instruction qualified as Instruction (Cancel(..), Execute(..), I)
 import Daml.Finance.Interface.Settlement.Types (Allocation(..), Approval(..), InstructionKey(..), RoutedStep(..))
 import Daml.Finance.Interface.Types.Common.Types (Id(..), Parties)
+import Daml.Finance.Settlement.HTLC qualified as HTLC (verifyCanCancel, verifyRevealedState)
 import Daml.Finance.Settlement.Instruction (Instruction(..), mustAuthorizeHelper)
 
 -- | Type synonym for `Batch`.
@@ -22,6 +23,8 @@ type T = Batch
 -- | Allows you to atomically settle a set of settlement `Step`.
 template Batch
   with
+    useHTLC : Bool
+      -- ^ Whether to use HTLCs for the settlement.
     instructor : Party
       -- ^ Party instructing settlement (and the creation of the `Batch`).
     consenters : Parties
@@ -47,6 +50,7 @@ template Batch
         instructor; consenters; settlers; id; description; contextId
         routedSteps = routedSteps this.routedStepsWithInstructionId; settlementTime
       settle Batch.Settle{actors} = do
+        when useHTLC do HTLC.verifyRevealedState $ Left (instructor, id)
         assertMsg "Actors must intersect with settlers." $
           not $ Set.null $ actors `Set.intersection` settlers
         -- order instructions (such that they can be executed with passthroughs)
@@ -74,6 +78,7 @@ template Batch
             instructionIds this.routedStepsWithInstructionId
         pure $ catOptionals settledCids
       cancel Batch.Cancel{actors} = do
+        when useHTLC do HTLC.verifyCanCancel $ Left (instructor, id)
         let
           allMustAuthorize = mustAuthorizeHelper True actors
           cancelInstruction instruction = do

src/main/daml/Daml/Finance/Settlement/Factory.daml

@@ -32,6 +32,7 @@ template Factory
             createInstruction index routedStep =
               ( index + 1,
                 Instruction with
+                  useHTLC = False
                   instructor
                   consenters
                   settlers
@@ -50,6 +51,58 @@ template Factory
           instructionCids <- mapA (fmap toInterfaceContractId . create) instructions
           batchCid <- toInterfaceContractId <$>
             create Batch with
+              useHTLC = False
+              instructor
+              consenters
+              settlers
+              id
+              description
+              contextId
+              routedStepsWithInstructionId = zip routedSteps instructionIds
+              settlementTime
+          pure (batchCid, instructionCids)
+
+-- | Factory template that implements the `Factory` interface.
+-- It is used to create a set of settlement `Instruction`\s, and a `Batch` to atomically settle
+-- them using a HTLC.
+template FactoryWithHTLC
+  with
+    provider : Party
+      -- ^ Party providing the facility.
+    observers : Parties
+      -- ^ Observers.
+  where
+    signatory provider
+    observer observers
+
+    interface instance SettlementFactory.I for FactoryWithHTLC where
+      view = SettlementFactory.View with provider; observers
+      instruct SettlementFactory.Instruct {instructor; consenters; settlers; id; description;
+        contextId; routedSteps; settlementTime} = do
+          let
+            createInstruction index routedStep =
+              ( index + 1,
+                Instruction with
+                  useHTLC = True
+                  instructor
+                  consenters
+                  settlers
+                  batchId = id
+                  id = Id (show index)
+                  routedStep
+                  settlementTime
+                  allocation = Unallocated
+                  approval = Unapproved
+                  signedSenders = mempty
+                  signedReceivers = mempty
+                  observers = fromList [(show id, settlers)]
+              )
+            instructions = snd $ mapAccumL createInstruction 0 routedSteps
+            instructionIds = map (.id) instructions
+          instructionCids <- mapA (fmap toInterfaceContractId . create) instructions
+          batchCid <- toInterfaceContractId <$>
+            create Batch with
+              useHTLC = True
               instructor
               consenters
               settlers

src/main/daml/Daml/Finance/Settlement/HTLC.daml

@@ -0,0 +1,113 @@
+-- Copyright (c) 2024 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+module Daml.Finance.Settlement.HTLC where
+
+import DA.Text (sha256)
+import Daml.Finance.Interface.Types.Common.Types (Id(..), Parties)
+
+-- | Represents the state of a Hash Time Lock Contract (HTLC).
+data HTLCState
+  = Open
+    -- ^ The 'Open' state indicates that the HTLC is available for allocating and approving
+    -- instructions. In this state, parties involved can allocate and approve instructions.
+  | Locked
+    -- ^ The 'Locked' state signifies that the HTLC is no longer open for new allocations
+    -- or approvals. It implies that all necessary instructions have been allocated and approved,
+    -- and the HTLC is now waiting the secret to be revealed.
+  | Revealed Text
+    -- ^ The 'Revealed' state occurs when the secret associated with the HTLC has been disclosed.
+    -- Once the HTLC enters this state, it indicates that all conditions for the contract's
+    -- execution have been met, and the associated financial transactions can be settled.
+  deriving (Eq, Show)
+
+-- Type synonym for HTLC key.
+type HTLCKey = (Party, Id)
+
+-- | Hash time lock contract.
+template HTLC
+  with
+    batchId : Id
+      -- ^ Batch identifier.
+    instructor : Party
+      -- ^ Instructor.
+    consenters : Parties
+      -- ^ Consenters.
+    settlers : Parties
+     -- ^ Settlers.
+    observers : Parties
+      -- ^ Observers.
+    expiry : Time
+      -- ^ Lock expiry.
+    hash : Text
+      -- ^ Hash of the secret.
+    state : HTLCState
+      -- ^ HTLC state.
+  where
+    signatory instructor, consenters
+    observer settlers, observers
+
+    ensure case state of
+      Revealed secret -> sha256 secret == hash
+      _ -> True
+
+    key (instructor, batchId) : HTLCKey
+    maintainer key._1
+
+    -- Allows locking the HTLC, transitioning its state to 'Locked'.
+    choice Lock : ContractId HTLC
+      controller instructor
+      do
+        -- Additional checks for instructions can be added here.
+        verifyAnyState Open $ Right this
+        create this with state = Locked
+
+    -- Allows anyone to reveal the secret, transitioning the HTLC's state to 'Revealed'.
+    choice Reveal : ContractId HTLC
+      with
+        actor : Party
+          -- ^ Choice controller.
+        secret : Text
+          -- ^ Secret.
+      controller actor
+      do
+        verifyAnyState Locked $ Right this
+        create this with state = Revealed secret
+
+-- | Verifies if the HTLC is open for allocation and approvals.
+verifyAnyState : HTLCState -> Either HTLCKey HTLC -> Update ()
+verifyAnyState expectedState input = do
+  htlc <- getHTLC input
+  verifyExpirationStatus False (Right htlc)
+  assertMsg ("HTLC must be " <> show expectedState) $ htlc.state == expectedState
+
+-- | Verifies if the secret has been revealed for settlement.
+verifyRevealedState : Either HTLCKey HTLC -> Update ()
+verifyRevealedState input = do
+  htlc <- getHTLC input
+  verifyExpirationStatus False (Right htlc)
+  assertMsg "HTLC must be Revealed." case htlc.state of Revealed _ -> True; _ -> False
+
+-- | Verify if expiration status is as expected.
+verifyExpirationStatus : Bool -> Either HTLCKey HTLC -> Update ()
+verifyExpirationStatus shouldBeExpired input = do
+  htlc <- getHTLC input
+  now <- getTime
+  let hasExpired = now > htlc.expiry
+  assertMsg ("Expiration status must be " <> show shouldBeExpired) $ hasExpired == shouldBeExpired
+
+-- | Verify that a HTLC can be cancelled. HTLC can be cancelled if it is Open or expired.
+verifyCanCancel : Either HTLCKey HTLC -> Update ()
+verifyCanCancel input = do
+  htlc <- getHTLC input
+  now <- getTime
+  let
+    hasExpired = now > htlc.expiry
+    isOpen = htlc.state == Open
+  assertMsg ("In order to cancel, the HTLC must be Open or expired") $ isOpen || hasExpired
+
+-- | Get HTLC.
+getHTLC : Either HTLCKey HTLC -> Update HTLC
+getHTLC input = case input of
+  Left htlcKey -> snd <$> fetchByKey @HTLC htlcKey
+  Right htlc -> pure htlc

src/main/daml/Daml/Finance/Settlement/Instruction.daml

@@ -3,6 +3,7 @@
 
 module Daml.Finance.Settlement.Instruction where
 
+import DA.Action (when)
 import DA.List qualified as L (head)
 import DA.Set (Set)
 import DA.Set qualified as Set (fromList, insert, intersection, isSubsetOf, null, singleton, toList, union)
@@ -17,6 +18,7 @@ import Daml.Finance.Interface.Types.Common.Types (AccountKey, Id(..), Parties, P
 import Daml.Finance.Interface.Util.Disclosure qualified as Disclosure (I, View(..), flattenObservers)
 import Daml.Finance.Interface.Util.InterfaceKey (fetchInterfaceByKey)
 import Daml.Finance.Interface.Util.Lockable qualified as Lockable (Acquire(..), I, LockType(..), Release(..))
+import Daml.Finance.Settlement.HTLC qualified as HTLC (HTLCState(..), verifyAnyState, verifyCanCancel, verifyRevealedState)
 import Daml.Finance.Util.Disclosure (addObserversImpl, removeObserversImpl, setObserversImpl)
 
 -- | Type synonym for `Instruction`.
@@ -27,6 +29,8 @@ type T = Instruction
 -- - the receiver must define the receiving account
 template Instruction
   with
+    useHTLC : Bool
+      -- ^ Whether to use HTLCs for the settlement.
     instructor : Party
       -- ^ Party instructing settlement (and the creation of the `Instruction`).
     consenters : Parties
@@ -70,12 +74,13 @@ template Instruction
         instructor; consenters; settlers; batchId; id; routedStep; settlementTime
         allocation; approval; signedSenders; signedReceivers
       allocate Instruction.Allocate{actors; allocation} = do
+        when useHTLC do HTLC.verifyAnyState HTLC.Open $ Left (instructor, batchId)
         let
           allMustAuthorize = mustAuthorizeHelper True actors
           atLeastOneMustAuthorize = mustAuthorizeHelper False actors
         atLeastOneMustAuthorize $ Set.fromList [routedStep.custodian, routedStep.sender]
         assertMsg ("Allocation must be new. " <> context this) $ allocation /= this.allocation
-        releasedCid <- releasePreviousAllocation this actors
+        releasedCid <- releasePreviousAllocation this actors True
         -- allocate
         newAllocation <- case allocation of
           Pledge holdingCid -> do
@@ -126,12 +131,13 @@ template Instruction
           signedSenders = if newAllocation == Unallocated then mempty else actors
         pure (newInstructionCid, releasedCid)
       approve Instruction.Approve{actors; approval} = do
+        when useHTLC do HTLC.verifyAnyState HTLC.Open $ Left (instructor, batchId)
         let
           allMustAuthorize = mustAuthorizeHelper True actors
           atLeastOneMustAuthorize = mustAuthorizeHelper False actors
         atLeastOneMustAuthorize $ Set.fromList [routedStep.custodian, routedStep.receiver]
         assertMsg ("Approval must be new. " <> context this) $ approval /= this.approval
-        releasePreviousApproval this actors
+        releasePreviousApproval this actors True
         -- approve
         case approval of
           TakeDelivery receiverAccountKey -> do
@@ -164,6 +170,7 @@ template Instruction
           approval
           signedReceivers = if approval == Unapproved then mempty else actors
       execute Instruction.Execute{actors} = do
+        when useHTLC do HTLC.verifyRevealedState $ Left (instructor, batchId)
         let allMustAuthorize = mustAuthorizeHelper True actors
         allMustAuthorize $ Set.insert instructor consenters
         assertMsg ("Actors must intersect with settlers. " <> context this) $
@@ -249,10 +256,11 @@ template Instruction
               SettleOffledgerAcknowledge -> pure None
               _ -> abortOnOffledgerMix
       cancel Instruction.Cancel{actors} = do
+        when useHTLC do HTLC.verifyCanCancel $ Left (instructor, batchId)
         let allMustAuthorize = mustAuthorizeHelper True actors
         allMustAuthorize $ Set.insert instructor consenters
-        releasePreviousApproval this actors
-        releasePreviousAllocation this actors
+        releasePreviousApproval this actors False
+        releasePreviousAllocation this actors False
 
 -- | HIDE
 context : Instruction -> Text
@@ -298,11 +306,10 @@ undisclosePledge this@Instruction {settlers} holdingCid actors = Holding.undiscl
   (context this, settlers) (addSignatories this actors) holdingCid
 
 -- | HIDE
-releasePreviousAllocation : Instruction -> Parties -> Update (Optional (ContractId Holding.I))
-releasePreviousAllocation this@Instruction {allocation; signedSenders} actors = do
+releasePreviousAllocation : Instruction -> Parties -> Bool -> Update (Optional (ContractId Holding.I))
+releasePreviousAllocation this@Instruction{allocation; signedSenders} actors signedSendersMustAuthorize = do
   let allMustAuthorize = mustAuthorizeHelper True actors
-  -- signed senders must agree to release previous allocation
-  allMustAuthorize signedSenders
+  when signedSendersMustAuthorize $ allMustAuthorize signedSenders
   case allocation of
     Pledge holdingCid -> do
       holdingCid <- fromInterfaceContractId @Holding.I <$>
@@ -318,11 +325,10 @@ releasePreviousAllocation this@Instruction {allocation; signedSenders} actors =
     _ -> pure None
 
 -- | HIDE
-releasePreviousApproval : Instruction -> Parties -> Update (Optional (ContractId Account.I))
-releasePreviousApproval this@Instruction {approval; signedReceivers} actors = do
+releasePreviousApproval : Instruction -> Parties -> Bool -> Update (Optional (ContractId Account.I))
+releasePreviousApproval this@Instruction{approval; signedReceivers} actors signedReceiversMustAuthorize = do
   let allMustAuthorize = mustAuthorizeHelper True actors
-  -- signed receivers must authorize to release previous approval
-  allMustAuthorize signedReceivers
+  when signedReceiversMustAuthorize $ allMustAuthorize signedReceivers
   case approval of
     TakeDelivery receiverAccountKey -> undiscloseAccount this receiverAccountKey actors
     PassThroughTo (passThroughAccountKey, _) -> undiscloseAccount this passThroughAccountKey actors