Add pending set to DAML triggers (digital-asset#3502)

fixes digital-asset#3360
kgeonw · Nov 18, 2019 · 5458053 · 5458053
1 parent d654d75
commit 5458053
Show file tree

Hide file tree

Showing 7 changed files with 147 additions and 21 deletions.
diff --git a/docs/source/triggers/template-root/src/CopyTrigger.daml b/docs/source/triggers/template-root/src/CopyTrigger.daml
@@ -91,7 +91,7 @@ copyRule party acs commandsInFlight () = do
 -- ARCHIVE_COPIES_END
 
 -- ARCHIVE_COMMAND_BEGIN
-  forA archiveCopies $ \cid -> emitCommands [exerciseCmd @Copy cid Archive]
+  forA archiveCopies $ \cid -> dedupExercise cid Archive
 -- ARCHIVE_COMMAND_END
 
 -- CREATE_COPIES_BEGIN

diff --git a/triggers/daml/Daml/Trigger.daml b/triggers/daml/Daml/Trigger.daml
@@ -42,17 +42,21 @@ import qualified Daml.Trigger.LowLevel as LowLevel
 -- a given type.
 
 -- This will change to a Map once we have proper maps in DAML-LF
-newtype ACS = ACS [(AnyContractId, AnyTemplate)]
+data ACS = ACS
+  { activeContracts : [(AnyContractId, AnyTemplate)]
+  , pendingContracts : Map CommandId [AnyContractId]
+  }
 
 {-# DEPRECATED getTemplates "getTemplates is deprecated in favor of getContracts" #-}
 getTemplates : forall a. Template a => ACS -> [(ContractId a, a)]
 getTemplates = getContracts
 
 -- | Extract the contracts of a given template from the ACS.
 getContracts : forall a. Template a => ACS -> [(ContractId a, a)]
-getContracts (ACS tpls) = mapOptional fromAny tpls
+getContracts (ACS tpls pending) = mapOptional fromAny $ filter (\(cid, _) -> not $ cid `elem` allPending) tpls
   where
     fromAny (cid, tpl) = (,) <$> fromAnyContractId cid <*> fromAnyTemplate tpl
+    allPending = concatMap snd $ Map.toList pending
 
 -- | This is the type of your trigger. `s` is the user-defined state type which
 -- you can often leave at `()`.
@@ -76,12 +80,20 @@ newtype TriggerA a = TriggerA (State TriggerAState a)
   deriving (Functor, Applicative, Action)
 
 -- | Send a transaction consisting of the given commands to the ledger.
-emitCommands : [Command] -> TriggerA CommandId
-emitCommands cmds = do
+-- The second argument can be used to mark a list of contract ids as pending.
+-- These contracts will automatically be filtered from getContracts until we
+-- either get the corresponding transaction event for this command or
+-- a failing completion.
+emitCommands : [Command] -> [AnyContractId] -> TriggerA CommandId
+emitCommands cmds pending = do
   state <- TriggerA get
   let id = CommandId $ show $ state.nextCommandId
   let commands = Commands id cmds
-  TriggerA $ modify $ \s -> s { emittedCommands = commands :: s.emittedCommands, nextCommandId = s.nextCommandId + 1 }
+  TriggerA $ modify $ \s -> s
+    { emittedCommands = commands :: s.emittedCommands
+    , pendingContracts = Map.insert id pending s.pendingContracts
+    , nextCommandId = s.nextCommandId + 1
+    }
   pure id
 
 -- | Create the template if it’s not already in the list of commands
@@ -98,14 +110,17 @@ dedupCreate t = do
   -- map to make these lookups cheaper.
   let cmds = concat $ map snd (Map.toList aState.commandsInFlight) <> map commands aState.emittedCommands
   unless (any ((Some t ==) . fromCreate) cmds) $
-    void $ emitCommands [createCmd t]
+    void $ emitCommands [createCmd t] []
 
 -- | Exercise the choice on the given contract if it is not already
 -- in flight.
 --
 -- Note that this will send the exercise as a single-command transaction.
 -- If you need to send multiple commands in one transaction, use
 -- `emitCommands` with `exerciseCmd` and handle filtering yourself.
+--
+-- If you are calling a consuming choice, you might be better off by using
+-- `emitCommands` and adding the contract id to the pending set.
 dedupExercise : (Eq c, Choice t c r) => ContractId t -> c -> TriggerA ()
 dedupExercise cid c = do
   aState <- TriggerA get
@@ -114,7 +129,7 @@ dedupExercise cid c = do
   -- map to make these lookups cheaper.
   let cmds = concat $ map snd (Map.toList aState.commandsInFlight) <> map commands aState.emittedCommands
   unless (any ((Some (cid, c) ==) . fromExercise) cmds) $
-    void $ emitCommands [exerciseCmd cid c]
+    void $ emitCommands [exerciseCmd cid c] []
 
 -- | Exercise the choice on the given contract if it is not already
 -- in flight.
@@ -130,7 +145,7 @@ dedupExerciseByKey k c = do
   -- map to make these lookups cheaper.
   let cmds = concat $ map snd (Map.toList aState.commandsInFlight) <> map commands aState.emittedCommands
   unless (any ((Some (k, c) ==) . fromExerciseByKey @t) cmds) $
-    void $ emitCommands [exerciseByKeyCmd @t k c]
+    void $ emitCommands [exerciseByKeyCmd @t k c] []
 
 -- | Transform the high-level trigger type into the one from `Daml.Trigger.LowLevel`.
 runTrigger : Trigger s -> LowLevel.Trigger (TriggerState s)
@@ -140,7 +155,7 @@ runTrigger userTrigger = LowLevel.Trigger
   }
   where
     initialState party (ActiveContracts createdEvents) =
-      let acs = foldl (\acs created -> applyEvent (CreatedEvent created) acs) (ACS []) createdEvents
+      let acs = foldl (\acs created -> applyEvent (CreatedEvent created) acs) (ACS [] Map.empty) createdEvents
           userState = userTrigger.initialize acs
           state = TriggerState acs party userState Map.empty 0
       in runRule userTrigger.rule state
@@ -155,16 +170,17 @@ runTrigger userTrigger = LowLevel.Trigger
               (state { userState }, [] )
             Failed {} ->
                 let commandsInFlight = Map.delete completion.commandId state.commandsInFlight
-                    state' = state { commandsInFlight, userState }
+                    acs = state.acs { pendingContracts = Map.delete completion.commandId state.acs.pendingContracts }
+                    state' = state { commandsInFlight, userState, acs }
                 in runRule userTrigger.rule state'
         MTransaction transaction ->
           let acs = applyTransaction transaction state.acs
               userState = userTrigger.updateState acs (MTransaction transaction) state.userState
               -- See the comment above for why we delete this here instead of when we receive the completion.
-              commandsInFlight = case transaction.commandId of
-                None -> state.commandsInFlight
-                Some commandId -> Map.delete commandId state.commandsInFlight
-              state' = state { acs, userState, commandsInFlight }
+              (acs', commandsInFlight) = case transaction.commandId of
+                None -> (acs, state.commandsInFlight)
+                Some commandId -> (acs { pendingContracts = Map.delete commandId acs.pendingContracts }, Map.delete commandId state.commandsInFlight)
+              state' = state { acs = acs', userState, commandsInFlight }
           in runRule userTrigger.rule state'
 
 -- Internal API
@@ -173,14 +189,14 @@ addCommands : Map CommandId [Command] -> Commands -> Map CommandId [Command]
 addCommands m (Commands cid cmds) = Map.insert cid cmds m
 
 insertTpl : AnyContractId -> AnyTemplate -> ACS -> ACS
-insertTpl cid tpl (ACS acs) = ACS ((cid, tpl) :: acs)
+insertTpl cid tpl acs = acs { activeContracts = (cid, tpl) :: acs.activeContracts }
 
 deleteTpl : AnyContractId -> ACS -> ACS
-deleteTpl cid (ACS acs) = ACS (filter (\(cid', _) -> cid /= cid') acs)
+deleteTpl cid acs = acs { activeContracts = filter (\(cid', _) -> cid /= cid') acs.activeContracts }
 
 lookupTpl : Template a => AnyContractId -> ACS -> Optional a
-lookupTpl cid (ACS acs) = do
-  (_, tpl) <- find ((cid ==) . fst) acs
+lookupTpl cid acs = do
+  (_, tpl) <- find ((cid ==) . fst) $ acs.activeContracts
   fromAnyTemplate tpl
 
 applyEvent : Event -> ACS -> ACS
@@ -199,9 +215,10 @@ runRule rule state =
   let (_, aState) =
         runTriggerA
           (rule state.party state.acs state.commandsInFlight state.userState)
-          (TriggerAState state.commandsInFlight [] state.nextCommandId)
+          (TriggerAState state.commandsInFlight [] state.acs.pendingContracts state.nextCommandId)
       commandsInFlight = foldl addCommands state.commandsInFlight aState.emittedCommands
-  in (state { nextCommandId = aState.nextCommandId, commandsInFlight }, aState.emittedCommands)
+      acs = state.acs { pendingContracts = aState.pendingContracts }
+  in (state { nextCommandId = aState.nextCommandId, commandsInFlight, acs }, aState.emittedCommands)
 
 runTriggerA : TriggerA a -> TriggerAState -> (a, TriggerAState)
 runTriggerA (TriggerA f) s =
@@ -216,7 +233,10 @@ data TriggerAState = TriggerAState
   -- This will be used for dedupCreateCmd/dedupExerciseCmd helpers.
   , emittedCommands : [Commands]
   -- ^ Emitted commands in reverse because I can’t be bothered to implement a dlist.
+  , pendingContracts : Map CommandId [AnyContractId]
+  -- ^ Map from command ids to the contract ids marked pending by that command.
   , nextCommandId : Int
+  -- ^ Command id used for the next submit
   }
 
 data TriggerState s = TriggerState

diff --git a/triggers/tests/BUILD.bazel b/triggers/tests/BUILD.bazel
@@ -27,6 +27,7 @@ genrule(
       cp -L $(location :daml/ExerciseByKey.daml) $$TMP_DIR/daml
       cp -L $(location :daml/Numeric.daml) $$TMP_DIR/daml
       cp -L $(location :daml/CommandId.daml) $$TMP_DIR/daml
+      cp -L $(location :daml/PendingSet.daml) $$TMP_DIR/daml
       cp -L $(location //docs:source/triggers/template-root/src/CopyTrigger.daml) $$TMP_DIR/daml
       cp -L $(location //triggers/daml:daml-trigger.dar) $$TMP_DIR/
       cat << EOF > $$TMP_DIR/daml.yaml

diff --git a/triggers/tests/daml/PendingSet.daml b/triggers/tests/daml/PendingSet.daml
@@ -0,0 +1,57 @@
+-- Copyright (c) 2019 The DAML Authors. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+daml 1.2
+module PendingSet where
+
+import DA.Foldable (mapA_)
+import DA.Next.Map (Map)
+import Daml.Trigger
+
+template Foo
+  with
+    p : Party
+  where
+    signatory p
+
+template Boo
+  with
+    p : Party
+  where
+    signatory p
+    controller p can
+      nonconsuming ArchiveFoo: ()
+        with
+          fooCids : [ContractId Foo]
+        do mapA_ archive fooCids
+           assert (length fooCids == 2)
+           create Done with p
+           pure ()
+
+template Done
+  with
+    p : Party
+  where
+    signatory p
+
+booTrigger : Trigger ()
+booTrigger = Trigger with
+  initialize = \acs -> ()
+  updateState = \acs _ s -> s
+  rule = booRule
+
+booRule : Party -> ACS -> Map CommandId [Command] -> () -> TriggerA ()
+booRule party acs _commandsInFlight _userState = do
+  let foos : [(ContractId Foo, Foo)] = getContracts @Foo acs
+  let boos : [(ContractId Boo, Boo)] = getContracts @Boo acs
+  case (boos, foos) of
+    ([], []) -> do
+      -- initialization so we don’t have to create contracts from Scala
+      _ <- emitCommands [createCmd (Foo party), createCmd (Foo party), createCmd (Boo party)] []
+      pure ()
+    (boo :: _, _ :: _) -> do
+      let cids = map fst foos
+      _ <- emitCommands [exerciseCmd (fst boo) ArchiveFoo with fooCids = cids] (map toAnyContractId cids)
+      pure ()
+    _ -> pure ()
+
diff --git a/triggers/tests/list-triggers.sh b/triggers/tests/list-triggers.sh
@@ -30,6 +30,7 @@ DAR=$(rlocation "$TEST_WORKSPACE/$2")
 OUTPUT="$($TRIGGER_EXE list --dar $DAR | tail -n '+2' | tr -d '\r')"
 EXPECTED="\
   CommandId:test
+  PendingSet:booTrigger
   CopyTrigger:copyTrigger
   ExerciseByKey:exerciseByKeyTrigger
   Numeric:test

diff --git a/triggers/tests/src/test/scala/com/digitalasset/daml/lf/engine/trigger/test/TestMain.scala b/triggers/tests/src/test/scala/com/digitalasset/daml/lf/engine/trigger/test/TestMain.scala
@@ -750,6 +750,47 @@ case class CommandIdTests(dar: Dar[(PackageId, Package)], runner: TestRunner) {
   }
 }
 
+case class PendingTests(dar: Dar[(PackageId, Package)], runner: TestRunner) {
+
+  val triggerId: Identifier =
+    Identifier(dar.main._1, QualifiedName.assertFromString("PendingSet:booTrigger"))
+
+  val fooId = Identifier(dar.main._1, QualifiedName.assertFromString("PendingSet:Foo"))
+  val booId = Identifier(dar.main._1, QualifiedName.assertFromString("PendingSet:Boo"))
+  val doneId = Identifier(dar.main._1, QualifiedName.assertFromString("PendingSet:Done"))
+
+  def test(name: String, numMessages: NumMessages, expectedNumFoo: Int, expectedNumBoo: Int) = {
+    def assertFinalState(finalState: SExpr, commandsR: Unit) = Right(())
+    def assertFinalACS(
+        acs: Map[Identifier, Seq[(String, Lf.ValueRecord[Lf.AbsoluteContractId])]],
+        commandsR: Unit) = {
+      val numDone = acs.get(doneId).fold(0)(_.size)
+      val numFoo = acs.get(fooId).fold(0)(_.size)
+      val numBoo = acs.get(booId).fold(0)(_.size)
+      TestRunner.assertEqual(numDone, 1, "active Done")
+      TestRunner.assertEqual(numFoo, expectedNumFoo, "active Foo")
+      TestRunner.assertEqual(numBoo, expectedNumBoo, "active Boo")
+    }
+    runner.genericTest(name, dar, triggerId, (_, _) => {
+      implicit ec: ExecutionContext => implicit mat: ActorMaterializer =>
+        Future.unit
+    }, numMessages, assertFinalState, assertFinalACS)
+  }
+
+  def runTests() = {
+    test(
+      "pending set",
+      // 1 for the creates at startup
+      // 1 for the completion from startup
+      // 1 for the exercise in the trigger
+      // 1 for the completion in the trigger
+      NumMessages(4),
+      expectedNumFoo = 0,
+      expectedNumBoo = 1
+    )
+  }
+}
+
 object TestMain {
 
   private val configParser = new scopt.OptionParser[Config]("acs_test") {
@@ -794,6 +835,7 @@ object TestMain {
         ExerciseByKeyTests(dar, runner).runTests()
         NumericTests(dar, runner).runTests()
         CommandIdTests(dar, runner).runTests()
+        PendingTests(dar, runner).runTests()
     }
   }
 }
diff --git a/unreleased.rst b/unreleased.rst
@@ -10,3 +10,8 @@ HEAD — ongoing
 --------------
 
 - [DAML Stdlib] Added the ``NumericScale`` typeclass, which improves the type inference for Numeric literals, and helps catch the creation of out-of-bound Numerics earlier in the compilation process.
+
+- [DAML Triggers] ``emitCommands`` now accepts an additional argument
+  that allows you to mark contracts as pending. Those contracts will
+  be automatically filtered from the result of ``getContracts`` until
+  we receive the corresponding completion/transaction.