From ad5edeba6c283b2a574a525891a9b96b63af3966 Mon Sep 17 00:00:00 2001 From: JRoberts <8711996+jr-simplex@users.noreply.github.com> Date: Tue, 12 Jul 2022 19:20:56 +0400 Subject: [PATCH] core: groups api (#806) --- src/Simplex/Chat.hs | 83 +++++++++++++++++++++++----------- src/Simplex/Chat/Controller.hs | 10 +++- src/Simplex/Chat/Store.hs | 30 ++++++------ src/Simplex/Chat/Types.hs | 10 ++-- src/Simplex/Chat/View.hs | 2 +- 5 files changed, 88 insertions(+), 47 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 7a9f901c8f..cde8bcf0e3 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -5,7 +5,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -432,7 +431,18 @@ processChatCommand = \case withAgent $ \a -> deleteConnection a $ aConnId' conn withStore' $ \db -> deletePendingContactConnection db userId chatId pure $ CRContactConnectionDeleted conn - CTGroup -> pure $ chatCmdError "not implemented" + CTGroup -> do + g@(Group gInfo@GroupInfo {membership} members) <- withStore $ \db -> getGroup db user chatId + let s = memberStatus membership + canDelete = + memberRole (membership :: GroupMember) == GROwner + || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited) + unless canDelete $ throwChatError CEGroupUserRole + withChatLock . procCmd $ do + when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel + mapM_ deleteMemberConnection members + withStore' $ \db -> deleteGroup db user g + pure $ CRGroupDeletedUser gInfo CTContactRequest -> pure $ chatCmdError "not supported" APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of CTDirect -> do @@ -659,11 +669,12 @@ processChatCommand = \case NewGroup gProfile -> withUser $ \user -> do gVar <- asks idsDrg CRGroupCreated <$> withStore (\db -> createNewGroup db gVar user gProfile) - AddMember gName cName memRole -> withUser $ \user@User {userId} -> withChatLock $ do + APIAddMember groupId contactId memRole -> withUser $ \user@User {userId} -> withChatLock $ do -- TODO for large groups: no need to load all members to determine if contact is a member - (group, contact) <- withStore $ \db -> (,) <$> getGroupByName db user gName <*> getContactByName db userId cName - let Group gInfo@GroupInfo {groupId, groupProfile, membership} members = group + (group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db userId contactId + let Group gInfo@GroupInfo {localDisplayName = gName, groupProfile, membership} members = group GroupMember {memberRole = userRole, memberId = userMemberId} = membership + Contact {localDisplayName = cName} = contact when (userRole < GRAdmin || userRole < memRole) $ throwChatError CEGroupUserRole when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined gInfo) unless (memberActive membership) $ throwChatError CEGroupMemberNotActive @@ -684,8 +695,8 @@ processChatCommand = \case Just cReq -> sendInvitation memberId cReq Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName | otherwise -> throwChatError $ CEGroupDuplicateMember cName - JoinGroup gName -> withUser $ \user@User {userId} -> do - ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g} <- withStore $ \db -> getGroupInvitation db user gName + APIJoinGroup groupId -> withUser $ \user@User {userId} -> do + ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g} <- withStore $ \db -> getGroupInvitation db user groupId withChatLock . procCmd $ do agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (membership g :: GroupMember) withStore' $ \db -> do @@ -693,11 +704,11 @@ processChatCommand = \case updateGroupMemberStatus db userId fromMember GSMemAccepted updateGroupMemberStatus db userId (membership g) GSMemAccepted pure $ CRUserAcceptedGroupSent g - MemberRole _gName _cName _mRole -> throwChatError $ CECommandError "unsupported" - RemoveMember gName cName -> withUser $ \user@User {userId} -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroupByName db user gName - case find ((== cName) . (localDisplayName :: GroupMember -> ContactName)) members of - Nothing -> throwChatError $ CEGroupMemberNotFound cName + APIMemberRole _groupId _groupMemberId _memRole -> throwChatError $ CECommandError "unsupported" + APIRemoveMember groupId memberId -> withUser $ \user@User {userId} -> do + Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId + case find ((== memberId) . groupMemberId) members of + Nothing -> throwChatError CEGroupMemberNotFound Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do let userRole = memberRole (membership :: GroupMember) when (userRole < GRAdmin || userRole < mRole) $ throwChatError CEGroupUserRole @@ -706,29 +717,38 @@ processChatCommand = \case deleteMemberConnection m withStore' $ \db -> updateGroupMemberStatus db userId m GSMemRemoved pure $ CRUserDeletedMember gInfo m - LeaveGroup gName -> withUser $ \user@User {userId} -> do - Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroupByName db user gName + APILeaveGroup groupId -> withUser $ \user@User {userId} -> do + Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId withChatLock . procCmd $ do void $ sendGroupMessage gInfo members XGrpLeave mapM_ deleteMemberConnection members withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft pure $ CRLeftMemberUser gInfo + APIListMembers groupId -> CRGroupMembers <$> withUser (\user -> withStore (\db -> getGroup db user groupId)) + AddMember gName cName memRole -> withUser $ \user@User {userId} -> do + (groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db userId cName + processChatCommand $ APIAddMember groupId contactId memRole + JoinGroup gName -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIJoinGroup groupId + MemberRole gName groupMemberName memRole -> do + (groupId, groupMemberId) <- getGroupAndMemberId gName groupMemberName + processChatCommand $ APIMemberRole groupId groupMemberId memRole + RemoveMember gName groupMemberName -> do + (groupId, groupMemberId) <- getGroupAndMemberId gName groupMemberName + processChatCommand $ APIRemoveMember groupId groupMemberId + LeaveGroup gName -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APILeaveGroup groupId DeleteGroup gName -> withUser $ \user -> do - g@(Group gInfo@GroupInfo {membership} members) <- withStore $ \db -> getGroupByName db user gName - let s = memberStatus membership - canDelete = - memberRole (membership :: GroupMember) == GROwner - || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited) - unless canDelete $ throwChatError CEGroupUserRole - withChatLock . procCmd $ do - when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel - mapM_ deleteMemberConnection members - withStore' $ \db -> deleteGroup db user g - pure $ CRGroupDeletedUser gInfo + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIDeleteChat (ChatRef CTGroup groupId) ClearGroup gName -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIClearChat (ChatRef CTGroup groupId) - ListMembers gName -> CRGroupMembers <$> withUser (\user -> withStore (\db -> getGroupByName db user gName)) + ListMembers gName -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + processChatCommand $ APIListMembers groupId ListGroups -> CRGroupsList <$> withUser (\user -> withStore' (`getUserGroupDetails` user)) SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName @@ -909,6 +929,12 @@ processChatCommand = \case _ -> throwChatError CEFileNotReceived {fileId} where forward = processChatCommand . sendCommand chatName + getGroupAndMemberId :: GroupName -> ContactName -> m (GroupId, GroupMemberId) + getGroupAndMemberId gName groupMemberName = withUser $ \user -> do + withStore $ \db -> do + groupId <- getGroupIdByName db user gName + groupMemberId <- getGroupMemberIdByName db user groupId groupMemberName + pure (groupId, groupMemberId) updateCallItemStatus :: ChatMonad m => UserId -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> m () updateCallItemStatus userId ct Call {chatItemId} receivedStatus msgId_ = do @@ -2318,6 +2344,11 @@ chatCommandP = <|> "/_ntf verify " *> (APIVerifyToken <$> strP <* A.space <*> strP <* A.space <*> strP) <|> "/_ntf delete " *> (APIDeleteToken <$> strP) <|> "/_ntf message " *> (APIGetNtfMessage <$> strP <* A.space <*> strP) + <|> "/_add #" *> (APIAddMember <$> A.decimal <* A.space <*> A.decimal <*> memberRole) + <|> "/_join #" *> (APIJoinGroup <$> A.decimal) + <|> "/_remove #" *> (APIRemoveMember <$> A.decimal <* A.space <*> A.decimal) + <|> "/_leave #" *> (APILeaveGroup <$> A.decimal) + <|> "/_members #" *> (APIListMembers <$> A.decimal) <|> "/smp_servers default" $> SetUserSMPServers [] <|> "/smp_servers " *> (SetUserSMPServers <$> smpServersP) <|> "/smp_servers" $> GetUserSMPServers diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index f0cee565d4..d9b6bc3f83 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -135,6 +135,12 @@ data ChatCommand | APIVerifyToken DeviceToken C.CbNonce ByteString | APIDeleteToken DeviceToken | APIGetNtfMessage {nonce :: C.CbNonce, encNtfInfo :: ByteString} + | APIAddMember GroupId ContactId GroupMemberRole + | APIJoinGroup GroupId + | APIMemberRole GroupId GroupMemberId GroupMemberRole + | APIRemoveMember GroupId GroupMemberId + | APILeaveGroup GroupId + | APIListMembers GroupId | GetUserSMPServers | SetUserSMPServers [SMPServer] | ChatHelp HelpSection @@ -159,8 +165,8 @@ data ChatCommand | NewGroup GroupProfile | AddMember GroupName ContactName GroupMemberRole | JoinGroup GroupName - | RemoveMember GroupName ContactName | MemberRole GroupName ContactName GroupMemberRole + | RemoveMember GroupName ContactName | LeaveGroup GroupName | DeleteGroup GroupName | ClearGroup GroupName @@ -366,7 +372,7 @@ data ChatErrorType | CEGroupNotJoined {groupInfo :: GroupInfo} | CEGroupMemberNotActive | CEGroupMemberUserRemoved - | CEGroupMemberNotFound {contactName :: ContactName} + | CEGroupMemberNotFound | CEGroupMemberIntroNotFound {contactName :: ContactName} | CEGroupCantResendInvitation {groupInfo :: GroupInfo, contactName :: ContactName} | CEGroupInternal {message :: String} diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 3f79794cb7..71cdcd873b 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -63,7 +63,7 @@ module Simplex.Chat.Store getGroup, getGroupInfo, getGroupIdByName, - getGroupByName, + getGroupMemberIdByName, getGroupInfoByName, getGroupMembers, deleteGroup, @@ -1327,12 +1327,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId} GroupInv -- TODO return the last connection that is ready, not any last connection -- requires updating connection status -getGroupByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO Group -getGroupByName db user gName = do - groupId <- getGroupIdByName db user gName - getGroup db user groupId - -getGroup :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Group +getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group getGroup db user groupId = do gInfo <- getGroupInfo db user groupId members <- liftIO $ getGroupMembers db user gInfo @@ -1416,12 +1411,11 @@ getGroupMembers db User {userId, userContactId} GroupInfo {groupId} = do toContactMember (memberRow :. connRow) = (toGroupMember userContactId memberRow) {activeConn = toMaybeConnection connRow} --- TODO no need to load all members to find the member who invited the used, +-- TODO no need to load all members to find the member who invited the user, -- instead of findFromContact there could be a query -getGroupInvitation :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO ReceivedGroupInvitation -getGroupInvitation db user localDisplayName = do +getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation +getGroupInvitation db user groupId = do cReq <- getConnRec_ user - groupId <- getGroupIdByName db user localDisplayName Group groupInfo@GroupInfo {membership} members <- getGroup db user groupId when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined case (cReq, findFromContact (invitedBy membership) members) of @@ -1431,8 +1425,8 @@ getGroupInvitation db user localDisplayName = do where getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation) getConnRec_ User {userId} = ExceptT $ do - firstRow fromOnly (SEGroupNotFoundByName localDisplayName) $ - DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.local_display_name = ? AND g.user_id = ?" (localDisplayName, userId) + firstRow fromOnly (SEGroupNotFound groupId) $ + DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId) findFromContact :: InvitedBy -> [GroupMember] -> Maybe GroupMember findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId) findFromContact _ = const Nothing @@ -3094,11 +3088,16 @@ getAllChatItemsLast_ db user@User {userId} count = do (userId, count) mapM (uncurry $ getAChatItem_ db user) itemRefs -getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO Int64 +getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId getGroupIdByName db User {userId} gName = ExceptT . firstRow fromOnly (SEGroupNotFoundByName gName) $ DB.query db "SELECT group_id FROM groups WHERE user_id = ? AND local_display_name = ?" (userId, gName) +getGroupMemberIdByName :: DB.Connection -> User -> GroupId -> ContactName -> ExceptT StoreError IO GroupMemberId +getGroupMemberIdByName db User {userId} groupId groupMemberName = + ExceptT . firstRow fromOnly (SEGroupMemberNotFound groupId groupMemberName) $ + DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName) + getChatItemIdByAgentMsgId :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) getChatItemIdByAgentMsgId db connId msgId = fmap join . maybeFirstRow fromOnly $ @@ -3770,8 +3769,9 @@ data StoreError | SEUserContactLinkNotFound | SEContactRequestNotFound {contactRequestId :: Int64} | SEContactRequestNotFoundByName {contactName :: ContactName} - | SEGroupNotFound {groupId :: Int64} + | SEGroupNotFound {groupId :: GroupId} | SEGroupNotFoundByName {groupName :: GroupName} + | SEGroupMemberNotFound {groupId :: GroupId, groupMemberName :: ContactName} | SEGroupWithoutUser | SEDuplicateGroupMember | SEGroupAlreadyJoined diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index f980bb1450..158b1d720f 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -171,8 +171,10 @@ data Group = Group {groupInfo :: GroupInfo, members :: [GroupMember]} instance ToJSON Group where toEncoding = J.genericToEncoding J.defaultOptions +type GroupId = Int64 + data GroupInfo = GroupInfo - { groupId :: Int64, + { groupId :: GroupId, localDisplayName :: GroupName, groupProfile :: GroupProfile, membership :: GroupMember, @@ -268,9 +270,11 @@ data ReceivedGroupInvitation = ReceivedGroupInvitation } deriving (Eq, Show) +type GroupMemberId = Int64 + data GroupMember = GroupMember - { groupMemberId :: Int64, - groupId :: Int64, + { groupMemberId :: GroupMemberId, + groupId :: GroupId, memberId :: MemberId, memberRole :: GroupMemberRole, memberCategory :: GroupMemberCategory, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index e1dd53fa05..42c3d0324f 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -744,7 +744,7 @@ viewChatError = \case CEGroupNotJoined g -> ["you did not join this group, use " <> highlight ("/join #" <> groupName' g)] CEGroupMemberNotActive -> ["you cannot invite other members yet, try later"] CEGroupMemberUserRemoved -> ["you are no longer a member of the group"] - CEGroupMemberNotFound c -> ["contact " <> ttyContact c <> " is not a group member"] + CEGroupMemberNotFound -> ["group doesn't have this member"] CEGroupMemberIntroNotFound c -> ["group member intro not found for " <> ttyContact c] CEGroupCantResendInvitation g c -> viewCannotResendInvitation g c CEGroupInternal s -> ["chat group bug: " <> plain s]