queryContractId and queryContractKey for high-level triggers (#7726)

* queryContractId and queryContractKey, trivially

* add changelog

CHANGELOG_BEGIN
- [Triggers] Two new functions are available for querying the ACS:
  ``queryContractId``, for looking up a contract by ID, and ``queryContractKey``
  for looking one up by key.
  See `issue #7726 <https://github.com/digital-asset/daml/pull/7726>`__.
CHANGELOG_END

* more efficient, direct queryContractId implementation

* flip getContractById's arguments, avoid 'flip'

* test queryContractKey

* test queryContractId

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 `()`.

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)

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]

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 ()
 

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 ()