Daml Triggers composed from small building blocks

Questions Features & Bugs
1

I want to compose Daml Triggers from small building blocks, based on the insight that instance Action (TriggerA s), just like instance Action Update or instance Action Script.

This is how I decomposed and recomposed the autoReply trigger form the gsg-trigger template.

Can I do it even simpler and/or more elegantly?

module ChatBot where

import qualified Daml.Trigger as T
import qualified User
import qualified DA.List.Total as List
import DA.Action (when)
import DA.Optional (whenSome)

import Daml.Script
import DA.Map qualified as Maps
import Daml.Trigger.Assert
import DA.Assert

-- THE ORIGINAL TRIGGER

autoReply : T.Trigger ()
autoReply = T.Trigger
  { initialize = pure ()
  , updateState = \_ -> pure ()
  , rule = \p -> do
      message_contracts <- T.query @User.Message
      let messages = map snd message_contracts
      debug $ "Messages so far: " <> show (length messages)
      let lastMessage = List.maximumOn (.receivedAt) messages
      debug $ "Last message: " <> show lastMessage
      whenSome lastMessage $ \m ->
        when (m.receiver == p) $ do
          users <- T.query @User.User
          debug $ "users: " <> show users
          let isSender = (\user -> user.username == m.sender)
          let replyTo = List.head $ filter (\(_, user) -> isSender user) users
          whenSome replyTo $ \(sender, _) ->
            T.dedupExercise sender (User.SendMessage p "Please, tell me more about that.")
  , registeredTemplates = T.AllInDar
  , heartbeat = None
  }

test : Script ()
test = do 
  alice <- allocateParty "Alice" 
  bob <- allocateParty "Bob" 

  aliceUserCid <- submit alice $ Daml.Script.createCmd User.User with username = alice, following = [bob]
  debug $ "Alide user cid: " <> show aliceUserCid
  bobUserCid <- submit bob $ Daml.Script.createCmd User.User with username = bob, following = [alice]
  debug $ "Bob user cid: " <> show bobUserCid

  bobMsgCid <- submit bob $ Daml.Script.exerciseCmd aliceUserCid User.SendMessage with sender = bob, content = "Hello Alice"
  
  let acsBuilder = toACS aliceUserCid <> toACS bobUserCid <> toACS bobMsgCid

  -- TESTING THE ORITINAL TRIGGER
  ((), cmds) <- testRule autoReply alice [] acsBuilder Maps.empty ()

  debug $ length cmds
  
  assertExerciseCmd (flattenCommands cmds) $ \(cid, choiceArg) -> do
    cid === bobUserCid
    debug choiceArg
    choiceArg === User.SendMessage with
      sender = alice
      content = "Please, tell me more about that."

-- COMPOSABLE BUILDING BLOCKS

queryMessages : T.TriggerA () [User.Message]
queryMessages =
  map snd <$> T.query @User.Message 

filterForReceivedByReplier : Party -> [User.Message] -> T.TriggerA () [User.Message]
filterForReceivedByReplier replyingParty messages = do 
  return $ filter (\m -> m.receiver == replyingParty) $ messages

pickLastMessage : [User.Message] -> T.TriggerA () (Optional User.Message)
pickLastMessage listOfUsers = do 
  return $ List.maximumOn (.receivedAt) $ listOfUsers 

checkIfReceivedByReplier : Party -> Optional User.Message -> T.TriggerA () (Optional User.Message)
checkIfReceivedByReplier replyingParty messageOpt = do 
  case messageOpt of 
    None -> return None 
    Some m -> return $ if m.receiver == replyingParty then Some m else None 

fromMessageToSenderUserCid : Optional User.Message -> T.TriggerA () (Optional (ContractId User.User))
fromMessageToSenderUserCid messageOpt = do 
  case messageOpt of 
    None -> return None 
    Some m -> do 
                userTuples <- T.query @User.User 
                return $ List.head . map fst . filter (\(_, user) -> user.username == m.sender) $ userTuples

replyToUserCid : Party -> T.TriggerA () (Optional (ContractId User.User))
replyToUserCid replyingParty = queryMessages 
            >>= filterForReceivedByReplier replyingParty
              >>= pickLastMessage 
                >>= checkIfReceivedByReplier replyingParty
                  >>= fromMessageToSenderUserCid

replyChoice : Party -> User.SendMessage
replyChoice replyingParty = User.SendMessage with 
  sender = replyingParty 
  content = "Please, tell me more about that."

sendReply : Party -> (Optional (ContractId User.User)) -> T.TriggerA () ()
sendReply replyingParty replyToUserCidOpt  = do 
  case replyToUserCidOpt of 
    None -> return () 
    Some cid -> T.dedupExercise cid (replyChoice replyingParty) 

autoReplyRule : Party -> T.TriggerA () ()
autoReplyRule replyingParty = 
  replyToUserCid replyingParty
    >>= sendReply replyingParty 

-- THE SAME TRIGGER ASSEMBLED FROM BUILDING BLOCKS

autoReply' : T.Trigger ()
autoReply' = T.Trigger
  { initialize = pure ()
  , updateState = \_ -> pure ()
  , rule = autoReplyRule
  , registeredTemplates = T.AllInDar
  , heartbeat = None
  }

test' : Script ()
test' = do 
  alice <- allocateParty "Alice" 
  bob <- allocateParty "Bob" 

  aliceUserCid <- submit alice $ Daml.Script.createCmd User.User with username = alice, following = [bob]
  debug $ "Alide user cid: " <> show aliceUserCid
  bobUserCid <- submit bob $ Daml.Script.createCmd User.User with username = bob, following = [alice]
  debug $ "Bob user cid: " <> show bobUserCid

  bobMsgCid <- submit bob $ Daml.Script.exerciseCmd aliceUserCid User.SendMessage with sender = bob, content = "Hello Alice"
  
  let acsBuilder = toACS aliceUserCid <> toACS bobUserCid <> toACS bobMsgCid

  -- TESTING THE MODIFIED TRIGGER
  ((), cmds) <- testRule autoReply' alice [] acsBuilder Maps.empty ()

  debug $ length cmds
  
  assertExerciseCmd (flattenCommands cmds) $ \(cid, choiceArg) -> do
    cid === bobUserCid
    debug choiceArg
    choiceArg === User.SendMessage with
      sender = alice
      content = "Please, tell me more about that."
2

Hi @gyorgybalazsi :wave:

What part specifically do you think could ebb done better?

1 Like
3

Hi @nemanja thank you, maybe there is no obvious way to improve it, if you cannot see anything at first sight. I close this and will put some thinking into bringing back the use of when and whenSome instead of pattern matching which I avoided because it’s new to me.

1 Like