mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
Expose trigger actAs party via getActAs (#12296)
fixes #12125 changelog_begin changelog_end
This commit is contained in:
parent
2e735c3228
commit
18e1cc5601
@ -45,6 +45,7 @@ module Daml.Trigger
|
||||
, registeredTemplate
|
||||
, RelTime(..)
|
||||
, getReadAs
|
||||
, getActAs
|
||||
) where
|
||||
|
||||
import Prelude hiding (any)
|
||||
@ -107,6 +108,8 @@ class ActionTriggerAny m where
|
||||
|
||||
getReadAs : m [Party]
|
||||
|
||||
getActAs : m Party
|
||||
|
||||
instance ActionTriggerAny (TriggerA s) where
|
||||
implQuery = TriggerA $ pure . getContracts
|
||||
queryContractId id = TriggerA $ pure . getContractById id
|
||||
@ -115,17 +118,23 @@ instance ActionTriggerAny (TriggerA s) where
|
||||
s <- get
|
||||
pure s.readAs
|
||||
|
||||
getActAs = TriggerA $ \_ -> do
|
||||
s <- get
|
||||
pure s.actAs
|
||||
|
||||
instance ActionTriggerAny (TriggerUpdateA s) where
|
||||
implQuery = TriggerUpdateA $ \(_, acs, _) -> pure (getContracts acs)
|
||||
queryContractId id = TriggerUpdateA $ \(_, acs, _) -> pure (getContractById id acs)
|
||||
queryPendingContracts = TriggerUpdateA $ \(_, acs, _) -> pure (getPendingContracts acs)
|
||||
getReadAs = TriggerUpdateA $ \(_, _, readAs) -> pure readAs
|
||||
implQuery = TriggerUpdateA $ \s -> pure (getContracts s.acs)
|
||||
queryContractId id = TriggerUpdateA $ \s -> pure (getContractById id s.acs)
|
||||
queryPendingContracts = TriggerUpdateA $ \s -> pure (getPendingContracts s.acs)
|
||||
getReadAs = TriggerUpdateA $ \s -> pure s.readAs
|
||||
getActAs = TriggerUpdateA $ \s -> pure s.actAs
|
||||
|
||||
instance ActionTriggerAny TriggerInitializeA where
|
||||
implQuery = TriggerInitializeA (\(acs, _) -> getContracts acs)
|
||||
queryContractId id = TriggerInitializeA (\(acs, _) -> getContractById id acs)
|
||||
queryPendingContracts = TriggerInitializeA (\(acs, _) -> getPendingContracts acs)
|
||||
getReadAs = TriggerInitializeA (\(_, readAs) -> readAs)
|
||||
implQuery = TriggerInitializeA (\s -> getContracts s.acs)
|
||||
queryContractId id = TriggerInitializeA (\s -> getContractById id s.acs)
|
||||
queryPendingContracts = TriggerInitializeA (\s -> getPendingContracts s.acs)
|
||||
getReadAs = TriggerInitializeA (\s -> s.readAs)
|
||||
getActAs = TriggerInitializeA (\s -> s.actAs)
|
||||
|
||||
-- | Features possible in `updateState` and `rule`.
|
||||
class ActionTriggerAny m => ActionTriggerUpdate m where
|
||||
@ -136,7 +145,7 @@ class ActionTriggerAny m => ActionTriggerUpdate m where
|
||||
getCommandsInFlight : m (Map CommandId [Command])
|
||||
|
||||
instance ActionTriggerUpdate (TriggerUpdateA s) where
|
||||
getCommandsInFlight = TriggerUpdateA $ \(cif, _, _) -> pure cif
|
||||
getCommandsInFlight = TriggerUpdateA $ \s -> pure s.commandsInFlight
|
||||
|
||||
instance ActionTriggerUpdate (TriggerA s) where
|
||||
getCommandsInFlight = liftTriggerRule $ get <&> \s -> s.commandsInFlight
|
||||
@ -264,10 +273,12 @@ runTrigger userTrigger = LowLevel.Trigger
|
||||
where
|
||||
initialState party readAs (ActiveContracts createdEvents) =
|
||||
let acs = foldl (\acs created -> applyEvent (CreatedEvent created) acs) (ACS mempty Map.empty) createdEvents
|
||||
userState = runTriggerInitializeA userTrigger.initialize (acs, readAs)
|
||||
userState = runTriggerInitializeA userTrigger.initialize (TriggerInitState acs party readAs)
|
||||
state = TriggerState acs party readAs userState Map.empty
|
||||
in TriggerSetup $ execStateT (runTriggerRule $ runRule userTrigger.rule) state
|
||||
utUpdateState commandsInFlight acs readAs msg = execState $ flip runTriggerUpdateA (commandsInFlight, acs, readAs) $ userTrigger.updateState msg
|
||||
utUpdateState commandsInFlight acs actAs readAs msg =
|
||||
let state = TriggerUpdateState commandsInFlight acs actAs readAs
|
||||
in execState $ flip runTriggerUpdateA state $ userTrigger.updateState msg
|
||||
update msg = do
|
||||
time <- getTime
|
||||
state <- get
|
||||
@ -275,7 +286,7 @@ runTrigger userTrigger = LowLevel.Trigger
|
||||
MCompletion completion ->
|
||||
-- NB: the commands-in-flight and ACS updateState sees are those
|
||||
-- prior to updates incurred by the msg
|
||||
let userState = utUpdateState state.commandsInFlight state.acs state.readAs (MCompletion completion) state.userState
|
||||
let userState = utUpdateState state.commandsInFlight state.acs state.actAs state.readAs (MCompletion completion) state.userState
|
||||
in case completion.status of
|
||||
Succeeded {} ->
|
||||
-- We delete successful completions when we receive the corresponding transaction
|
||||
@ -289,7 +300,7 @@ runTrigger userTrigger = LowLevel.Trigger
|
||||
MTransaction transaction -> do
|
||||
let acs = applyTransaction transaction state.acs
|
||||
-- again, we use the commands-in-flight and ACS before the update below
|
||||
userState = utUpdateState state.commandsInFlight acs state.readAs (MTransaction transaction) state.userState
|
||||
userState = utUpdateState state.commandsInFlight acs state.actAs state.readAs (MTransaction transaction) state.userState
|
||||
-- See the comment above for why we delete this here instead of when we receive the completion.
|
||||
(acs', commandsInFlight) = case transaction.commandId of
|
||||
None -> (acs, state.commandsInFlight)
|
||||
@ -297,6 +308,6 @@ runTrigger userTrigger = LowLevel.Trigger
|
||||
put $ state { acs = acs', userState, commandsInFlight }
|
||||
runRule userTrigger.rule
|
||||
MHeartbeat -> do
|
||||
let userState = utUpdateState state.commandsInFlight state.acs state.readAs MHeartbeat state.userState
|
||||
let userState = utUpdateState state.commandsInFlight state.acs state.actAs state.readAs MHeartbeat state.userState
|
||||
put $ state { userState }
|
||||
runRule userTrigger.rule
|
||||
|
@ -67,7 +67,7 @@ testRule trigger party readAs acsBuilder commandsInFlight s = do
|
||||
acs <- buildACS party acsBuilder
|
||||
let state = TriggerState
|
||||
{ acs = acs
|
||||
, party = party
|
||||
, actAs = party
|
||||
, readAs = readAs
|
||||
, userState = s
|
||||
, commandsInFlight = commandsInFlight
|
||||
|
@ -20,6 +20,8 @@ module Daml.Trigger.Internal
|
||||
, liftTriggerRule
|
||||
, TriggerAState (..)
|
||||
, TriggerState (..)
|
||||
, TriggerInitState(..)
|
||||
, TriggerUpdateState(..)
|
||||
) where
|
||||
|
||||
import DA.Action.State
|
||||
@ -65,12 +67,20 @@ instance ActionState s (TriggerA s) where
|
||||
instance HasTime (TriggerA s) where
|
||||
getTime = TriggerA $ const getTime
|
||||
|
||||
-- | HIDE
|
||||
data TriggerUpdateState = TriggerUpdateState
|
||||
with
|
||||
commandsInFlight : Map CommandId [Command]
|
||||
acs : ACS
|
||||
actAs : Party
|
||||
readAs : [Party]
|
||||
|
||||
-- | TriggerUpdateA is the type used in the `updateState` of a Daml
|
||||
-- trigger. It has similar actions in common with `TriggerA`, but
|
||||
-- cannot use `emitCommands` or `getTime`.
|
||||
newtype TriggerUpdateA s a =
|
||||
-- | HIDE
|
||||
TriggerUpdateA { runTriggerUpdateA : (Map CommandId [Command], ACS, [Party]) -> State s a }
|
||||
TriggerUpdateA { runTriggerUpdateA : TriggerUpdateState -> State s a }
|
||||
|
||||
instance Functor (TriggerUpdateA s) where
|
||||
fmap f (TriggerUpdateA r) = TriggerUpdateA $ rliftFmap fmap f r
|
||||
@ -87,11 +97,18 @@ instance ActionState s (TriggerUpdateA s) where
|
||||
put = TriggerUpdateA . const . put
|
||||
modify = TriggerUpdateA . const . modify
|
||||
|
||||
-- | HIDE
|
||||
data TriggerInitState = TriggerInitState
|
||||
with
|
||||
acs : ACS
|
||||
actAs : Party
|
||||
readAs : [Party]
|
||||
|
||||
-- | TriggerInitializeA is the type used in the `initialize` of a Daml
|
||||
-- trigger. It can query, but not emit commands or update the state.
|
||||
newtype TriggerInitializeA a =
|
||||
-- | HIDE
|
||||
TriggerInitializeA { runTriggerInitializeA : (ACS, [Party]) -> a }
|
||||
TriggerInitializeA { runTriggerInitializeA : TriggerInitState -> a }
|
||||
deriving (Functor, Applicative, Action)
|
||||
|
||||
-- Internal API
|
||||
@ -142,14 +159,15 @@ runRule
|
||||
runRule rule = do
|
||||
state <- get
|
||||
TriggerRule . zoom zoomIn zoomOut . runTriggerRule . flip runTriggerA state.acs
|
||||
$ rule state.party
|
||||
where zoomIn state = TriggerAState state.commandsInFlight state.acs.pendingContracts state.userState state.readAs
|
||||
$ rule state.actAs
|
||||
where zoomIn state = TriggerAState state.commandsInFlight state.acs.pendingContracts state.userState state.readAs state.actAs
|
||||
zoomOut state aState =
|
||||
let commandsInFlight = aState.commandsInFlight
|
||||
acs = state.acs { pendingContracts = aState.pendingContracts }
|
||||
userState = aState.userState
|
||||
readAs = aState.readAs
|
||||
in state { commandsInFlight, acs, userState, readAs }
|
||||
actAs = aState.actAs
|
||||
in state { commandsInFlight, acs, userState, readAs, actAs }
|
||||
|
||||
-- | HIDE
|
||||
liftTriggerRule : TriggerRule (TriggerAState s) a -> TriggerA s a
|
||||
@ -167,12 +185,14 @@ data TriggerAState s = TriggerAState
|
||||
-- ^ zoomed from TriggerState
|
||||
, readAs : [Party]
|
||||
-- ^ zoomed from TriggerState
|
||||
, actAs : Party
|
||||
-- ^ zoomed from TriggerState
|
||||
}
|
||||
|
||||
-- | HIDE
|
||||
data TriggerState s = TriggerState
|
||||
{ acs : ACS
|
||||
, party : Party
|
||||
, actAs : Party
|
||||
, readAs : [Party]
|
||||
, userState : s
|
||||
, commandsInFlight : Map CommandId [Command]
|
||||
|
@ -42,6 +42,7 @@ DAML_LF_VERSIONS = [
|
||||
cp -L $(location :daml/Time.daml) $$TMP_DIR/daml
|
||||
cp -L $(location :daml/Heartbeat.daml) $$TMP_DIR/daml
|
||||
cp -L $(location :daml/ReadAs.daml) $$TMP_DIR/daml
|
||||
cp -L $(location :daml/ActAs.daml) $$TMP_DIR/daml
|
||||
cp -L $(location //templates:copy-trigger/src/CopyTrigger.daml) $$TMP_DIR/daml
|
||||
cp -L $(location //triggers/daml:daml-trigger{suffix}.dar) $$TMP_DIR/daml-trigger.dar
|
||||
cp -L $(location //daml-script/daml:daml-script{suffix}.dar) $$TMP_DIR/daml-script.dar
|
||||
|
39
triggers/tests/daml/ActAs.daml
Normal file
39
triggers/tests/daml/ActAs.daml
Normal file
@ -0,0 +1,39 @@
|
||||
-- Copyright (c) 2022 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
|
||||
-- SPDX-License-Identifier: Apache-2.0
|
||||
|
||||
|
||||
module ActAs where
|
||||
|
||||
import DA.Action
|
||||
import Daml.Trigger
|
||||
|
||||
-- We run until init, updateState and rule have finished and
|
||||
-- check that the parties are identical across the 3.
|
||||
|
||||
test : Trigger (Party, Bool, Bool)
|
||||
test = Trigger
|
||||
{ initialize = do
|
||||
p <- getActAs
|
||||
pure (p, False, False)
|
||||
, updateState = \_ -> do
|
||||
p <- getActAs
|
||||
(p', _, _) <- get
|
||||
unless (p == p') $ error "Inconsistent actAs parties"
|
||||
modify (\(a, _, b) -> (a, True, b))
|
||||
, rule = \p -> do
|
||||
p' <- getActAs
|
||||
(p'', _, _) <- get
|
||||
unless (p == p') $ error "Inconsistent actAs parties"
|
||||
unless (p == p'') $ error "Inconsistent actAs parties"
|
||||
modify (\(a, b, _) -> (a, b, True))
|
||||
_ <- emitCommands [createCmd (T p)] []
|
||||
pure ()
|
||||
, registeredTemplates = AllInDar
|
||||
, heartbeat = None
|
||||
}
|
||||
|
||||
template T
|
||||
with
|
||||
p : Party
|
||||
where
|
||||
signatory p
|
@ -17,6 +17,7 @@ import org.scalatest._
|
||||
import org.scalatest.matchers.should.Matchers
|
||||
import org.scalatest.wordspec.AsyncWordSpec
|
||||
import scalaz.syntax.traverse._
|
||||
import scala.jdk.CollectionConverters._
|
||||
|
||||
import com.daml.lf.engine.trigger.TriggerMsg
|
||||
|
||||
@ -558,5 +559,30 @@ abstract class AbstractFuncTests
|
||||
}
|
||||
}
|
||||
}
|
||||
"getActAs" should {
|
||||
"produce a consistent party" in {
|
||||
for {
|
||||
client <- ledgerClient()
|
||||
party <- allocateParty(client)
|
||||
runner = getRunner(
|
||||
client,
|
||||
QualifiedName.assertFromString("ActAs:test"),
|
||||
party,
|
||||
)
|
||||
(acs, offset) <- runner.queryACS()
|
||||
// 1 for the completion & 1 for the transaction.
|
||||
result <- runner.runWithACS(acs, offset, msgFlow = Flow[TriggerMsg].take(2))._2
|
||||
} yield {
|
||||
inside(toHighLevelResult(result).state) { case SRecord(_, _, values) =>
|
||||
// Check that both updateState and rule were executed.
|
||||
values.asScala shouldBe Seq[SValue](
|
||||
SParty(Party.assertFromString(party)),
|
||||
SBool(true),
|
||||
SBool(true),
|
||||
)
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
Loading…
Reference in New Issue
Block a user