GroupChat Key Bug

GroupChat.daml

-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

daml 1.2

-- DAML chat-room model, with support for multiple chat-groups with entry by invitation.

module GroupChat where

import DA.List

data GID = GID with
  id : Text
  members : [Party]
    deriving (Eq, Show)

data MID = MID with
  gid : GID
  poster : Party
  id : Text
    deriving (Eq, Show)

template Message
  with
    mid : MID
    text : Text
  where
    signatory mid.gid.members

    key mid : MID
    maintainer key.gid.members

    choice M_ChangeGID
      : ContractId Message
      with
        newGid : GID
      controller mid.gid.members, newGid.members
      do
        create this with
          mid = mid with
            gid = newGid

template MessageIndex
  with
    gid : GID
    poster : Party
    messageIds : [Text]
  where
    signatory gid.members

    key (gid, poster) : (GID, Party)
    maintainer key._1.members

    controller gid.members, poster can
      MI_Message
        : ContractId Message
        with
          id : Text
          text : Text
        do
          create this with
            messageIds = id :: messageIds
          create Message with
            mid = MID with
              gid
              poster
              id
            text

    choice MI_ChangeGID
      : ContractId MessageIndex
      with
        newGid : GID
      controller gid.members, newGid.members
      do
        forA messageIds (\id -> do
          (mCid, m) <- fetchByKey @Message MID with ..
          exercise mCid M_ChangeGID with newGid
          )
        create this with
          gid = newGid

    controller gid.members can
      ArchiveIndex : ()
        do
          forA messageIds (\id -> do
            (mCid, m) <- fetchByKey @Message MID with ..
            archive mCid
            )
          return ()

template ChatGroup
  with
    gid : GID
    pastMembers : [Party]
  where
    signatory gid.members

    key gid : GID
    maintainer key.members

    choice ChangeGID
      : ContractId ChatGroup
      with
        newGid : GID
      controller gid.members, newGid.members
      do
        forA (gid.members ++ pastMembers) (\poster -> do
          (miCid, mi) <- fetchByKey @MessageIndex (gid, poster)
          exercise miCid MI_ChangeGID with newGid
          )
        create this with
            gid = newGid

    nonconsuming choice AddMember
      : ContractId ChatGroup
      with
        member : Party
        newMember : Party
      controller member, newMember
      do
        assert (member `elem` gid.members)
        let newGid = gid with members = dedupSort (newMember :: gid.members)
        exercise self ChangeGID with newGid

    nonconsuming choice Post_Message
      : ()
      with
        poster : Party
        id : Text
        text : Text
      controller poster
      do
        assert (poster `elem` gid.members)
        miCid <- exercise self GetOrCreateIndex with poster
        exercise miCid MI_Message with ..
        return ()

    nonconsuming choice LeaveGroup
      : ContractId ChatGroup
      with
        member : Party
      controller member
      do
        assert (member `elem` gid.members)
        let newGid = gid with members = filter (/= member) gid.members
        exercise self ChangeGID with newGid

    controller gid.members can
      ArchiveGroup : ()
        do
          forA (gid.members ++ pastMembers) (\poster -> do
            miCid <- exercise self GetOrCreateIndex with poster
            exercise miCid ArchiveIndex
            )
          return ()

      nonconsuming GetOrCreateIndex
        : ContractId MessageIndex
        with
          poster : Party
        do
          oid <- lookupByKey @MessageIndex (gid, poster)
          case oid of
            Some id -> return id
            None -> create MessageIndex with messageIds = []; ..

template GroupMembershipRequest
  with
    groupId : Text
    member : Party
    newMember : Party
  where
    signatory newMember

    controller member can
      Onboard
        : ContractId ChatGroup
        with
          groupCid : ContractId ChatGroup
        do
          group <- fetch groupCid
          assert (group.gid.id == groupId)
          exercise groupCid AddMember with
            member
            newMember

setup_chat = scenario do
  parties@[alice, bob, charlie, dora] <- mapA getParty ["Alice", "Bob", "Charlie", "Dora"]

  g <- submit alice do
    create ChatGroup with
      gid = GID with
        id = "troll-bot"
        members = [alice]
      pastMembers = []

  return (parties, g)

first_post = scenario do
  s@(parties@[alice, bob, charlie, dora], g) <- setup_chat

  submit alice do
    exercise g Post_Message with
      poster = alice
      id = "1"
      text = "first post"

  return s

onboard_bob = scenario do
  s@(parties@[alice, bob, charlie, dora], g) <- first_post

  rb <- submit bob do
    create GroupMembershipRequest
      with
        groupId = "troll-bot"
        member = alice
        newMember = bob

  g <- submit alice do
    exercise rb Onboard with groupCid = g

  submit bob do
    exercise g Post_Message with
      poster = bob
      id = "1"
      text = "Hey Alice!"

  return (parties, g)

second_post = scenario do
  s@(parties@[alice, bob, charlie, dora], g) <- onboard_bob

  submit alice do
    exercise g Post_Message with
      poster = alice
      id = "2"
      text = "Hey Bob, I'm good and you?"