diff --git a/triggers/daml/Daml/Trigger.daml b/triggers/daml/Daml/Trigger.daml index 7198f77078..c54304643f 100644 --- a/triggers/daml/Daml/Trigger.daml +++ b/triggers/daml/Daml/Trigger.daml @@ -5,6 +5,8 @@ module Daml.Trigger ( query + , queryContractId + , queryContractKey , ActionTriggerAny , Trigger(..) , TriggerA @@ -38,8 +40,10 @@ module Daml.Trigger , RelTime(..) ) where +import Prelude hiding (any) import DA.Action import DA.Action.State (execState) +import DA.Foldable (any) import DA.Functor ((<&>)) #ifdef DAML_GENMAP && DAML_GENERIC_COMPARISON import qualified DA.Map as GMap @@ -67,18 +71,38 @@ getContracts (ACS tpls pending) = mapOptional fromAny fromAny (cid, tpl) = (,) <$> fromAnyContractId cid <*> fromAnyTemplate tpl allPending = concatMap snd $ Map.toList pending +getContractById : forall a. Template a => ContractId a -> ACS -> Optional a +getContractById id (ACS tpls pending) = do + let aid = toAnyContractId id +#ifdef DAML_GENMAP && DAML_GENERIC_COMPARISON + implSpecific = GMap.lookup aid <=< GMap.lookup (templateTypeRep @a) +#else + implSpecific = fmap snd . find ((aid ==) . fst) +#endif + aa <- implSpecific tpls + a <- fromAnyTemplate aa + if any (elem aid) pending then None else Some a + -- | Extract the contracts of a given template from the ACS. query : forall a m. (Template a, ActionTriggerAny m) => m [(ContractId a, a)] query = implQuery +-- | Find the contract with the given `key` in the ACS, if present. +queryContractKey : forall a k m. (Template a, HasKey a k, Eq k, ActionTriggerAny m, Functor m) + => k -> m (Optional (ContractId a, a)) +queryContractKey k = find (\(_, a) -> k == key a) <$> query + instance ActionTriggerAny (TriggerA s) where implQuery = TriggerA $ pure . getContracts + queryContractId id = TriggerA $ pure . getContractById id instance ActionTriggerAny (TriggerUpdateA s) where implQuery = TriggerUpdateA $ pure . getContracts + queryContractId id = TriggerUpdateA $ pure . getContractById id instance ActionTriggerAny TriggerInitializeA where implQuery = TriggerInitializeA getContracts + queryContractId = TriggerInitializeA . getContractById -- | This is the type of your trigger. `s` is the user-defined state type which -- you can often leave at `()`. diff --git a/triggers/daml/Daml/Trigger/Assert.daml b/triggers/daml/Daml/Trigger/Assert.daml index 1af704f923..2519c378e4 100644 --- a/triggers/daml/Daml/Trigger/Assert.daml +++ b/triggers/daml/Daml/Trigger/Assert.daml @@ -17,8 +17,8 @@ import DA.Next.Map (Map) import qualified DA.Next.Map as Map import qualified DA.Text as Text -import Daml.Trigger -import Daml.Trigger.Internal +import Daml.Trigger hiding (queryContractId) +import Daml.Trigger.Internal hiding (queryContractId) import Daml.Trigger.LowLevel hiding (Trigger) import Daml.Script (Script, queryContractId) diff --git a/triggers/daml/Daml/Trigger/Internal.daml b/triggers/daml/Daml/Trigger/Internal.daml index 1bb615b0ab..2c17b3db56 100644 --- a/triggers/daml/Daml/Trigger/Internal.daml +++ b/triggers/daml/Daml/Trigger/Internal.daml @@ -103,6 +103,9 @@ class ActionTriggerAny m where -- type parameters are in the 'm a' order, so it is not exported.) implQuery : forall a. Template a => m [(ContractId a, a)] + -- | Find the contract with the given `id` in the ACS, if present. + queryContractId : Template a => ContractId a -> m (Optional a) + -- Internal API addCommands : Map CommandId [Command] -> Commands -> Map CommandId [Command] diff --git a/triggers/tests/daml/ExerciseByKey.daml b/triggers/tests/daml/ExerciseByKey.daml index f50b5a2e16..7e2a8051c0 100644 --- a/triggers/tests/daml/ExerciseByKey.daml +++ b/triggers/tests/daml/ExerciseByKey.daml @@ -22,12 +22,12 @@ exerciseByKeyTrigger = Trigger retryRule : Party -> TriggerA Int () retryRule party = do allowedRetries <- get - ts <- query @T + ts <- queryContractKey @T party t_s <- query @T_ case (ts, t_s) of - ([], _) -> + (None, _) -> dedupCreate T { p = party } - ((_, T { p = party' } ) :: _, []) | party == party' -> + (Some _, []) -> dedupExerciseByKey @T party C otherwise -> pure () diff --git a/triggers/tests/scenarios/Rule.daml b/triggers/tests/scenarios/Rule.daml index 2293b5f104..ac87aa0836 100644 --- a/triggers/tests/scenarios/Rule.daml +++ b/triggers/tests/scenarios/Rule.daml @@ -27,6 +27,12 @@ template T do pure () +-- not instances we want in the stdlib, but good enough for this test +instance CanAbort (TriggerA s) where + abort = error +instance ActionFail (TriggerA s) where + fail = error + trigger : Trigger Int trigger = Trigger with initialize = pure 0 @@ -46,9 +52,7 @@ trigger = Trigger with dedupExerciseByKey @T (party, 0) Poke with n = 1 newCIF <- getCommandsInFlight let changedCIF = Map.size (Map.filterWithKey (\k _ -> not (Map.member k priorCIF)) newCIF) - if (changedCIF == 4) - then pure () - else error $ show changedCIF <> " new commands in flight instead of 4" + assertEq changedCIF 4 put (-1) -- just introducing some chaos registeredTemplates = RegisteredTemplates [registeredTemplate @T] heartbeat = None @@ -71,3 +75,33 @@ test = do assertEq k (alice, 0) assertEq choiceArg (Poke 1) pure () + +queryIds : Trigger () +queryIds = Trigger with + initialize = pure () + updateState = const (pure ()) + rule = \party -> do + [(tId, queried), (tId', queried')] <- query @T + assertById tId queried + assertById tId' queried' + -- exercise leaves the contract there + dedupExercise tId Poke with n = 43 + assertById tId queried + -- emit will filter out after the rule runs + emitCommands [exerciseCmd tId Poke with n = 44] [toAnyContractId tId] + assertById tId queried + assertById tId' queried' + registeredTemplates = RegisteredTemplates [registeredTemplate @T] + heartbeat = None + +assertById tId lookedUp = do + Some c <- queryContractId tId + assertEq c lookedUp + +testQueryIds = do + alice <- Script.allocateParty "Alice" + tId <- submit alice do Script.createCmd T with party = alice, count = 42 + tId' <- submit alice do Script.createCmd T with party = alice, count = 43 + let activeContracts = toACS tId <> toACS tId' + let commandsInFlight = Map.empty + testRule queryIds alice activeContracts commandsInFlight ()