diff --git a/docs/source/triggers/template-root/src/CopyTrigger.daml b/docs/source/triggers/template-root/src/CopyTrigger.daml index 128c37d57972..0f1cb5bce5e3 100644 --- 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 index 895955099a6d..20b126cad2a8 100644 --- a/triggers/daml/Daml/Trigger.daml +++ b/triggers/daml/Daml/Trigger.daml @@ -42,7 +42,10 @@ 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)] @@ -50,9 +53,10 @@ 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,7 +110,7 @@ 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. @@ -106,6 +118,9 @@ dedupCreate t = do -- 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 index b72716d9afcb..5961af3f3703 100644 --- 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 new file mode 100644 index 000000000000..2cab91f00223 --- /dev/null +++ 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 index 7ab37ce0a346..be0a01463ea6 100755 --- 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 index 54fc750ca5ea..9197b9c252f4 100644 --- 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 index da29030b375f..43dc6f3a9ea1 100644 --- 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.