core: backend for group invitations UI (status, db, updates) (#815)
This commit is contained in:
JRoberts
GitHub
parent
8e15460bdc
commit
eb89eec5b5
@ -41,6 +41,7 @@ library
|
||||
Simplex.Chat.Migrations.M20220514_profiles_user_id
|
||||
Simplex.Chat.Migrations.M20220626_auto_reply
|
||||
Simplex.Chat.Migrations.M20220702_calls
|
||||
Simplex.Chat.Migrations.M20220715_groups_chat_item_id
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Options
|
||||
Simplex.Chat.Protocol
|
||||
|
||||
@ -672,27 +672,30 @@ processChatCommand = \case
|
||||
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 -> (,) <$> getGroup db user groupId <*> getContact db userId contactId
|
||||
let Group gInfo@GroupInfo {localDisplayName = gName, groupProfile, membership} members = group
|
||||
let Group gInfo@GroupInfo {localDisplayName, 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
|
||||
let sendInvitation memberId cReq = do
|
||||
void . sendDirectContactMessage contact $
|
||||
XGrpInv $ GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
|
||||
setActive $ ActiveG gName
|
||||
let sendInvitation groupMemberId memberId cReq = do
|
||||
let groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
|
||||
msg <- sendDirectContactMessage contact $ XGrpInv groupInv
|
||||
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveSndChatItem user (CDDirectSnd contact) msg content Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci
|
||||
setActive $ ActiveG localDisplayName
|
||||
pure $ CRSentGroupInvitation gInfo contact
|
||||
case contactMember contact members of
|
||||
Nothing -> do
|
||||
gVar <- asks idsDrg
|
||||
(agentConnId, cReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
GroupMember {memberId} <- withStore $ \db -> createContactMember db gVar user groupId contact memRole agentConnId cReq
|
||||
sendInvitation memberId cReq
|
||||
GroupMember {memberId, groupMemberId} <- withStore $ \db -> createContactMember db gVar user groupId contact memRole agentConnId cReq
|
||||
sendInvitation groupMemberId memberId cReq
|
||||
Just GroupMember {groupMemberId, memberId, memberStatus}
|
||||
| memberStatus == GSMemInvited ->
|
||||
withStore' (\db -> getMemberInvitation db user groupMemberId) >>= \case
|
||||
Just cReq -> sendInvitation memberId cReq
|
||||
Just cReq -> sendInvitation groupMemberId memberId cReq
|
||||
Nothing -> throwChatError $ CEGroupCantResendInvitation gInfo cName
|
||||
| otherwise -> throwChatError $ CEGroupDuplicateMember cName
|
||||
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
@ -703,11 +706,20 @@ processChatCommand = \case
|
||||
createMemberConnection db userId fromMember agentConnId
|
||||
updateGroupMemberStatus db userId fromMember GSMemAccepted
|
||||
updateGroupMemberStatus db userId (membership g) GSMemAccepted
|
||||
updateCIGroupInvitationStatus user
|
||||
pure $ CRUserAcceptedGroupSent g
|
||||
where
|
||||
updateCIGroupInvitationStatus user@User {userId} = do
|
||||
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId
|
||||
case (cInfo, content) of
|
||||
(DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do
|
||||
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole
|
||||
updateDirectChatItemView userId ct itemId aciContent Nothing
|
||||
_ -> pure () -- prohibited
|
||||
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
|
||||
case find ((== memberId) . groupMemberId') members of
|
||||
Nothing -> throwChatError CEGroupMemberNotFound
|
||||
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do
|
||||
let userRole = memberRole (membership :: GroupMember)
|
||||
@ -1714,10 +1726,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
GroupInfo {groupId, localDisplayName, groupProfile} <- withStore $ \db -> createGroupInvitation db user ct inv
|
||||
let content = CIGroupInvitation (CIGroupInfo {groupId, localDisplayName, groupProfile}) memRole
|
||||
gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = GroupMember {groupMemberId}} <- withStore $ \db -> createGroupInvitation db user ct inv
|
||||
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content Nothing
|
||||
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
|
||||
toView $ CRReceivedGroupInvitation gInfo ct memRole
|
||||
showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group"
|
||||
|
||||
checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> m ()
|
||||
|
||||
@ -259,6 +259,7 @@ data ChatResponse
|
||||
| CRContactSubError {contact :: Contact, chatError :: ChatError}
|
||||
| CRContactSubSummary {contactSubscriptions :: [ContactSubStatus]}
|
||||
| CRGroupInvitation {groupInfo :: GroupInfo}
|
||||
| CRReceivedGroupInvitation {groupInfo :: GroupInfo, contact :: Contact, memberRole :: GroupMemberRole}
|
||||
| CRUserJoinedGroup {groupInfo :: GroupInfo}
|
||||
| CRJoinedGroupMember {groupInfo :: GroupInfo, member :: GroupMember}
|
||||
| CRJoinedGroupMemberConnecting {groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember}
|
||||
|
||||
@ -495,8 +495,8 @@ ciDeleteModeToText = \case
|
||||
CIDMBroadcast -> "this item is deleted (broadcast)"
|
||||
CIDMInternal -> "this item is deleted (internal)"
|
||||
|
||||
ciGroupInvitationToText :: CIGroupInfo -> GroupMemberRole -> Text
|
||||
ciGroupInvitationToText CIGroupInfo {groupProfile = GroupProfile {displayName, fullName}} role =
|
||||
ciGroupInvitationToText :: CIGroupInvitation -> GroupMemberRole -> Text
|
||||
ciGroupInvitationToText CIGroupInvitation {groupProfile = GroupProfile {displayName, fullName}} role =
|
||||
"invitation to join group " <> displayName <> optionalFullName displayName fullName <> " as " <> (decodeLatin1 . strEncode $ role)
|
||||
|
||||
-- This type is used both in API and in DB, so we use different JSON encodings for the database and for the API
|
||||
@ -508,21 +508,38 @@ data CIContent (d :: MsgDirection) where
|
||||
CISndCall :: CICallStatus -> Int -> CIContent 'MDSnd
|
||||
CIRcvCall :: CICallStatus -> Int -> CIContent 'MDRcv
|
||||
CIRcvIntegrityError :: MsgErrorType -> CIContent 'MDRcv
|
||||
CIGroupInvitation :: CIGroupInfo -> GroupMemberRole -> CIContent 'MDRcv
|
||||
CIRcvGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDRcv
|
||||
CISndGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDSnd
|
||||
|
||||
deriving instance Show (CIContent d)
|
||||
|
||||
data CIGroupInfo = CIGroupInfo
|
||||
data CIGroupInvitation = CIGroupInvitation
|
||||
{ groupId :: GroupId,
|
||||
groupMemberId :: GroupMemberId,
|
||||
localDisplayName :: GroupName,
|
||||
groupProfile :: GroupProfile
|
||||
groupProfile :: GroupProfile,
|
||||
status :: CIGroupInvitationStatus
|
||||
}
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
instance ToJSON CIGroupInfo where
|
||||
instance ToJSON CIGroupInvitation where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data CIGroupInvitationStatus
|
||||
= CIGISPending
|
||||
| CIGISAccepted
|
||||
| CIGISRejected
|
||||
| CIGISExpired
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromJSON CIGroupInvitationStatus where
|
||||
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CIGIS"
|
||||
|
||||
instance ToJSON CIGroupInvitationStatus where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CIGIS"
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CIGIS"
|
||||
|
||||
ciContentToText :: CIContent d -> Text
|
||||
ciContentToText = \case
|
||||
CISndMsgContent mc -> msgContentText mc
|
||||
@ -532,7 +549,8 @@ ciContentToText = \case
|
||||
CISndCall status duration -> "outgoing call: " <> ciCallInfoText status duration
|
||||
CIRcvCall status duration -> "incoming call: " <> ciCallInfoText status duration
|
||||
CIRcvIntegrityError err -> msgIntegrityError err
|
||||
CIGroupInvitation groupInfo memberRole -> ciGroupInvitationToText groupInfo memberRole
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> "received " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
CISndGroupInvitation groupInvitation memberRole -> "sent " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
|
||||
msgIntegrityError :: MsgErrorType -> Text
|
||||
msgIntegrityError = \case
|
||||
@ -577,7 +595,8 @@ data JSONCIContent
|
||||
| JCISndCall {status :: CICallStatus, duration :: Int} -- duration in seconds
|
||||
| JCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| JCIRcvIntegrityError {msgError :: MsgErrorType}
|
||||
| JCIGroupInvitation {groupInfo :: CIGroupInfo, memberRole :: GroupMemberRole}
|
||||
| JCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| JCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON JSONCIContent where
|
||||
@ -596,7 +615,8 @@ jsonCIContent = \case
|
||||
CISndCall status duration -> JCISndCall {status, duration}
|
||||
CIRcvCall status duration -> JCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> JCIRcvIntegrityError err
|
||||
CIGroupInvitation groupInfo memberRole -> JCIGroupInvitation {groupInfo, memberRole}
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> JCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> JCISndGroupInvitation {groupInvitation, memberRole}
|
||||
|
||||
aciContentJSON :: JSONCIContent -> ACIContent
|
||||
aciContentJSON = \case
|
||||
@ -607,7 +627,8 @@ aciContentJSON = \case
|
||||
JCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
|
||||
JCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
JCIRcvIntegrityError err -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
JCIGroupInvitation {groupInfo, memberRole} -> ACIContent SMDRcv $ CIGroupInvitation groupInfo memberRole
|
||||
JCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
JCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
|
||||
-- platform independent
|
||||
data DBJSONCIContent
|
||||
@ -618,7 +639,8 @@ data DBJSONCIContent
|
||||
| DBJCISndCall {status :: CICallStatus, duration :: Int}
|
||||
| DBJCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| DBJCIRcvIntegrityError {msgError :: MsgErrorType}
|
||||
| DBJCIGroupInvitation {groupInfo :: CIGroupInfo, memberRole :: GroupMemberRole}
|
||||
| DBJCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| DBJCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
deriving (Generic)
|
||||
|
||||
instance FromJSON DBJSONCIContent where
|
||||
@ -637,7 +659,8 @@ dbJsonCIContent = \case
|
||||
CISndCall status duration -> DBJCISndCall {status, duration}
|
||||
CIRcvCall status duration -> DBJCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> DBJCIRcvIntegrityError err
|
||||
CIGroupInvitation groupInfo memberRole -> DBJCIGroupInvitation {groupInfo, memberRole}
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> DBJCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> DBJCISndGroupInvitation {groupInvitation, memberRole}
|
||||
|
||||
aciContentDBJSON :: DBJSONCIContent -> ACIContent
|
||||
aciContentDBJSON = \case
|
||||
@ -648,7 +671,8 @@ aciContentDBJSON = \case
|
||||
DBJCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
|
||||
DBJCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
DBJCIRcvIntegrityError err -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
DBJCIGroupInvitation {groupInfo, memberRole} -> ACIContent SMDRcv $ CIGroupInvitation groupInfo memberRole
|
||||
DBJCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
DBJCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
|
||||
data CICallStatus
|
||||
= CISCallPending
|
||||
|
||||
12
src/Simplex/Chat/Migrations/M20220715_groups_chat_item_id.hs
Normal file
12
src/Simplex/Chat/Migrations/M20220715_groups_chat_item_id.hs
Normal file
@ -0,0 +1,12 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20220715_groups_chat_item_id where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20220715_groups_chat_item_id :: Query
|
||||
m20220715_groups_chat_item_id =
|
||||
[sql|
|
||||
ALTER TABLE groups ADD COLUMN chat_item_id INTEGER DEFAULT NULL REFERENCES chat_items ON DELETE SET NULL;
|
||||
|]
|
||||
@ -117,7 +117,8 @@ CREATE TABLE groups(
|
||||
group_profile_id INTEGER REFERENCES group_profiles ON DELETE SET NULL, -- shared group profile
|
||||
inv_queue_info BLOB,
|
||||
created_at TEXT CHECK(created_at NOT NULL),
|
||||
updated_at TEXT CHECK(updated_at NOT NULL), -- received
|
||||
updated_at TEXT CHECK(updated_at NOT NULL),
|
||||
chat_item_id INTEGER DEFAULT NULL REFERENCES chat_items ON DELETE SET NULL, -- received
|
||||
FOREIGN KEY(user_id, local_display_name)
|
||||
REFERENCES display_names(user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
|
||||
@ -60,6 +60,7 @@ module Simplex.Chat.Store
|
||||
updateConnectionStatus,
|
||||
createNewGroup,
|
||||
createGroupInvitation,
|
||||
setGroupInvitationChatItemId,
|
||||
getGroup,
|
||||
getGroupInfo,
|
||||
getGroupIdByName,
|
||||
@ -147,6 +148,7 @@ module Simplex.Chat.Store
|
||||
getDirectChatItemIdByText,
|
||||
getGroupChatItemIdByText,
|
||||
getChatItemByFileId,
|
||||
getChatItemByGroupId,
|
||||
updateDirectChatItemStatus,
|
||||
updateDirectCIFileStatus,
|
||||
updateDirectChatItem,
|
||||
@ -212,6 +214,7 @@ import Simplex.Chat.Migrations.M20220404_files_status_fields
|
||||
import Simplex.Chat.Migrations.M20220514_profiles_user_id
|
||||
import Simplex.Chat.Migrations.M20220626_auto_reply
|
||||
import Simplex.Chat.Migrations.M20220702_calls
|
||||
import Simplex.Chat.Migrations.M20220715_groups_chat_item_id
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..))
|
||||
@ -238,7 +241,8 @@ schemaMigrations =
|
||||
("20220404_files_status_fields", m20220404_files_status_fields),
|
||||
("20220514_profiles_user_id", m20220514_profiles_user_id),
|
||||
("20220626_auto_reply", m20220626_auto_reply),
|
||||
("20220702_calls", m20220702_calls)
|
||||
("20220702_calls", m20220702_calls),
|
||||
("20220715_groups_chat_item_id", m20220715_groups_chat_item_id)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@ -1325,6 +1329,11 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId} GroupInv
|
||||
membership <- createContactMember_ db user groupId user invitedMember GCUserMember GSMemInvited (IBContact contactId) currentTs
|
||||
pure $ GroupInfo {groupId, localDisplayName, groupProfile, membership, createdAt = currentTs, updatedAt = currentTs}
|
||||
|
||||
setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO ()
|
||||
setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE groups SET chat_item_id = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (chatItemId, currentTs, userId, groupId)
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group
|
||||
@ -1335,7 +1344,7 @@ getGroup db user groupId = do
|
||||
|
||||
deleteGroup :: DB.Connection -> User -> Group -> IO ()
|
||||
deleteGroup db User {userId} (Group GroupInfo {groupId, localDisplayName} members) = do
|
||||
forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId m)
|
||||
forM_ members $ \m -> DB.execute db "DELETE FROM connections WHERE user_id = ? AND group_member_id = ?" (userId, groupMemberId' m)
|
||||
DB.execute db "DELETE FROM group_members WHERE user_id = ? AND group_id = ?" (userId, groupId)
|
||||
DB.execute
|
||||
db
|
||||
@ -1538,7 +1547,7 @@ deleteGroupMemberConnection db userId GroupMember {groupMemberId} =
|
||||
|
||||
createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
|
||||
createIntroductions db members toMember = do
|
||||
let reMembers = filter (\m -> memberCurrent m && groupMemberId m /= groupMemberId toMember) members
|
||||
let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members
|
||||
if null reMembers
|
||||
then pure []
|
||||
else do
|
||||
@ -1554,7 +1563,7 @@ createIntroductions db members toMember = do
|
||||
(re_group_member_id, to_group_member_id, intro_status, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?)
|
||||
|]
|
||||
(groupMemberId reMember, groupMemberId toMember, GMIntroPending, ts, ts)
|
||||
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, ts, ts)
|
||||
introId <- insertedRowId db
|
||||
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
|
||||
|
||||
@ -1623,7 +1632,7 @@ getIntroduction_ db reMember toMember = ExceptT $ do
|
||||
FROM group_member_intros
|
||||
WHERE re_group_member_id = ? AND to_group_member_id = ?
|
||||
|]
|
||||
(groupMemberId reMember, groupMemberId toMember)
|
||||
(groupMemberId' reMember, groupMemberId' toMember)
|
||||
where
|
||||
toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro
|
||||
toIntro [(introId, groupConnReq, directConnReq, introStatus)] =
|
||||
@ -1649,7 +1658,7 @@ createIntroReMember db user@User {userId} gInfo@GroupInfo {groupId} _host@GroupM
|
||||
memProfileId
|
||||
}
|
||||
member <- createNewMember_ db user gInfo newMember currentTs
|
||||
conn <- createMemberConnection_ db userId (groupMemberId member) groupAgentConnId memberContactId cLevel currentTs
|
||||
conn <- createMemberConnection_ db userId (groupMemberId' member) groupAgentConnId memberContactId cLevel currentTs
|
||||
pure (member :: GroupMember) {activeConn = Just conn}
|
||||
|
||||
createIntroToMemberContact :: DB.Connection -> UserId -> GroupMember -> GroupMember -> ConnId -> ConnId -> IO ()
|
||||
@ -2572,6 +2581,7 @@ getDirectChatPreviews_ db User {userId} = do
|
||||
) ChatStats ON ChatStats.contact_id = ct.contact_id
|
||||
LEFT JOIN chat_items ri ON i.quoted_shared_msg_id = ri.shared_msg_id
|
||||
WHERE ct.user_id = ?
|
||||
AND (c.conn_level = 0 OR i.chat_item_id IS NOT NULL)
|
||||
AND c.connection_id = (
|
||||
SELECT cc_connection_id FROM (
|
||||
SELECT
|
||||
@ -3470,6 +3480,22 @@ getChatItemByFileId db user@User {userId} fileId = do
|
||||
(userId, fileId)
|
||||
getAChatItem_ db user itemId chatRef
|
||||
|
||||
getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByGroupId db user@User {userId} groupId = do
|
||||
(itemId, chatRef) <-
|
||||
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT i.chat_item_id, i.contact_id, i.group_id
|
||||
FROM chat_items i
|
||||
JOIN groups g ON g.chat_item_id = i.chat_item_id
|
||||
WHERE g.user_id = ? AND g.group_id = ?
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupId)
|
||||
getAChatItem_ db user itemId chatRef
|
||||
|
||||
getAChatItem_ :: DB.Connection -> User -> ChatItemId -> ChatRef -> ExceptT StoreError IO AChatItem
|
||||
getAChatItem_ db user@User {userId} itemId = \case
|
||||
ChatRef CTDirect contactId -> do
|
||||
@ -3794,6 +3820,7 @@ data StoreError
|
||||
| SEQuotedChatItemNotFound
|
||||
| SEChatItemSharedMsgIdNotFound {sharedMsgId :: SharedMsgId}
|
||||
| SEChatItemNotFoundByFileId {fileId :: FileTransferId}
|
||||
| SEChatItemNotFoundByGroupId {groupId :: GroupId}
|
||||
deriving (Show, Exception, Generic)
|
||||
|
||||
instance ToJSON StoreError where
|
||||
|
||||
@ -303,6 +303,9 @@ memberConn = activeConn
|
||||
memberConnId :: GroupMember -> Maybe ConnId
|
||||
memberConnId GroupMember {activeConn} = aConnId <$> activeConn
|
||||
|
||||
groupMemberId' :: GroupMember -> GroupMemberId
|
||||
groupMemberId' GroupMember {groupMemberId} = groupMemberId
|
||||
|
||||
data NewGroupMember = NewGroupMember
|
||||
{ memInfo :: MemberInfo,
|
||||
memCategory :: GroupMemberCategory,
|
||||
|
||||
@ -132,7 +132,8 @@ responseToView testView = \case
|
||||
where
|
||||
(errors, subscribed) = partition (isJust . contactError) summary
|
||||
CRGroupInvitation GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}} ->
|
||||
[groupInvitation ldn fullName]
|
||||
[groupInvitation' ldn fullName]
|
||||
CRReceivedGroupInvitation g c role -> viewReceivedGroupInvitation g c role
|
||||
CRUserJoinedGroup g -> [ttyGroup' g <> ": you joined the group"]
|
||||
CRJoinedGroupMember g m -> [ttyGroup' g <> ": " <> ttyMember m <> " joined the group "]
|
||||
CRJoinedGroupMemberConnecting g host m -> [ttyGroup' g <> ": " <> ttyMember host <> " added " <> ttyFullMember m <> " to the group (connecting...)"]
|
||||
@ -206,6 +207,7 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha
|
||||
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
|
||||
CISndDeleted _ -> []
|
||||
CISndCall {} -> []
|
||||
CISndGroupInvitation {} -> []
|
||||
where
|
||||
to = ttyToContact' c
|
||||
CIDirectRcv -> case content of
|
||||
@ -213,7 +215,7 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha
|
||||
CIRcvDeleted _ -> []
|
||||
CIRcvCall {} -> []
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err meta
|
||||
CIGroupInvitation g role -> viewReceivedGroupInvitation g c role
|
||||
CIRcvGroupInvitation {} -> []
|
||||
where
|
||||
from = ttyFromContact' c
|
||||
where
|
||||
@ -223,6 +225,7 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha
|
||||
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
|
||||
CISndDeleted _ -> []
|
||||
CISndCall {} -> []
|
||||
CISndGroupInvitation {} -> [] -- prohibited
|
||||
where
|
||||
to = ttyToGroup g
|
||||
CIGroupRcv m -> case content of
|
||||
@ -230,7 +233,7 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha
|
||||
CIRcvDeleted _ -> []
|
||||
CIRcvCall {} -> []
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err meta
|
||||
CIGroupInvitation {} -> [] -- should be not possible
|
||||
CIRcvGroupInvitation {} -> [] -- prohibited
|
||||
where
|
||||
from = ttyFromGroup' g m
|
||||
where
|
||||
@ -387,10 +390,10 @@ viewCannotResendInvitation GroupInfo {localDisplayName = gn} c =
|
||||
"to re-send invitation: " <> highlight ("/rm " <> gn <> " " <> c) <> ", " <> highlight ("/a " <> gn <> " " <> c)
|
||||
]
|
||||
|
||||
viewReceivedGroupInvitation :: CIGroupInfo -> Contact -> GroupMemberRole -> [StyledString]
|
||||
viewReceivedGroupInvitation CIGroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} c role =
|
||||
[ ttyGroup g <> optFullName g fullName <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role),
|
||||
"use " <> highlight ("/j " <> g) <> " to accept"
|
||||
viewReceivedGroupInvitation :: GroupInfo -> Contact -> GroupMemberRole -> [StyledString]
|
||||
viewReceivedGroupInvitation g c role =
|
||||
[ ttyFullGroup g <> ": " <> ttyContact' c <> " invites you to join the group as " <> plain (strEncode role),
|
||||
"use " <> highlight ("/j " <> groupName' g) <> " to accept"
|
||||
]
|
||||
|
||||
groupPreserved :: GroupInfo -> [StyledString]
|
||||
@ -429,11 +432,11 @@ viewGroupsList gs = map groupSS $ sortOn ldn_ gs
|
||||
ldn_ = T.toLower . (localDisplayName :: GroupInfo -> GroupName)
|
||||
groupSS GroupInfo {localDisplayName = ldn, groupProfile = GroupProfile {fullName}, membership} =
|
||||
case memberStatus membership of
|
||||
GSMemInvited -> groupInvitation ldn fullName
|
||||
GSMemInvited -> groupInvitation' ldn fullName
|
||||
_ -> ttyGroup ldn <> optFullName ldn fullName
|
||||
|
||||
groupInvitation :: GroupName -> Text -> StyledString
|
||||
groupInvitation displayName fullName =
|
||||
groupInvitation' :: GroupName -> Text -> StyledString
|
||||
groupInvitation' displayName fullName =
|
||||
highlight ("#" <> displayName)
|
||||
<> optFullName displayName fullName
|
||||
<> " - you are invited ("
|
||||
|
||||
@ -455,13 +455,15 @@ testGroup = versionTestMatrix3 runTestGroup
|
||||
cath #$> ("/_get chat #1 count=100", chat, [])
|
||||
getReadChats :: TestCC -> TestCC -> TestCC -> IO ()
|
||||
getReadChats alice bob cath = do
|
||||
alice @@@ [("#team", "hey team"), ("@cath", ""), ("@bob", "")]
|
||||
alice @@@ [("#team", "hey team"), ("@cath", "sent invitation to join group team as admin"), ("@bob", "sent invitation to join group team as admin")]
|
||||
alice #$> ("/_get chat #1 count=100", chat, [(1, "hello"), (0, "hi there"), (0, "hey team")])
|
||||
alice #$> ("/_get chat #1 after=1 count=100", chat, [(0, "hi there"), (0, "hey team")])
|
||||
alice #$> ("/_get chat #1 before=3 count=100", chat, [(1, "hello"), (0, "hi there")])
|
||||
bob @@@ [("@cath", "hey"), ("#team", "hey team"), ("@alice", "invitation to join group team as admin")]
|
||||
-- "before" and "after" define a chat item id across all chats,
|
||||
-- so we take into account sent group invitations in direct chats
|
||||
alice #$> ("/_get chat #1 after=3 count=100", chat, [(0, "hi there"), (0, "hey team")])
|
||||
alice #$> ("/_get chat #1 before=5 count=100", chat, [(1, "hello"), (0, "hi there")])
|
||||
bob @@@ [("@cath", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")]
|
||||
bob #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (1, "hi there"), (0, "hey team")])
|
||||
cath @@@ [("@bob", "hey"), ("#team", "hey team"), ("@alice", "invitation to join group team as admin")]
|
||||
cath @@@ [("@bob", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")]
|
||||
cath #$> ("/_get chat #1 count=100", chat, [(0, "hello"), (0, "hi there"), (1, "hey team")])
|
||||
alice #$> ("/_read chat #1 from=1 to=100", id, "ok")
|
||||
bob #$> ("/_read chat #1 from=1 to=100", id, "ok")
|
||||
@ -576,7 +578,7 @@ testGroup2 =
|
||||
<##? [ "dan> hi",
|
||||
"@dan hey"
|
||||
]
|
||||
alice ##> "/t 6"
|
||||
alice ##> "/t 8"
|
||||
alice
|
||||
<##? [ "#club hello",
|
||||
"#club bob> hi there",
|
||||
@ -878,13 +880,13 @@ testGroupMessageUpdate =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
-- msg id 1
|
||||
-- alice: msg id 3, bob, cath: msg id 2 (after group invitations)
|
||||
alice #> "#team hello!"
|
||||
concurrently_
|
||||
(bob <# "#team alice> hello!")
|
||||
(cath <# "#team alice> hello!")
|
||||
|
||||
alice #$> ("/_update item #1 1 text hey 👋", id, "message updated")
|
||||
alice #$> ("/_update item #1 3 text hey 👋", id, "message updated")
|
||||
concurrently_
|
||||
(bob <# "#team alice> [edited] hey 👋")
|
||||
(cath <# "#team alice> [edited] hey 👋")
|
||||
@ -894,7 +896,7 @@ testGroupMessageUpdate =
|
||||
cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing)])
|
||||
|
||||
threadDelay 1000000
|
||||
-- msg id 2
|
||||
-- alice: msg id 4, bob, cath: msg id 3
|
||||
bob `send` "> #team @alice (hey) hi alice"
|
||||
bob <# "#team > alice hey 👋"
|
||||
bob <## " hi alice"
|
||||
@ -912,12 +914,12 @@ testGroupMessageUpdate =
|
||||
bob #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((1, "hi alice"), Just (0, "hey 👋"))])
|
||||
cath #$> ("/_get chat #1 count=100", chat', [((0, "hey 👋"), Nothing), ((0, "hi alice"), Just (0, "hey 👋"))])
|
||||
|
||||
alice #$> ("/_update item #1 1 text greetings 🤝", id, "message updated")
|
||||
alice #$> ("/_update item #1 3 text greetings 🤝", id, "message updated")
|
||||
concurrently_
|
||||
(bob <# "#team alice> [edited] greetings 🤝")
|
||||
(cath <# "#team alice> [edited] greetings 🤝")
|
||||
|
||||
alice #$> ("/_update item #1 2 text updating bob's message", id, "cannot update this item")
|
||||
alice #$> ("/_update item #1 4 text updating bob's message", id, "cannot update this item")
|
||||
|
||||
threadDelay 1000000
|
||||
cath `send` "> #team @alice (greetings) greetings!"
|
||||
@ -942,23 +944,23 @@ testGroupMessageDelete =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
-- alice: msg id 1, bob, cath: msg id 2 (1 is group invitation)
|
||||
-- alice: msg id 3, bob, cath: msg id 2 (after group invitations)
|
||||
alice #> "#team hello!"
|
||||
concurrently_
|
||||
(bob <# "#team alice> hello!")
|
||||
(cath <# "#team alice> hello!")
|
||||
|
||||
alice #$> ("/_delete item #1 1 internal", id, "message deleted")
|
||||
alice #$> ("/_delete item #1 3 internal", id, "message deleted")
|
||||
|
||||
alice #$> ("/_get chat #1 count=100", chat, [])
|
||||
bob #$> ("/_get chat #1 count=100", chat, [(0, "hello!")])
|
||||
cath #$> ("/_get chat #1 count=100", chat, [(0, "hello!")])
|
||||
|
||||
alice #$> ("/_update item #1 1 text updating deleted message", id, "cannot update this item")
|
||||
alice #$> ("/_send #1 json {\"quotedItemId\": 1, \"msgContent\": {\"type\": \"text\", \"text\": \"quoting deleted message\"}}", id, "cannot reply to this message")
|
||||
alice #$> ("/_update item #1 3 text updating deleted message", id, "cannot update this item")
|
||||
alice #$> ("/_send #1 json {\"quotedItemId\": 3, \"msgContent\": {\"type\": \"text\", \"text\": \"quoting deleted message\"}}", id, "cannot reply to this message")
|
||||
|
||||
threadDelay 1000000
|
||||
-- alice: msg id 2, bob, cath: msg id 3
|
||||
-- alice: msg id 4, bob, cath: msg id 3
|
||||
bob `send` "> #team @alice (hello) hi alic"
|
||||
bob <# "#team > alice hello!"
|
||||
bob <## " hi alic"
|
||||
@ -976,12 +978,12 @@ testGroupMessageDelete =
|
||||
bob #$> ("/_get chat #1 count=100", chat', [((0, "hello!"), Nothing), ((1, "hi alic"), Just (0, "hello!"))])
|
||||
cath #$> ("/_get chat #1 count=100", chat', [((0, "hello!"), Nothing), ((0, "hi alic"), Just (0, "hello!"))])
|
||||
|
||||
alice #$> ("/_delete item #1 1 broadcast", id, "message deleted")
|
||||
alice #$> ("/_delete item #1 3 broadcast", id, "message deleted")
|
||||
concurrently_
|
||||
(bob <# "#team alice> [deleted] hello!")
|
||||
(cath <# "#team alice> [deleted] hello!")
|
||||
|
||||
alice #$> ("/_delete item #1 2 internal", id, "message deleted")
|
||||
alice #$> ("/_delete item #1 4 internal", id, "message deleted")
|
||||
|
||||
alice #$> ("/_get chat #1 count=100", chat', [])
|
||||
bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alic"), Just (0, "hello!"))])
|
||||
@ -1000,7 +1002,7 @@ testGroupMessageDelete =
|
||||
cath #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))])
|
||||
|
||||
threadDelay 1000000
|
||||
-- alice: msg id 3, bob, cath: msg id 4
|
||||
-- alice: msg id 5, bob, cath: msg id 4
|
||||
cath #> "#team how are you?"
|
||||
concurrently_
|
||||
(alice <# "#team cath> how are you?")
|
||||
@ -1011,8 +1013,8 @@ testGroupMessageDelete =
|
||||
(alice <# "#team cath> [deleted] how are you?")
|
||||
(bob <# "#team cath> [deleted] how are you?")
|
||||
|
||||
alice #$> ("/_delete item #1 2 broadcast", id, "cannot delete this item")
|
||||
alice #$> ("/_delete item #1 2 internal", id, "message deleted")
|
||||
alice #$> ("/_delete item #1 4 broadcast", id, "cannot delete this item")
|
||||
alice #$> ("/_delete item #1 4 internal", id, "message deleted")
|
||||
|
||||
alice #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing)])
|
||||
bob #$> ("/_get chat #1 count=100", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "this item is deleted (broadcast)"), Nothing)])
|
||||
@ -1020,6 +1022,7 @@ testGroupMessageDelete =
|
||||
|
||||
testGroupAsync :: IO ()
|
||||
testGroupAsync = withTmpFiles $ do
|
||||
print (0 :: Integer)
|
||||
withNewTestChat "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChat "bob" bobProfile $ \bob -> do
|
||||
connectUsers alice bob
|
||||
@ -1039,6 +1042,7 @@ testGroupAsync = withTmpFiles $ do
|
||||
(bob <## "#team: you joined the group")
|
||||
alice #> "#team hello bob"
|
||||
bob <# "#team alice> hello bob"
|
||||
print (1 :: Integer)
|
||||
withTestChat "alice" $ \alice -> do
|
||||
withNewTestChat "cath" cathProfile $ \cath -> do
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
@ -1058,6 +1062,7 @@ testGroupAsync = withTmpFiles $ do
|
||||
]
|
||||
alice #> "#team hello cath"
|
||||
cath <# "#team alice> hello cath"
|
||||
print (2 :: Integer)
|
||||
withTestChat "bob" $ \bob -> do
|
||||
withTestChat "cath" $ \cath -> do
|
||||
concurrentlyN_
|
||||
@ -1072,6 +1077,7 @@ testGroupAsync = withTmpFiles $ do
|
||||
cath <## "#team: connected to server(s)"
|
||||
cath <## "#team: member bob (Bob) is connected"
|
||||
]
|
||||
print (3 :: Integer)
|
||||
withTestChat "bob" $ \bob -> do
|
||||
withNewTestChat "dan" danProfile $ \dan -> do
|
||||
bob <## "2 contacts connected (use /cs for the list)"
|
||||
@ -1089,6 +1095,7 @@ testGroupAsync = withTmpFiles $ do
|
||||
[ bob <## "#team: dan joined the group",
|
||||
dan <## "#team: you joined the group"
|
||||
]
|
||||
print (4 :: Integer)
|
||||
withTestChat "alice" $ \alice -> do
|
||||
withTestChat "cath" $ \cath -> do
|
||||
withTestChat "dan" $ \dan -> do
|
||||
@ -1109,6 +1116,7 @@ testGroupAsync = withTmpFiles $ do
|
||||
dan <## "#team: member alice (Alice) is connected"
|
||||
dan <## "#team: member cath (Catherine) is connected"
|
||||
]
|
||||
print (5 :: Integer)
|
||||
withTestChat "alice" $ \alice -> do
|
||||
withTestChat "bob" $ \bob -> do
|
||||
withTestChat "cath" $ \cath -> do
|
||||
@ -1653,7 +1661,7 @@ testGroupSendImageWithTextAndQuote =
|
||||
(alice <# "#team bob> hi team")
|
||||
(cath <# "#team bob> hi team")
|
||||
threadDelay 1000000
|
||||
alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": 1, \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}"
|
||||
alice ##> "/_send #1 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"quotedItemId\": 3, \"msgContent\": {\"text\":\"hey bob\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}"
|
||||
alice <# "#team > bob hi team"
|
||||
alice <## " hey bob"
|
||||
alice <# "/f #team ./tests/fixtures/test.jpg"
|
||||
@ -1696,11 +1704,11 @@ testGroupSendImageWithTextAndQuote =
|
||||
dest2 <- B.readFile "./tests/tmp/test_1.jpg"
|
||||
dest2 `shouldBe` src
|
||||
alice #$> ("/_get chat #1 count=100", chat'', [((0, "hi team"), Nothing, Nothing), ((1, "hey bob"), Just (0, "hi team"), Just "./tests/fixtures/test.jpg")])
|
||||
alice @@@ [("#team", "hey bob"), ("@bob", ""), ("@cath", "")]
|
||||
alice @@@ [("#team", "hey bob"), ("@bob", "sent invitation to join group team as admin"), ("@cath", "sent invitation to join group team as admin")]
|
||||
bob #$> ("/_get chat #1 count=100", chat'', [((1, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (1, "hi team"), Just "./tests/tmp/test.jpg")])
|
||||
bob @@@ [("#team", "hey bob"), ("@cath",""), ("@alice","invitation to join group team as admin")]
|
||||
bob @@@ [("#team", "hey bob"), ("@alice","received invitation to join group team as admin")]
|
||||
cath #$> ("/_get chat #1 count=100", chat'', [((0, "hi team"), Nothing, Nothing), ((0, "hey bob"), Just (0, "hi team"), Just "./tests/tmp/test_1.jpg")])
|
||||
cath @@@ [("#team", "hey bob"), ("@bob",""), ("@alice","invitation to join group team as admin")]
|
||||
cath @@@ [("#team", "hey bob"), ("@alice","received invitation to join group team as admin")]
|
||||
|
||||
testUserContactLink :: Spec
|
||||
testUserContactLink = versionTestMatrix3 $ \alice bob cath -> do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user