dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-08-28 05:24:44 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: groups api (#806)

Browse Source
This commit is contained in:
JRoberts
2022-07-12 19:20:56 +04:00
committed by GitHub
parent 494de9bc43
commit ad5edeba6c
5 changed files with 88 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+57 -26
View File
@@ -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
src/Simplex/Chat/Controller.hs
+8 -2
View File
@@ -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}
src/Simplex/Chat/Store.hs
+15 -15
View File
@@ -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
src/Simplex/Chat/Types.hs
+7 -3
View File
@@ -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,
src/Simplex/Chat/View.hs
+1 -1
View File
@@ -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]