core: initial group member role when joining via link (#1975)

* core: initial group member role when joining via link * fix tests * set role when joining group via link, enable observer test * show group link when role changes * amend test * check role is member or observer when creating a link
2026-04-28 04:06:22 +00:00 · 2023-03-06 09:51:42 +00:00
parent 2bc1236a2c
commit f915eb2a20
10 changed files with 180 additions and 70 deletions
@@ -1191,25 +1191,36 @@ processChatCommand = \case
    CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName)
  UpdateGroupDescription gName description ->
    updateGroupProfileByName gName $ \p -> p {description}
-  APICreateGroupLink groupId -> withUser $ \user -> withChatLock "createGroupLink" $ do
+  APICreateGroupLink groupId mRole -> withUser $ \user -> withChatLock "createGroupLink" $ do
    gInfo <- withStore $ \db -> getGroupInfo db user groupId
    assertUserGroupRole gInfo GRAdmin
+    when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole
    groupLinkId <- GroupLinkId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16))
    let crClientData = encodeJSON $ CRDataGroup groupLinkId
    (connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMContact $ Just crClientData
-    withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId
-    pure $ CRGroupLinkCreated user gInfo cReq
+    withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole
+    pure $ CRGroupLinkCreated user gInfo cReq mRole
+  APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withChatLock "groupLinkMemberRole " $ do
+    gInfo <- withStore $ \db -> getGroupInfo db user groupId
+    (groupLinkId, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
+    assertUserGroupRole gInfo GRAdmin
+    when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole'
+    when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole'
+    pure $ CRGroupLink user gInfo groupLink mRole'
  APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock "deleteGroupLink" $ do
    gInfo <- withStore $ \db -> getGroupInfo db user groupId
    deleteGroupLink' user gInfo
    pure $ CRGroupLinkDeleted user gInfo
  APIGetGroupLink groupId -> withUser $ \user -> do
    gInfo <- withStore $ \db -> getGroupInfo db user groupId
-    groupLink <- withStore $ \db -> getGroupLink db user gInfo
-    pure $ CRGroupLink user gInfo groupLink
-  CreateGroupLink gName -> withUser $ \user -> do
+    (_, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
+    pure $ CRGroupLink user gInfo groupLink mRole
+  CreateGroupLink gName mRole -> withUser $ \user -> do
    groupId <- withStore $ \db -> getGroupIdByName db user gName
-    processChatCommand $ APICreateGroupLink groupId
+    processChatCommand $ APICreateGroupLink groupId mRole
+  GroupLinkMemberRole gName mRole -> withUser $ \user -> do
+    groupId <- withStore $ \db -> getGroupIdByName db user gName
+    processChatCommand $ APIGroupLinkMemberRole groupId mRole
  DeleteGroupLink gName -> withUser $ \user -> do
    groupId <- withStore $ \db -> getGroupIdByName db user gName
    processChatCommand $ APIDeleteGroupLink groupId
@@ -2213,7 +2224,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
              forM_ groupLinkId $ \_ -> probeMatchingContacts ct $ contactConnIncognito ct
              forM_ viaUserContactLink $ \userContactLinkId ->
                withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
-                  Just (UserContactLink {autoAccept = Just AutoAccept {autoReply = mc_}}, groupId_) -> do
+                  Just (UserContactLink {autoAccept = Just AutoAccept {autoReply = mc_}}, groupId_, gLinkMemRole) -> do
                    forM_ mc_ $ \mc -> do
                      (msg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
                      ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
@@ -2221,7 +2232,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
                    forM_ groupId_ $ \groupId -> do
                      gVar <- asks idsDrg
                      groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation
-                      withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct GRMember groupConnIds
+                      withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds
                  _ -> pure ()
            Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) ->
              when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
@@ -2578,7 +2589,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
            CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
            CORRequest cReq@UserContactRequest {localDisplayName} -> do
              withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
-                Just (UserContactLink {autoAccept}, groupId_) ->
+                Just (UserContactLink {autoAccept}, groupId_, _) ->
                  case autoAccept of
                    Just AutoAccept {acceptIncognito} -> case groupId_ of
                      Nothing -> do
@@ -4045,7 +4056,7 @@ chatCommandP =
      ("/help" <|> "/h") $> ChatHelp HSMain,
      ("/group " <|> "/g ") *> char_ '#' *> (NewGroup <$> groupProfile),
      "/_group " *> (APINewGroup <$> A.decimal <* A.space <*> jsonP),
-      ("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> memberRole),
+      ("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayName <* A.space <* char_ '@' <*> displayName <*> (memberRole <|> pure GRAdmin)),
      ("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayName),
      ("/member role " <|> "/mr ") *> char_ '#' *> (MemberRole <$> displayName <* A.space <* char_ '@' <*> displayName <*> memberRole),
      ("/remove " <|> "/rm ") *> char_ '#' *> (RemoveMember <$> displayName <* A.space <* char_ '@' <*> displayName),
@@ -4060,10 +4071,12 @@ chatCommandP =
      ("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayName <* A.space <*> groupProfile),
      ("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayName),
      "/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> optional (A.space *> msgTextP)),
-      "/_create link #" *> (APICreateGroupLink <$> A.decimal),
+      "/_create link #" *> (APICreateGroupLink <$> A.decimal <*> (memberRole <|> pure GRMember)),
+      "/_set link role #" *> (APIGroupLinkMemberRole <$> A.decimal <*> memberRole),
      "/_delete link #" *> (APIDeleteGroupLink <$> A.decimal),
      "/_get link #" *> (APIGetGroupLink <$> A.decimal),
-      "/create link #" *> (CreateGroupLink <$> displayName),
+      "/create link #" *> (CreateGroupLink <$> displayName <*> (memberRole <|> pure GRMember)),
+      "/set link role #" *> (GroupLinkMemberRole <$> displayName <*> memberRole),
      "/delete link #" *> (DeleteGroupLink <$> displayName),
      "/show link #" *> (ShowGroupLink <$> displayName),
      (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> msgTextP),
@@ -4173,8 +4186,7 @@ chatCommandP =
        [ " owner" $> GROwner,
          " admin" $> GRAdmin,
          " member" $> GRMember,
-          -- " observer" $> GRObserver,
-          pure GRAdmin
+          " observer" $> GRObserver
        ]
    chatNameP = ChatName <$> chatTypeP <*> displayName
    chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName
@@ -237,7 +237,8 @@ data ChatCommand
  | APILeaveGroup GroupId
  | APIListMembers GroupId
  | APIUpdateGroupProfile GroupId GroupProfile
-  | APICreateGroupLink GroupId
+  | APICreateGroupLink GroupId GroupMemberRole
+  | APIGroupLinkMemberRole GroupId GroupMemberRole
  | APIDeleteGroupLink GroupId
  | APIGetGroupLink GroupId
  | APIGetUserSMPServers UserId
@@ -317,7 +318,8 @@ data ChatCommand
  | UpdateGroupNames GroupName GroupProfile
  | ShowGroupProfile GroupName
  | UpdateGroupDescription GroupName (Maybe Text)
-  | CreateGroupLink GroupName
+  | CreateGroupLink GroupName GroupMemberRole
+  | GroupLinkMemberRole GroupName GroupMemberRole
  | DeleteGroupLink GroupName
  | ShowGroupLink GroupName
  | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: Text, message :: Text}
@@ -455,8 +457,8 @@ data ChatResponse
  | CRGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
  | CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember}
  | CRGroupProfile {user :: User, groupInfo :: GroupInfo}
-  | CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact}
-  | CRGroupLink {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact}
+  | CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
+  | CRGroupLink {user :: User, groupInfo :: GroupInfo, connReqContact :: ConnReqContact, memberRole :: GroupMemberRole}
  | CRGroupLinkDeleted {user :: User, groupInfo :: GroupInfo}
  | CRAcceptingGroupJoinRequest {user :: User, groupInfo :: GroupInfo, contact :: Contact}
  | CRMemberSubError {user :: User, groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError}
@@ -685,6 +687,7 @@ data ChatErrorType
  | CEContactDisabled {contact :: Contact}
  | CEConnectionDisabled {connection :: Connection}
  | CEGroupUserRole {groupInfo :: GroupInfo, requiredRole :: GroupMemberRole}
+  | CEGroupMemberInitialRole {groupInfo :: GroupInfo, initialRole :: GroupMemberRole}
  | CEContactIncognitoCantInvite
  | CEGroupIncognitoCantInvite
  | CEGroupContactRole {contactName :: ContactName}
@@ -132,7 +132,12 @@ groupsHelpInfo =
      indent <> highlight "/group_descr <group> [<descr>]     " <> " - update/remove group description",
      indent <> highlight "/groups                            " <> " - list groups",
      indent <> highlight "#<group> <message>                 " <> " - send message to group",
-      indent <> highlight "/create link #<group>              " <> " - create public group link",
+      "",
+      green "Public group links:",
+      indent <> highlight "/create link #<group> [role]       " <> " - create public group link (with optional role, default: member)",
+      indent <> highlight "/set link role #<group> role       " <> " - change role assigned to the users joining via the link (member/observer)",
+      indent <> highlight "/show link #<group>                " <> " - show public group link and initial member role",
+      indent <> highlight "/delete link #<group>              " <> " - delete link to join the group (does NOT delete any members)",
      "",
      green "Mute group messages:",
      indent <> highlight "/mute #<group>                     " <> " - do not show contact's messages",
@@ -0,0 +1,12 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20230303_group_link_role where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20230303_group_link_role :: Query
+m20230303_group_link_role =
+  [sql|
+ALTER TABLE user_contact_links ADD COLUMN group_link_member_role TEXT NULL; -- member or observer
+|]
@@ -282,6 +282,7 @@ CREATE TABLE user_contact_links(
  group_id INTEGER REFERENCES groups ON DELETE CASCADE,
  auto_accept_incognito INTEGER DEFAULT 0 CHECK(auto_accept_incognito NOT NULL),
  group_link_id BLOB,
+  group_link_member_role TEXT NULL,
  UNIQUE(user_id, local_display_name)
 );
 CREATE TABLE contact_requests(
@@ -75,6 +75,7 @@ module Simplex.Chat.Store
    deleteGroupLink,
    getGroupLink,
    getGroupLinkId,
+    setGroupLinkMemberRole,
    createOrUpdateContactRequest,
    getContactRequest',
    getContactRequest,
@@ -341,6 +342,7 @@ import Simplex.Chat.Migrations.M20230117_fkey_indexes
 import Simplex.Chat.Migrations.M20230118_recreate_smp_servers
 import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx
 import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id
+import Simplex.Chat.Migrations.M20230303_group_link_role
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
 import Simplex.Chat.Util (week)
@@ -406,7 +408,8 @@ schemaMigrations =
    ("20230117_fkey_indexes", m20230117_fkey_indexes),
    ("20230118_recreate_smp_servers", m20230118_recreate_smp_servers),
    ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx),
-    ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id)
+    ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id),
+    ("20230303_group_link_role", m20230303_group_link_role)
  ]

 -- | The list of migrations in ascending order by date
@@ -1086,13 +1089,13 @@ getUserAddress db User {userId} =
      |]
      (Only userId)

-getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId))
+getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId, GroupMemberRole))
 getUserContactLinkById db userId userContactLinkId =
-  maybeFirstRow (\(ucl :. Only groupId_) -> (toUserContactLink ucl, groupId_)) $
+  maybeFirstRow (\(ucl :. (groupId_, mRole_)) -> (toUserContactLink ucl, groupId_, fromMaybe GRMember mRole_)) $
    DB.query
      db
      [sql|
-        SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id
+        SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id, group_link_member_role
        FROM user_contact_links
        WHERE user_id = ?
          AND user_contact_link_id = ?
@@ -1117,14 +1120,14 @@ updateUserAddressAutoAccept db user@User {userId} autoAccept = do
      Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
      _ -> (False, False, Nothing)

-createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> ExceptT StoreError IO ()
-createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId =
+createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> GroupLinkId -> GroupMemberRole -> ExceptT StoreError IO ()
+createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq groupLinkId memberRole =
  checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do
    currentTs <- getCurrentTime
    DB.execute
      db
-      "INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
-      (userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, True, currentTs, currentTs)
+      "INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
+      (userId, groupId, groupLinkId, "group_link_" <> localDisplayName, cReq, memberRole, True, currentTs, currentTs)
    userContactLinkId <- insertedRowId db
    void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs

@@ -1182,16 +1185,22 @@ deleteGroupLink db User {userId} GroupInfo {groupId} = do
    (userId, groupId)
  DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId)

-getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO ConnReqContact
+getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO (Int64, ConnReqContact, GroupMemberRole)
 getGroupLink db User {userId} gInfo@GroupInfo {groupId} =
-  ExceptT . firstRow fromOnly (SEGroupLinkNotFound gInfo) $
-    DB.query db "SELECT conn_req_contact FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId)
+  ExceptT . firstRow groupLink (SEGroupLinkNotFound gInfo) $
+    DB.query db "SELECT user_contact_link_id, conn_req_contact, group_link_member_role FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId)
+  where
+    groupLink (linkId, cReq, mRole_) = (linkId, cReq, fromMaybe GRMember mRole_)

 getGroupLinkId :: DB.Connection -> User -> GroupInfo -> IO (Maybe GroupLinkId)
 getGroupLinkId db User {userId} GroupInfo {groupId} =
  fmap join . maybeFirstRow fromOnly $
    DB.query db "SELECT group_link_id FROM user_contact_links WHERE user_id = ? AND group_id = ? LIMIT 1" (userId, groupId)

+setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> IO ()
+setGroupLinkMemberRole db User {userId} userContactLinkId memberRole =
+  DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId)
+
 createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
 createOrUpdateContactRequest db user@User {userId} userContactLinkId invId Profile {displayName, fullName, image, preferences} xContactId_ =
  liftIO (maybeM getContact' xContactId_) >>= \case
@@ -186,8 +186,8 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
  CRGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"]
  CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m
  CRGroupProfile u g -> ttyUser u $ viewGroupProfile g
-  CRGroupLinkCreated u g cReq -> ttyUser u $ groupLink_ "Group link is created!" g cReq
-  CRGroupLink u g cReq -> ttyUser u $ groupLink_ "Group link:" g cReq
+  CRGroupLinkCreated u g cReq mRole -> ttyUser u $ groupLink_ "Group link is created!" g cReq mRole
+  CRGroupLink u g cReq mRole -> ttyUser u $ groupLink_ "Group link:" g cReq mRole
  CRGroupLinkDeleted u g -> ttyUser u $ viewGroupLinkDeleted g
  CRAcceptingGroupJoinRequest _ g c -> [ttyFullContact c <> ": accepting request to join group " <> ttyGroup' g <> "..."]
  CRMemberSubError u g m e -> ttyUser u [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e]
@@ -541,13 +541,13 @@ autoAcceptStatus_ = \case
    maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
  _ -> ["auto_accept off"]

-groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> [StyledString]
-groupLink_ intro g cReq =
+groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole -> [StyledString]
+groupLink_ intro g cReq mRole =
  [ intro,
    "",
    (plain . strEncode) cReq,
    "",
-    "Anybody can connect to you and join group with: " <> highlight' "/c <group_link_above>",
+    "Anybody can connect to you and join group as " <> showRole mRole <> " with: " <> highlight' "/c <group_link_above>",
    "to show it again: " <> highlight ("/show link #" <> groupName' g),
    "to delete it: " <> highlight ("/delete link #" <> groupName' g) <> " (joined members will remain connected to you)"
  ]
@@ -1225,6 +1225,7 @@ viewChatError logLevel = \case
      (: []) . (ttyGroup' g <>) $ case role of
        GRAuthor -> ": you don't have permission to send messages"
        _ -> ": you have insufficient permissions for this action, the required role is " <> plain (strEncode role)
+    CEGroupMemberInitialRole g role -> [ttyGroup' g <> ": initial role for group member cannot be " <> plain (strEncode role) <> ", use member or observer"]
    CEContactIncognitoCantInvite -> ["you're using your main profile for this group - prohibited to invite contacts to whom you are connected incognito"]
    CEGroupIncognitoCantInvite -> ["you've connected to this group using an incognito profile - prohibited to invite contacts"]
    CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"]