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
|
, registeredTemplate
|
||||||
, RelTime(..)
|
, RelTime(..)
|
||||||
, getReadAs
|
, getReadAs
|
||||||
|
, getActAs
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prelude hiding (any)
|
import Prelude hiding (any)
|
||||||
@ -107,6 +108,8 @@ class ActionTriggerAny m where
|
|||||||
|
|
||||||
getReadAs : m [Party]
|
getReadAs : m [Party]
|
||||||
|
|
||||||
|
getActAs : m Party
|
||||||
|
|
||||||
instance ActionTriggerAny (TriggerA s) where
|
instance ActionTriggerAny (TriggerA s) where
|
||||||
implQuery = TriggerA $ pure . getContracts
|
implQuery = TriggerA $ pure . getContracts
|
||||||
queryContractId id = TriggerA $ pure . getContractById id
|
queryContractId id = TriggerA $ pure . getContractById id
|
||||||
@ -115,17 +118,23 @@ instance ActionTriggerAny (TriggerA s) where
|
|||||||
s <- get
|
s <- get
|
||||||
pure s.readAs
|
pure s.readAs
|
||||||
|
|
||||||
|
getActAs = TriggerA $ \_ -> do
|
||||||
|
s <- get
|
||||||
|
pure s.actAs
|
||||||
|
|
||||||
instance ActionTriggerAny (TriggerUpdateA s) where
|
instance ActionTriggerAny (TriggerUpdateA s) where
|
||||||
implQuery = TriggerUpdateA $ \(_, acs, _) -> pure (getContracts acs)
|
implQuery = TriggerUpdateA $ \s -> pure (getContracts s.acs)
|
||||||
queryContractId id = TriggerUpdateA $ \(_, acs, _) -> pure (getContractById id acs)
|
queryContractId id = TriggerUpdateA $ \s -> pure (getContractById id s.acs)
|
||||||
queryPendingContracts = TriggerUpdateA $ \(_, acs, _) -> pure (getPendingContracts acs)
|
queryPendingContracts = TriggerUpdateA $ \s -> pure (getPendingContracts s.acs)
|
||||||
getReadAs = TriggerUpdateA $ \(_, _, readAs) -> pure readAs
|
getReadAs = TriggerUpdateA $ \s -> pure s.readAs
|
||||||
|
getActAs = TriggerUpdateA $ \s -> pure s.actAs
|
||||||
|
|
||||||
instance ActionTriggerAny TriggerInitializeA where
|
instance ActionTriggerAny TriggerInitializeA where
|
||||||
implQuery = TriggerInitializeA (\(acs, _) -> getContracts acs)
|
implQuery = TriggerInitializeA (\s -> getContracts s.acs)
|
||||||
queryContractId id = TriggerInitializeA (\(acs, _) -> getContractById id acs)
|
queryContractId id = TriggerInitializeA (\s -> getContractById id s.acs)
|
||||||
queryPendingContracts = TriggerInitializeA (\(acs, _) -> getPendingContracts acs)
|
queryPendingContracts = TriggerInitializeA (\s -> getPendingContracts s.acs)
|
||||||
getReadAs = TriggerInitializeA (\(_, readAs) -> readAs)
|
getReadAs = TriggerInitializeA (\s -> s.readAs)
|
||||||
|
getActAs = TriggerInitializeA (\s -> s.actAs)
|
||||||
|
|
||||||
-- | Features possible in `updateState` and `rule`.
|
-- | Features possible in `updateState` and `rule`.
|
||||||
class ActionTriggerAny m => ActionTriggerUpdate m where
|
class ActionTriggerAny m => ActionTriggerUpdate m where
|
||||||
@ -136,7 +145,7 @@ class ActionTriggerAny m => ActionTriggerUpdate m where
|
|||||||
getCommandsInFlight : m (Map CommandId [Command])
|
getCommandsInFlight : m (Map CommandId [Command])
|
||||||
|
|
||||||
instance ActionTriggerUpdate (TriggerUpdateA s) where
|
instance ActionTriggerUpdate (TriggerUpdateA s) where
|
||||||
getCommandsInFlight = TriggerUpdateA $ \(cif, _, _) -> pure cif
|
getCommandsInFlight = TriggerUpdateA $ \s -> pure s.commandsInFlight
|
||||||
|
|
||||||
instance ActionTriggerUpdate (TriggerA s) where
|
instance ActionTriggerUpdate (TriggerA s) where
|
||||||
getCommandsInFlight = liftTriggerRule $ get <&> \s -> s.commandsInFlight
|
getCommandsInFlight = liftTriggerRule $ get <&> \s -> s.commandsInFlight
|
||||||
@ -264,10 +273,12 @@ runTrigger userTrigger = LowLevel.Trigger
|
|||||||
where
|
where
|
||||||
initialState party readAs (ActiveContracts createdEvents) =
|
initialState party readAs (ActiveContracts createdEvents) =
|
||||||
let acs = foldl (\acs created -> applyEvent (CreatedEvent created) acs) (ACS mempty Map.empty) 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
|
state = TriggerState acs party readAs userState Map.empty
|
||||||
in TriggerSetup $ execStateT (runTriggerRule $ runRule userTrigger.rule) state
|
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
|
update msg = do
|
||||||
time <- getTime
|
time <- getTime
|
||||||
state <- get
|
state <- get
|
||||||
@ -275,7 +286,7 @@ runTrigger userTrigger = LowLevel.Trigger
|
|||||||
MCompletion completion ->
|
MCompletion completion ->
|
||||||
-- NB: the commands-in-flight and ACS updateState sees are those
|
-- NB: the commands-in-flight and ACS updateState sees are those
|
||||||
-- prior to updates incurred by the msg
|
-- 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
|
in case completion.status of
|
||||||
Succeeded {} ->
|
Succeeded {} ->
|
||||||
-- We delete successful completions when we receive the corresponding transaction
|
-- We delete successful completions when we receive the corresponding transaction
|
||||||
@ -289,7 +300,7 @@ runTrigger userTrigger = LowLevel.Trigger
|
|||||||
MTransaction transaction -> do
|
MTransaction transaction -> do
|
||||||
let acs = applyTransaction transaction state.acs
|
let acs = applyTransaction transaction state.acs
|
||||||
-- again, we use the commands-in-flight and ACS before the update below
|
-- 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.
|
-- See the comment above for why we delete this here instead of when we receive the completion.
|
||||||
(acs', commandsInFlight) = case transaction.commandId of
|
(acs', commandsInFlight) = case transaction.commandId of
|
||||||
None -> (acs, state.commandsInFlight)
|
None -> (acs, state.commandsInFlight)
|
||||||
@ -297,6 +308,6 @@ runTrigger userTrigger = LowLevel.Trigger
|
|||||||
put $ state { acs = acs', userState, commandsInFlight }
|
put $ state { acs = acs', userState, commandsInFlight }
|
||||||
runRule userTrigger.rule
|
runRule userTrigger.rule
|
||||||
MHeartbeat -> do
|
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 }
|
put $ state { userState }
|
||||||
runRule userTrigger.rule
|
runRule userTrigger.rule
|
||||||
|
@ -67,7 +67,7 @@ testRule trigger party readAs acsBuilder commandsInFlight s = do
|
|||||||
acs <- buildACS party acsBuilder
|
acs <- buildACS party acsBuilder
|
||||||
let state = TriggerState
|
let state = TriggerState
|
||||||
{ acs = acs
|
{ acs = acs
|
||||||
, party = party
|
, actAs = party
|
||||||
, readAs = readAs
|
, readAs = readAs
|
||||||
, userState = s
|
, userState = s
|
||||||
, commandsInFlight = commandsInFlight
|
, commandsInFlight = commandsInFlight
|
||||||
|
@ -20,6 +20,8 @@ module Daml.Trigger.Internal
|
|||||||
, liftTriggerRule
|
, liftTriggerRule
|
||||||
, TriggerAState (..)
|
, TriggerAState (..)
|
||||||
, TriggerState (..)
|
, TriggerState (..)
|
||||||
|
, TriggerInitState(..)
|
||||||
|
, TriggerUpdateState(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import DA.Action.State
|
import DA.Action.State
|
||||||
@ -65,12 +67,20 @@ instance ActionState s (TriggerA s) where
|
|||||||
instance HasTime (TriggerA s) where
|
instance HasTime (TriggerA s) where
|
||||||
getTime = TriggerA $ const getTime
|
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
|
-- | TriggerUpdateA is the type used in the `updateState` of a Daml
|
||||||
-- trigger. It has similar actions in common with `TriggerA`, but
|
-- trigger. It has similar actions in common with `TriggerA`, but
|
||||||
-- cannot use `emitCommands` or `getTime`.
|
-- cannot use `emitCommands` or `getTime`.
|
||||||
newtype TriggerUpdateA s a =
|
newtype TriggerUpdateA s a =
|
||||||
-- | HIDE
|
-- | HIDE
|
||||||
TriggerUpdateA { runTriggerUpdateA : (Map CommandId [Command], ACS, [Party]) -> State s a }
|
TriggerUpdateA { runTriggerUpdateA : TriggerUpdateState -> State s a }
|
||||||
|
|
||||||
instance Functor (TriggerUpdateA s) where
|
instance Functor (TriggerUpdateA s) where
|
||||||
fmap f (TriggerUpdateA r) = TriggerUpdateA $ rliftFmap fmap f r
|
fmap f (TriggerUpdateA r) = TriggerUpdateA $ rliftFmap fmap f r
|
||||||
@ -87,11 +97,18 @@ instance ActionState s (TriggerUpdateA s) where
|
|||||||
put = TriggerUpdateA . const . put
|
put = TriggerUpdateA . const . put
|
||||||
modify = TriggerUpdateA . const . modify
|
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
|
-- | TriggerInitializeA is the type used in the `initialize` of a Daml
|
||||||
-- trigger. It can query, but not emit commands or update the state.
|
-- trigger. It can query, but not emit commands or update the state.
|
||||||
newtype TriggerInitializeA a =
|
newtype TriggerInitializeA a =
|
||||||
-- | HIDE
|
-- | HIDE
|
||||||
TriggerInitializeA { runTriggerInitializeA : (ACS, [Party]) -> a }
|
TriggerInitializeA { runTriggerInitializeA : TriggerInitState -> a }
|
||||||
deriving (Functor, Applicative, Action)
|
deriving (Functor, Applicative, Action)
|
||||||
|
|
||||||
-- Internal API
|
-- Internal API
|
||||||
@ -142,14 +159,15 @@ runRule
|
|||||||
runRule rule = do
|
runRule rule = do
|
||||||
state <- get
|
state <- get
|
||||||
TriggerRule . zoom zoomIn zoomOut . runTriggerRule . flip runTriggerA state.acs
|
TriggerRule . zoom zoomIn zoomOut . runTriggerRule . flip runTriggerA state.acs
|
||||||
$ rule state.party
|
$ rule state.actAs
|
||||||
where zoomIn state = TriggerAState state.commandsInFlight state.acs.pendingContracts state.userState state.readAs
|
where zoomIn state = TriggerAState state.commandsInFlight state.acs.pendingContracts state.userState state.readAs state.actAs
|
||||||
zoomOut state aState =
|
zoomOut state aState =
|
||||||
let commandsInFlight = aState.commandsInFlight
|
let commandsInFlight = aState.commandsInFlight
|
||||||
acs = state.acs { pendingContracts = aState.pendingContracts }
|
acs = state.acs { pendingContracts = aState.pendingContracts }
|
||||||
userState = aState.userState
|
userState = aState.userState
|
||||||
readAs = aState.readAs
|
readAs = aState.readAs
|
||||||
in state { commandsInFlight, acs, userState, readAs }
|
actAs = aState.actAs
|
||||||
|
in state { commandsInFlight, acs, userState, readAs, actAs }
|
||||||
|
|
||||||
-- | HIDE
|
-- | HIDE
|
||||||
liftTriggerRule : TriggerRule (TriggerAState s) a -> TriggerA s a
|
liftTriggerRule : TriggerRule (TriggerAState s) a -> TriggerA s a
|
||||||
@ -167,12 +185,14 @@ data TriggerAState s = TriggerAState
|
|||||||
-- ^ zoomed from TriggerState
|
-- ^ zoomed from TriggerState
|
||||||
, readAs : [Party]
|
, readAs : [Party]
|
||||||
-- ^ zoomed from TriggerState
|
-- ^ zoomed from TriggerState
|
||||||
|
, actAs : Party
|
||||||
|
-- ^ zoomed from TriggerState
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | HIDE
|
-- | HIDE
|
||||||
data TriggerState s = TriggerState
|
data TriggerState s = TriggerState
|
||||||
{ acs : ACS
|
{ acs : ACS
|
||||||
, party : Party
|
, actAs : Party
|
||||||
, readAs : [Party]
|
, readAs : [Party]
|
||||||
, userState : s
|
, userState : s
|
||||||
, commandsInFlight : Map CommandId [Command]
|
, commandsInFlight : Map CommandId [Command]
|
||||||
|
@ -42,6 +42,7 @@ DAML_LF_VERSIONS = [
|
|||||||
cp -L $(location :daml/Time.daml) $$TMP_DIR/daml
|
cp -L $(location :daml/Time.daml) $$TMP_DIR/daml
|
||||||
cp -L $(location :daml/Heartbeat.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/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 //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 //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
|
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.matchers.should.Matchers
|
||||||
import org.scalatest.wordspec.AsyncWordSpec
|
import org.scalatest.wordspec.AsyncWordSpec
|
||||||
import scalaz.syntax.traverse._
|
import scalaz.syntax.traverse._
|
||||||
|
import scala.jdk.CollectionConverters._
|
||||||
|
|
||||||
import com.daml.lf.engine.trigger.TriggerMsg
|
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