dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-11 01:57:20 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: channel messages (#6604)

Browse Source 
* core: channel messages (WIP)

* do not include member ID when quoting channel messages

* query plans

* reduce duplication

* refactor

* refactor plan

* refactor 2

* all tests

* remove plan

* refactor 3

* refactor 4

* refactor 5

* refactor 6

* plans

* plans to imrove test coverage and fix bugs

* update plan

* update plan

* bug fixes (wip)

* new plan

* fixes wip

* more tests

* comment, fix lint

* restore comment

* restore comments

* rename param

* move type

* simplify

* comment

* fix stale state

* refactor

* less diff

* simplify

* less diff

* refactor

---------

Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny
2026-02-12 07:11:59 +00:00
committed by GitHub
parent e29712c2e8
commit 628b00eb08
31 changed files with 3453 additions and 532 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Library/Commands.hs
+83 -66
View File
@@ -620,12 +620,12 @@ processChatCommand vr nm = \case
mapM_ assertNoMentions cms
withContactLock "sendMessage" chatId $
sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
SRGroup chatId gsScope ->
SRGroup chatId gsScope asGroup ->
withGroupLock "sendMessage" chatId $ do
(gInfo, cmrs) <- withFastStore $ \db -> do
g <- getGroupInfo db vr user chatId
(g,) <$> mapM (composedMessageReqMentions db user g) cms
sendGroupContentMessages user gInfo gsScope live itemTTL cmrs
sendGroupContentMessages user gInfo gsScope asGroup live itemTTL cmrs
APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
_ <- createChatTag db user emoji text
CRChatTags user <$> getUserChatTags db user
@@ -654,7 +654,7 @@ processChatCommand vr nm = \case
gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId
let mc = MCReport reportText reportReason
cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty}
sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False Nothing [composedMessageReq cm]
sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False False Nothing [composedMessageReq cm]
ReportMessage {groupName, contactName_, reportReason, reportedMessage} -> withUser $ \user -> do
gId <- withFastStore $ \db -> getGroupIdByName db user groupName
reportedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId contactName_ reportedMessage
@@ -672,7 +672,7 @@ processChatCommand vr nm = \case
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
let event = XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) Nothing
let event = XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) Nothing Nothing
(SndMessage {msgId}, _) <- sendDirectContactMessage user ct event
ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime
@@ -695,7 +695,7 @@ processChatCommand vr nm = \case
-- TODO [knocking] check chat item scope?
cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable, showGroupAsSender}, content = ciContent} -> do
case (ciContent, itemSharedMsgId, editable) of
(CISndMsgContent oldMC, Just itemSharedMId, True) -> do
chatScopeInfo <- mapM (getChatScopeInfo vr user) scope
@@ -706,7 +706,7 @@ processChatCommand vr nm = \case
ciMentions <- withFastStore $ \db -> getCIMentions db user gInfo ft_ mentions
let msgScope = toMsgScope gInfo <$> chatScopeInfo
mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope
event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope (Just showGroupAsSender)
SndMessage {msgId} <- sendGroupMessage user gInfo scope recipients event
ci' <- withFastStore' $ \db -> do
currentTs <- liftIO getCurrentTime
@@ -852,10 +852,10 @@ processChatCommand vr nm = \case
throwCmdError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)
unless (ciReactionAllowed ci) $
throwCmdError "reaction not allowed - chat item has no content"
let GroupMember {memberId = itemMemberId} = chatItemMember g ci
let itemMemberId = memberId' <$> chatItemMember g ci
rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True
checkReactionAllowed rs
SndMessage {msgId} <- sendGroupMessage user g scope recipients (XMsgReact itemSharedMId (Just itemMemberId) (toMsgScope g <$> chatScopeInfo) reaction add)
SndMessage {msgId} <- sendGroupMessage user g scope recipients (XMsgReact itemSharedMId itemMemberId (toMsgScope g <$> chatScopeInfo) reaction add)
createdAt <- liftIO getCurrentTime
reactions <- withFastStore' $ \db -> do
setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt
@@ -927,7 +927,7 @@ processChatCommand vr nm = \case
MCChat {} -> True
MCUnknown {} -> True
-- TODO [knocking] forward from / to scope
APIForwardChatItems toChat@(ChatRef toCType toChatId toScope) fromChat@(ChatRef fromCType fromChatId _fromScope) itemIds itemTTL -> withUser $ \user -> case toCType of
APIForwardChatItems toChat@(ChatRef toCType toChatId toScope) sendAsGroup fromChat@(ChatRef fromCType fromChatId _fromScope) itemIds itemTTL -> withUser $ \user -> case toCType of
CTDirect -> do
cmrs <- prepareForward user
case L.nonEmpty cmrs of
@@ -941,7 +941,7 @@ processChatCommand vr nm = \case
Just cmrs' ->
withGroupLock "forwardChatItem, to group" toChatId $ do
gInfo <- withFastStore $ \db -> getGroupInfo db vr user toChatId
sendGroupContentMessages user gInfo toScope False itemTTL cmrs'
sendGroupContentMessages user gInfo toScope sendAsGroup False itemTTL cmrs'
Nothing -> pure $ CRNewChatItems user []
CTLocal -> do
cmrs <- prepareForward user
@@ -1275,7 +1275,7 @@ processChatCommand vr nm = \case
sendWelcomeMsg user ct ucl UserContactRequest {welcomeSharedMsgId} =
forM_ (autoReply $ addressSettings ucl) $ \mc -> case welcomeSharedMsgId of
Just smId ->
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
Nothing -> do
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
@@ -1880,7 +1880,8 @@ processChatCommand vr nm = \case
groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs preferences
groupProfile = businessGroupProfile profile groupPreferences
gVar <- asks random
(gInfo, hostMember) <- withStore $ \db -> createPreparedGroup db gVar vr user groupProfile True ccLink welcomeSharedMsgId False
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar vr user groupProfile True ccLink welcomeSharedMsgId False
hostMember <- maybe (throwCmdError "no host member") pure hostMember_
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
let cd = CDGroupRcv gInfo Nothing hostMember
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing
@@ -1909,13 +1910,9 @@ processChatCommand vr nm = \case
welcomeSharedMsgId <- forM description $ \_ -> getSharedMsgId
let useRelays = not direct
gVar <- asks random
(gInfo, hostMember) <- withStore $ \db -> createPreparedGroup db gVar vr user gp False ccLink welcomeSharedMsgId useRelays
(gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar vr user gp False ccLink welcomeSharedMsgId useRelays
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
-- TODO [relays] member: TBC save items as message from channel
-- TODO - hostMember to later be associated with owner profile when relays send it
-- TODO - pick any owner at random from initial introductions, find unknown member in group?
-- TODO - alternatively support not having a member in CDGroupRcv direction?
let cd = CDGroupRcv gInfo Nothing hostMember
let cd = maybe (CDChannelRcv gInfo Nothing) (CDGroupRcv gInfo Nothing) hostMember_
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing
@@ -1933,11 +1930,17 @@ processChatCommand vr nm = \case
lift $ createContactChangedFeatureItems user ct ct'
pure $ CRContactUserChanged user ct newUser ct'
APIChangePreparedGroupUser groupId newUserId -> withUser $ \user -> do
(gInfo, hostMember) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user groupId <*> getHostMember db vr user groupId
gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId
when (isNothing $ preparedGroup gInfo) $ throwCmdError "group doesn't have link to connect"
when (isJust $ memberConn hostMember) $ throwCmdError "host member already has connection"
hostMember_ <-
if useRelays' gInfo
then pure Nothing
else do
hostMember <- withFastStore $ \db -> getHostMember db vr user groupId
when (isJust $ memberConn hostMember) $ throwCmdError "host member already has connection"
pure $ Just hostMember
newUser <- privateGetUser newUserId
gInfo' <- withFastStore $ \db -> updatePreparedGroupUser db vr user gInfo hostMember newUser
gInfo' <- withFastStore $ \db -> updatePreparedGroupUser db vr user gInfo hostMember_ newUser
pure $ CRGroupUserChanged user gInfo newUser gInfo'
APIConnectPreparedContact contactId incognito msgContent_ -> withUser $ \user -> do
ct@Contact {preparedContact} <- withFastStore $ \db -> getContact db vr user contactId
@@ -1985,7 +1988,7 @@ processChatCommand vr nm = \case
pure $ CRStartedConnectionToContact user ct' customUserProfile
CVRConnectedContact ct' -> pure $ CRContactAlreadyExists user ct'
APIConnectPreparedGroup groupId incognito msgContent_ -> withUser $ \user -> do
(gInfo, hostMember) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user groupId <*> getHostMember db vr user groupId
gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId
case gInfo of
GroupInfo {preparedGroup = Nothing} -> throwCmdError "group doesn't have link to connect"
GroupInfo {useRelays = BoolDef True, preparedGroup = Just PreparedGroup {connLinkToConnect}} -> do
@@ -2050,6 +2053,7 @@ processChatCommand vr nm = \case
newConnIds <- getAgentConnShortLinkAsync user relayLink
withStore' $ \db -> createRelayMemberConnectionAsync db user gInfo' relayMember relayLink newConnIds subMode
GroupInfo {preparedGroup = Just PreparedGroup {connLinkToConnect, welcomeSharedMsgId, requestSharedMsgId}} -> do
hostMember <- withFastStore $ \db -> getHostMember db vr user groupId
msg_ <- forM msgContent_ $ \mc -> case requestSharedMsgId of
Just smId -> pure (smId, mc)
Nothing -> do
@@ -2184,17 +2188,20 @@ processChatCommand vr nm = \case
contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName
forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg
toChatRef <- getChatRef user toChatName
processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId Nothing) (forwardedItemId :| []) Nothing
asGroup <- getSendAsGroup user toChatRef
processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTDirect contactId Nothing) (forwardedItemId :| []) Nothing
ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do
groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName
forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg
toChatRef <- getChatRef user toChatName
processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId Nothing) (forwardedItemId :| []) Nothing
asGroup <- getSendAsGroup user toChatRef
processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTGroup groupId Nothing) (forwardedItemId :| []) Nothing
ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do
folderId <- withFastStore (`getUserNoteFolderId` user)
forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg
toChatRef <- getChatRef user toChatName
processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing
asGroup <- getSendAsGroup user toChatRef
processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing
SendMessage sendName msg -> withUser $ \user -> do
let mc = MCText msg
case sendName of
@@ -2214,13 +2221,14 @@ processChatCommand vr nm = \case
_ ->
throwChatError $ CEContactNotFound name Nothing
SNGroup name scope_ -> do
(gId, cScope_, mentions) <- withFastStore $ \db -> do
gId <- getGroupIdByName db user name
(gInfo, cScope_, mentions) <- withFastStore $ \db -> do
gInfo <- getGroupInfoByName db vr user name
let gId = groupId' gInfo
cScope_ <-
forM scope_ $ \(GSNMemberSupport mName_) ->
GCSMemberSupport <$> mapM (getGroupMemberIdByName db user gId) mName_
(gId,cScope_,) <$> liftIO (getMessageMentions db user gId msg)
let sendRef = SRGroup gId cScope_
(gInfo, cScope_,) <$> liftIO (getMessageMentions db user gId msg)
let sendRef = SRGroup (groupId' gInfo) cScope_ (sendAsGroup' gInfo)
processChatCommand vr nm $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
SNLocal -> do
folderId <- withFastStore (`getUserNoteFolderId` user)
@@ -2247,7 +2255,7 @@ processChatCommand vr nm = \case
processChatCommand vr nm $ APIAcceptMemberContact contactId
SendLiveMessage chatName msg -> withUser $ \user -> do
(chatRef, mentions) <- getChatRefAndMentions user chatName msg
withSendRef chatRef $ \sendRef -> do
withSendRef user chatRef $ \sendRef -> do
let mc = MCText msg
processChatCommand vr nm $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
SendMessageBroadcast mc -> withUser $ \user -> do
@@ -2289,7 +2297,7 @@ processChatCommand vr nm = \case
combineResults _ _ (Left e) = Left e
createCI :: DB.Connection -> User -> Bool -> UTCTime -> (Contact, SndMessage) -> IO ()
createCI db user hasLink createdAt (ct, sndMsg) =
void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False hasLink createdAt
void $ createNewSndChatItem db user (CDDirectSnd ct) False sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False hasLink createdAt
SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do
contactId <- withFastStore $ \db -> getContactIdByName db user cName
quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
@@ -2497,7 +2505,7 @@ processChatCommand vr nm = \case
pure $ CRMemberSupportChatDeleted user gInfo' m'
APIMembersRole groupId memberIds newRole -> withUser $ \user ->
withGroupLock "memberRole" groupId $ do
-- TODO [channels fwd] possible optimization is to read only required members + relays
-- TODO [relays] possible optimization is to read only required members + relays
g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId
when (selfSelected gInfo) $ throwCmdError "can't change role for self"
let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members
@@ -2550,7 +2558,7 @@ processChatCommand vr nm = \case
recipients = filter memberCurrent members
(msgs_, _gsr) <- sendGroupMessages user gInfo Nothing recipients events
let itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) itemsData Nothing False
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch"
(errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
@@ -2566,10 +2574,10 @@ processChatCommand vr nm = \case
pure (m :: GroupMember) {memberRole = newRole}
APIBlockMembersForAll groupId memberIds blockFlag -> withUser $ \user ->
withGroupLock "blockForAll" groupId $ do
-- TODO [channels fwd] possible optimization is to read only required members + relays
-- TODO [relays] possible optimization is to read only required members + relays
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
when (selfSelected gInfo) $ throwCmdError "can't block/unblock self"
-- TODO [channels fwd] consider sending restriction to all members (remove filtering), as we do in delivery jobs
-- TODO [relays] consider sending restriction to all members (remove filtering), as we do in delivery jobs
let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members
when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound
when (length memberIds > 1 && anyAdmin) $ throwCmdError "can't block/unblock multiple members when admins selected"
@@ -2597,7 +2605,7 @@ processChatCommand vr nm = \case
recipients = filter memberCurrent remainingMems
(msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients events
let itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) itemsData Nothing False
cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False
when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch"
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_
unless (null acis) $ toView $ CEvtNewChatItems user acis
@@ -2614,7 +2622,7 @@ processChatCommand vr nm = \case
in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing
APIRemoveMembers {groupId, groupMemberIds, withMessages} -> withUser $ \user ->
withGroupLock "removeMembers" groupId $ do
-- TODO [channels fwd] possible optimization is to read only required members + relays
-- TODO [relays] possible optimization is to read only required members + relays
Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId
let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin) = selectMembers gmIds members
gmIds = S.fromList $ L.toList groupMemberIds
@@ -2681,7 +2689,7 @@ processChatCommand vr nm = \case
Right (Just a) -> Just $ Right a
Left e -> Just $ Left e
itemsData = mapMaybe skipUnwantedItem itemsData_
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) itemsData Nothing False
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) False itemsData Nothing False
deleteMembersConnections' user memsToDelete True
(errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete)
let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo chatScopeInfo)) $ rights cis_
@@ -2913,13 +2921,14 @@ processChatCommand vr nm = \case
groupId <- withFastStore $ \db -> getGroupIdByName db user gName
processChatCommand vr nm $ APIGetGroupLink groupId
SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do
(groupId, quotedItemId, mentions) <-
(gInfo, quotedItemId, mentions) <-
withFastStore $ \db -> do
gId <- getGroupIdByName db user gName
gInfo <- getGroupInfoByName db vr user gName
let gId = groupId' gInfo
qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
(gId, qiId,) <$> liftIO (getMessageMentions db user gId msg)
(gInfo, qiId,) <$> liftIO (getMessageMentions db user gId msg)
let mc = MCText msg
processChatCommand vr nm $ APISendMessages (SRGroup groupId Nothing) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
processChatCommand vr nm $ APISendMessages (SRGroup (groupId' gInfo) Nothing (sendAsGroup' gInfo)) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
ClearNoteFolder -> withUser $ \user -> do
folderId <- withFastStore (`getUserNoteFolderId` user)
processChatCommand vr nm $ APIClearChat (ChatRef CTLocal folderId Nothing)
@@ -2960,10 +2969,10 @@ processChatCommand vr nm = \case
chatRef <- getChatRef user chatName
case chatRef of
ChatRef CTLocal folderId _ -> processChatCommand vr nm $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
_ -> withSendRef chatRef $ \sendRef -> processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")]
_ -> withSendRef user chatRef $ \sendRef -> processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")]
SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
chatRef <- getChatRef user chatName
withSendRef chatRef $ \sendRef -> do
withSendRef user chatRef $ \sendRef -> do
filePath <- lift $ toFSFilePath fPath
unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath}
fileSize <- getFileSize filePath
@@ -3194,6 +3203,9 @@ processChatCommand vr nm = \case
| otherwise -> throwCmdError "not supported"
_ -> throwCmdError "not supported"
pure $ ChatRef cType chatId Nothing
getSendAsGroup :: User -> ChatRef -> CM ShowGroupAsSender
getSendAsGroup user' (ChatRef CTGroup chatId _) = sendAsGroup' <$> withFastStore (\db -> getGroupInfo db vr user' chatId)
getSendAsGroup _ _ = pure False
getChatRefAndMentions :: User -> ChatName -> Text -> CM (ChatRef, Map MemberName GroupMemberId)
getChatRefAndMentions user cName msg = do
chatRef@(ChatRef cType chatId _) <- getChatRef user cName
@@ -3539,7 +3551,7 @@ processChatCommand vr nm = \case
assertDeletable gInfo items
assertUserGroupRole gInfo GRModerator
let msgMemIds = itemsMsgMemIds gInfo items
events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId) $ toMsgScope gInfo <$> chatScopeInfo) msgMemIds
events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId memId $ toMsgScope gInfo <$> chatScopeInfo) msgMemIds
mapM_ (sendGroupMessages_ user gInfo ms) events
delGroupChatItems user gInfo chatScopeInfo items True
where
@@ -3552,14 +3564,16 @@ processChatCommand vr nm = \case
case chatDir of
CIGroupRcv GroupMember {memberRole} -> memberRole' membership >= memberRole && isJust itemSharedMsgId
CIGroupSnd -> isJust itemSharedMsgId
itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, MemberId)]
CIChannelRcv -> memberRole' membership == GROwner && isJust itemSharedMsgId
itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, Maybe MemberId)]
itemsMsgMemIds GroupInfo {membership = GroupMember {memberId = membershipMemId}} = mapMaybe itemMsgMemIds
where
itemMsgMemIds :: CChatItem 'CTGroup -> Maybe (SharedMsgId, MemberId)
itemMsgMemIds :: CChatItem 'CTGroup -> Maybe (SharedMsgId, Maybe MemberId)
itemMsgMemIds (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) =
join <$> forM itemSharedMsgId $ \msgId -> Just $ case chatDir of
CIGroupRcv GroupMember {memberId} -> (msgId, memberId)
CIGroupSnd -> (msgId, membershipMemId)
CIGroupRcv GroupMember {memberId} -> (msgId, Just memberId)
CIGroupSnd -> (msgId, Just membershipMemId)
CIChannelRcv -> (msgId, Nothing)
delGroupChatItems :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Bool -> CM [ChatItemDeletion]
delGroupChatItems user gInfo@GroupInfo {membership} chatScopeInfo items moderation = do
@@ -3977,7 +3991,7 @@ processChatCommand vr nm = \case
msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_
when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch"
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live
r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) False itemsData timed_ live
processSendErrs r
forM_ (timed_ >>= timedDeleteAt') $ \deleteAt ->
forM_ cis $ \ci ->
@@ -3996,8 +4010,8 @@ processChatCommand vr nm = \case
prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, _), fInv_) -> do
case (quotedItemId, itemForwarded) of
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Nothing)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Nothing)
(Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing)
(Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing)
(Just qiId, Nothing) -> do
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
getDirectChatItem db user contactId qiId
@@ -4005,7 +4019,7 @@ processChatCommand vr nm = \case
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
qmc = quoteContent mc origQmc file
quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Just quotedItem)
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Just quotedItem)
(Just _, Just _) -> throwError SEInvalidQuote
where
quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool)
@@ -4013,17 +4027,17 @@ processChatCommand vr nm = \case
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwError SEInvalidQuote
sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupChatScope -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages user gInfo scope live itemTTL cmrs = do
sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages user gInfo scope showGroupAsSender live itemTTL cmrs = do
assertMultiSendable live cmrs
chatScopeInfo <- mapM (getChatScopeInfo vr user) scope
recipients <- getGroupRecipients vr user gInfo chatScopeInfo modsCompatVersion
sendGroupContentMessages_ user gInfo scope chatScopeInfo recipients live itemTTL cmrs
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs
where
hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs
modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope chatScopeInfo recipients live itemTTL cmrs = do
sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs = do
forM_ allowedRole $ assertUserGroupRole gInfo
assertGroupContentAllowed
processComposedMessages
@@ -4048,13 +4062,13 @@ processChatCommand vr nm = \case
Nothing
processComposedMessages :: CM ChatResponse
processComposedMessages = do
-- TODO [channels fwd] single description for all recipients
-- TODO [relays] single description for all recipients
(fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length recipients)
timed_ <- sndGroupCITimed live gInfo itemTTL
(chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_
(msgs_, gsr) <- sendGroupMessages user gInfo Nothing recipients chatMsgEvents
let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_)
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) itemsData timed_ live
cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData timed_ live
when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch"
createMemberSndStatuses cis_ msgs_ gsr
let r@(_, cis) = partitionEithers cis_
@@ -4077,7 +4091,7 @@ processChatCommand vr nm = \case
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, ciMentions), fInv_) ->
let msgScope = toMsgScope gInfo <$> chatScopeInfo
mentions = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions
in prepareGroupMsg db user gInfo msgScope mc mentions quotedItemId itemForwarded fInv_ timed_ live
in prepareGroupMsg db user gInfo msgScope showGroupAsSender mc mentions quotedItemId itemForwarded fInv_ timed_ live
createMemberSndStatuses ::
[Either ChatError (ChatItem 'CTGroup 'MDSnd)] ->
NonEmpty (Either ChatError SndMessage) ->
@@ -4226,10 +4240,12 @@ processChatCommand vr nm = \case
getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do
msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId)
CRQueueInfo user msgInfo <$> withAgent (\a -> getConnectionQueueInfo a nm acId)
withSendRef :: ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse
withSendRef chatRef a = case chatRef of
withSendRef :: User -> ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse
withSendRef user chatRef a = case chatRef of
ChatRef CTDirect cId _ -> a $ SRDirect cId
ChatRef CTGroup gId scope -> a $ SRGroup gId scope
ChatRef CTGroup gId scope -> do
gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId
a $ SRGroup gId scope (sendAsGroup' gInfo)
_ -> throwCmdError "not supported"
getSharedMsgId :: CM SharedMsgId
getSharedMsgId = do
@@ -4620,7 +4636,7 @@ chatCommandP =
"/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> (knownReaction <$?> jsonP)),
"/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* " #" <*> A.decimal <* A.space <*> A.decimal <* A.space <*> (knownReaction <$?> jsonP)),
"/_forward plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP),
"/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP),
"/_forward " *> (APIForwardChatItems <$> chatRefP <*> (" as_group=" *> onOffP <|> pure False) <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP),
"/_read user " *> (APIUserRead <$> A.decimal),
"/read user" $> UserRead,
"/_read chat " *> (APIChatRead <$> chatRefP),
@@ -5047,7 +5063,8 @@ chatCommandP =
cType -> (\chatId -> ChatRef cType chatId Nothing) <$> A.decimal
sendRefP =
(A.char '@' $> SRDirect <*> A.decimal)
<|> (A.char '#' $> SRGroup <*> A.decimal <*> optional gcScopeP)
<|> (A.char '#' $> SRGroup <*> A.decimal <*> optional gcScopeP <*> asGroupP)
asGroupP = ("(as_group=" *> onOffP <* A.char ')') <|> pure False
gcScopeP = "(_support" *> (GCSMemberSupport <$> optional (A.char ':' *> A.decimal)) <* A.char ')'
sendNameP =
(A.char '@' $> SNDirect <*> displayNameP)
src/Simplex/Chat/Library/Internal.hs
+65 -50
View File
@@ -200,30 +200,33 @@ toggleNtf m ntfOn =
forM_ (memberConnId m) $ \connId ->
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchAllErrors` eToView
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
prepareGroupMsg db user g@GroupInfo {membership} msgScope mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> ShowGroupAsSender -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
prepareGroupMsg db user g@GroupInfo {membership} msgScope showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of
(Nothing, Nothing) ->
let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope
let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender)
in pure (XMsgNew mc', Nothing)
(Nothing, Just _) ->
let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope
let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender)
in pure (XMsgNew mc', Nothing)
(Just quotedItemId, Nothing) -> do
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <-
getGroupCIWithReactions db user g quotedItemId
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
(origQmc, qd, sent, member_) <- quoteData qci membership
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = memberId' <$> member_}
qmc = quoteContent mc origQmc file
(qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'}
mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope)
mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender))
pure (XMsgNew mc', Just quotedItem)
(Just _, Just _) -> throwError SEInvalidQuote
where
quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, Maybe GroupMember)
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote
quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership')
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc, meta = CIMeta {showGroupAsSender = sentAsGroup}} membership'
| sentAsGroup = pure (qmc, CIQGroupSnd, True, Nothing)
| otherwise = pure (qmc, CIQGroupSnd, True, Just membership')
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, Just m)
quoteData ChatItem {chatDir = CIChannelRcv, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv Nothing, False, Nothing)
quoteData _ _ = throwError SEInvalidQuote
updatedMentionNames :: MsgContent -> Maybe MarkdownList -> Map MemberName CIMention -> (MsgContent, Maybe MarkdownList, Map MemberName CIMention)
@@ -1190,13 +1193,15 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn
| otherwise = Nothing
itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json]
itemForwardEvents cci = case cci of
(CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file})
| not (blockedByAdmin sender) -> do
(CChatItem SMDRcv ci@ChatItem {content = CIRcvMsgContent mc, file})
| not (maybe False blockedByAdmin sender_) -> do
fInvDescr_ <- join <$> forM file getRcvFileInvDescr
processContentItem sender ci mc fInvDescr_
processContentItem sender_ ci mc fInvDescr_
| otherwise -> pure []
where sender_ = chatItemRcvFromMember ci
(CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do
fInvDescr_ <- join <$> forM file getSndFileInvDescr
processContentItem membership ci mc fInvDescr_
processContentItem (Just membership) ci mc fInvDescr_
_ -> pure []
where
getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText))
@@ -1229,8 +1234,8 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn
fInv = xftpFileInvitation fileName fileSize fInvDescr
in Just (fInv, fileDescrText)
| otherwise = Nothing
processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json]
processContentItem sender ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ =
processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json]
processContentItem sender_ ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ =
if isNothing fInvDescr_ && not (msgContentHasText mc)
then pure []
else do
@@ -1239,9 +1244,11 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn
fInv_ = fst <$> fInvDescr_
(mc', _, mentions') = updatedMentionNames mc formattedText mentions
mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions'
asGroup = isNothing sender_
-- TODO [knocking] send history to other scopes too?
(chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False
let senderVRange = memberChatVRange' sender
(chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing asGroup mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False
-- for channel messages default chat version range to membership range
let senderVRange = maybe (memberChatVRange' membership) memberChatVRange' sender_
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent}
fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of
(Just fileDescrText, Just msgId) -> do
@@ -1250,9 +1257,9 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn
pure . L.toList $ L.map (XMsgFileDescr msgId) parts
_ -> pure []
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
GroupMember {memberId} = sender
memberName = Just $ memberShortenedName sender
msgForwardEvents = map (\cm -> XGrpMsgForward memberId memberName cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs)
memberId_ = memberId' <$> sender_
memberName_ = memberShortenedName <$> sender_
msgForwardEvents = map (\cm -> XGrpMsgForward memberId_ memberName_ cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs)
pure msgForwardEvents
memberShortenedName :: GroupMember -> ContactName
@@ -2105,7 +2112,7 @@ memberSendAction gInfo@GroupInfo {membership} events members m@GroupMember {memb
| isRelay membership && not (isRelay m) -> MSASendBatched . snd <$> readyMemberConn m
-- if user is not chat relay, send only to chat relays
| not (isRelay membership) && isRelay m -> MSASendBatched . snd <$> readyMemberConn m
| otherwise -> Nothing -- TODO [channels fwd] MSAForwarded to create GSSForwarded snd statuses?
| otherwise -> Nothing -- TODO [relays] MSAForwarded to create GSSForwarded snd statuses?
| otherwise = case memberConn m of
Nothing -> pendingOrForwarded
Just conn@Connection {connStatus}
@@ -2204,12 +2211,12 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta
_ -> throwError e
pure (am', conn', msg)
saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage)
saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} brokerTs = do
saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> Maybe GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage)
saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMember_ msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} brokerTs = do
let newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs}
fwdMemberId = Just $ groupMemberId' forwardingMember
refAuthorId = Just $ groupMemberId' refAuthorMember
-- TODO [channels fwd] TBC highlighting difference between deduplicated messages (useRelays branch)
refAuthorId = groupMemberId' <$> refAuthorMember_
-- TODO [relays] TBC highlighting difference between deduplicated messages (useRelays branch)
withStore' (\db -> runExceptT $ createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) >>= \case
Right msg -> pure $ Just msg
Left e@SEDuplicateGroupMessage {authorGroupMemberId, forwardedByGroupMemberId}
@@ -2218,7 +2225,7 @@ saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMemb
(Just authorGMId, Nothing) -> do
vr <- chatVersionRange
am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGMId
if sameMemberId refMemberId am
if maybe False (\ref -> sameMemberId (memberId' ref) am) refAuthorMember_
then forM_ (memberConn forwardingMember) $ \fmConn ->
void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId
else toView $ CEvtMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id"
@@ -2233,7 +2240,7 @@ saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothi
saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd)
saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = do
let itemTexts = ciContentTexts content
saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
saveSndChatItems user cd False [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case
[Right ci] -> pure ci
_ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item"
@@ -2252,11 +2259,12 @@ saveSndChatItems ::
ChatTypeI c =>
User ->
ChatDirection c 'MDSnd ->
ShowGroupAsSender ->
[Either ChatError (NewSndChatItemData c)] ->
Maybe CITimed ->
Bool ->
CM [Either ChatError (ChatItem c 'MDSnd)]
saveSndChatItems user cd itemsData itemTimed live = do
saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
createdAt <- liftIO getCurrentTime
vr <- chatVersionRange
when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $
@@ -2266,9 +2274,9 @@ saveSndChatItems user cd itemsData itemTimed live = do
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do
let hasLink_ = ciContentHasLink content (snd itemTexts)
ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt
ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
let ci = mkChatItem_ cd False ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing createdAt
let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing createdAt
Right <$> case cd of
CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions
_ -> pure ci
@@ -2288,33 +2296,38 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} shared
createdAt <- liftIO getCurrentTime
vr <- chatVersionRange
withStore' $ \db -> do
(mentions' :: Map MemberName CIMention, userMention) <- case cd of
CDGroupRcv g@GroupInfo {membership} _scope _m -> do
mentions' <- getRcvCIMentions db user g ft_ mentions
let userReply = case cmToQuotedMsg chatMsgEvent of
Just QuotedMsg {msgRef = MsgRef {memberId = Just mId}} -> sameMemberId mId membership
_ -> False
userMention' = userReply || any (\CIMention {memberId} -> sameMemberId memberId membership) mentions'
in pure (mentions', userMention')
CDDirectRcv _ -> pure (M.empty, False)
(mentions' :: Map MemberName CIMention, userMention) <- case toChatInfo cd of
GroupChat g@GroupInfo {membership} _ -> groupMentions db g membership
_ -> pure (M.empty, False)
cInfo' <-
if (ciRequiresAttention content || contactChatDeleted cd)
then updateChatTsStats db vr user cd createdAt (memberChatStats userMention)
else pure $ toChatInfo cd
let hasLink_ = ciContentHasLink content ft_
let showAsGroup = case cd of CDChannelRcv {} -> True; _ -> False
hasLink_ = ciContentHasLink content ft_
(ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention hasLink_ brokerTs createdAt
forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt
let ci = mkChatItem_ cd False ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember createdAt
ci' <- case cd of
CDGroupRcv g _scope _m | not (null mentions') -> createGroupCIMentions db g ci mentions'
let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember createdAt
ci' <- case toChatInfo cd of
GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions'
_ -> pure ci
pure (ci', cInfo')
where
groupMentions db g membership = do
mentions' <- getRcvCIMentions db user g ft_ mentions
let userReply = case cmToQuotedMsg chatMsgEvent of
Just QuotedMsg {msgRef = MsgRef {memberId = Just mId}} -> sameMemberId mId membership
_ -> False
userMention' = userReply || any (\CIMention {memberId} -> sameMemberId memberId membership) mentions'
in pure (mentions', userMention')
memberChatStats :: Bool -> Maybe (Int, MemberAttention, Int)
memberChatStats userMention = case cd of
CDGroupRcv _g (Just scope) m -> do
CDGroupRcv _g (Just scope) m ->
let unread = fromEnum $ ciCreateStatus content == CISRcvNew
in Just (unread, memberAttentionChange unread (Just brokerTs) m scope, fromEnum userMention)
in Just (unread, memberAttentionChange unread (Just brokerTs) (Just m) scope, fromEnum userMention)
CDChannelRcv _g (Just scope) ->
let unread = fromEnum $ ciCreateStatus content == CISRcvNew
in Just (unread, memberAttentionChange unread (Just brokerTs) Nothing scope, fromEnum userMention)
_ -> Nothing
-- TODO [mentions] optimize by avoiding unnecessary parsing
@@ -2594,7 +2607,7 @@ createChatItems user itemTs_ dirsCIContents = do
memberChatStats = case cd of
CDGroupRcv _g (Just scope) m -> do
let unread = length $ filter (ciRequiresAttention . fst) contents
in Just (unread, memberAttentionChange unread itemTs_ m scope, 0)
in Just (unread, memberAttentionChange unread itemTs_ (Just m) scope, 0)
_ -> Nothing
createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> [IO AChatItem]
createACIs db itemTs createdAt (cd, showGroupAsSender, contents) = map createACI contents
@@ -2605,10 +2618,12 @@ createChatItems user itemTs_ dirsCIContents = do
let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt
pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
memberAttentionChange :: Int -> (Maybe UTCTime) -> GroupMember -> GroupChatScopeInfo -> MemberAttention
memberAttentionChange unread brokerTs_ rcvMem = \case
-- rcvMem_ Nothing means message from channel - treated same as message from moderator,
-- e.g. it can reset unanswered counter if newer than last unanswered message.
memberAttentionChange :: Int -> (Maybe UTCTime) -> Maybe GroupMember -> GroupChatScopeInfo -> MemberAttention
memberAttentionChange unread brokerTs_ rcvMem_ = \case
GCSIMemberSupport (Just suppMem)
| groupMemberId' suppMem == groupMemberId' rcvMem -> MAInc unread brokerTs_
| maybe False ((groupMemberId' suppMem ==) . groupMemberId') rcvMem_ -> MAInc unread brokerTs_
| msgIsNewerThanLastUnanswered -> MAReset
| otherwise -> MAInc 0 Nothing
where
src/Simplex/Chat/Library/Subscriber.hs
+302 -204
View File
@@ -210,7 +210,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
Nothing -> eToView $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result"
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
(_, _, SMDSnd, GroupChat g@GroupInfo {groupId} _scope) -> do
-- TODO [channels fwd] single description for all recipients
-- TODO [relays] single description for all recipients
ms <- getRecipients
let rfdsMemberFTs = zipWith (\rfd (conn, sft) -> (conn, sft, fileDescrText rfd)) rfds (memberFTs ms)
extraRFDs = drop (length rfdsMemberFTs) rfds
@@ -480,7 +480,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgDel sharedMsgId _ _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
-- TODO discontinue XFile
@@ -667,7 +667,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
where
sendAutoReply ct mc = \case
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing
void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
_ -> do
(msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
@@ -932,48 +932,58 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
logInfo $ "group msg=" <> tshow tag <> " " <> eInfo
let body = chatMsgToBody chatMsg
(m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg
let ctx js = DeliveryTaskContext js False
checkSendAsGroup :: Maybe Bool -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext)
checkSendAsGroup asGroup_ a
| asGroup_ == Just True && memberRole' m'' < GROwner =
messageError "member is not allowed to send as group" $> Nothing
| otherwise = a
-- ! see isForwardedGroupMsg: processing functions should return DeliveryJobScope for same events
deliveryJobScope_ <- case event of
XMsgNew mc -> memberCanSend m'' scope $ newGroupContentMessage gInfo' m'' mc msg brokerTs False
deliveryTaskContext_ <- case event of
XMsgNew mc ->
checkSendAsGroup asGroup $
memberCanSend (Just m'') scope $ newGroupContentMessage gInfo' (Just m'') mc msg brokerTs False
where
ExtMsgContent {scope} = mcExtMsgContent mc
ExtMsgContent {scope, asGroup} = mcExtMsgContent mc
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' msgScope $ groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live
XMsgDel sharedMsgId memberId scope_ -> groupMessageDelete gInfo' m'' sharedMsgId memberId scope_ msg brokerTs
XMsgReact sharedMsgId (Just memberId) scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs
XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
checkSendAsGroup asGroup_ $
memberCanSend (Just m'') msgScope $
groupMessageUpdate gInfo' (Just m'') sharedMsgId mContent mentions msgScope msg brokerTs ttl live asGroup_
XMsgDel sharedMsgId memberId_ scope_ -> groupMessageDelete gInfo' (Just m'') sharedMsgId memberId_ scope_ msg brokerTs
XMsgReact sharedMsgId memberId scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs
-- TODO discontinue XFile
XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo' m'' sharedMsgId
XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId
XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName
XInfo p -> xInfoMember gInfo' m'' p brokerTs
XInfo p -> fmap ctx <$> xInfoMember gInfo' m'' p brokerTs
XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
XGrpMemNew memInfo msgScope -> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs
XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_
XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv
XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd gInfo' m'' memInfo introInv
XGrpMemRole memId memRole -> xGrpMemRole gInfo' m'' memId memRole msg brokerTs
XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs
XGrpMemRole memId memRole -> fmap ctx <$> xGrpMemRole gInfo' m'' memId memRole msg brokerTs
XGrpMemRestrict memId memRestrictions -> fmap ctx <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs
XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId
XGrpMemDel memId withMessages -> case encoding @e of
SJson -> xGrpMemDel gInfo' m'' memId withMessages chatMsg msg brokerTs False
SBinary -> pure Nothing -- impossible
XGrpLeave -> xGrpLeave gInfo' m'' msg brokerTs
XGrpDel -> Just (DJSGroup {jobSpec = DJRelayRemoved}) <$ xGrpDel gInfo' m'' msg brokerTs
XGrpInfo p' -> xGrpInfo gInfo' m'' p' msg brokerTs
XGrpPrefs ps' -> xGrpPrefs gInfo' m'' ps'
SJson -> fmap ctx <$> xGrpMemDel gInfo' m'' memId withMessages chatMsg msg brokerTs False
SBinary -> pure Nothing
XGrpLeave -> fmap ctx <$> xGrpLeave gInfo' m'' msg brokerTs
XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs
XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs
XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps'
-- TODO [knocking] why don't we forward these messages?
XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just m'') msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
XGrpMsgForward memberId memberName msg' msgTs -> Nothing <$ xGrpMsgForward gInfo' m'' memberId memberName msg' msgTs brokerTs
XInfoProbe probe -> Nothing <$ xInfoProbe (COMGroupMember m'') probe
XInfoProbeCheck probeHash -> Nothing <$ xInfoProbeCheck (COMGroupMember m'') probeHash
XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe
BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup gInfo' sharedMsgId chunk msgMeta
_ -> Nothing <$ messageError ("unsupported message: " <> tshow event)
forM deliveryJobScope_ $ \jobScope ->
-- TODO [channels fwd] XMsgNew to return messageFromChannel
pure $ NewMessageDeliveryTask {messageId = msgId, jobScope, messageFromChannel = False}
forM deliveryTaskContext_ $ \taskContext ->
pure $ NewMessageDeliveryTask {messageId = msgId, taskContext}
checkSendRcpt :: [AChatMessage] -> CM Bool
checkSendRcpt aMsgs = do
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
@@ -987,7 +997,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
hasDeliveryReceipt (toCMEventTag chatMsgEvent)
createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns
createDeliveryTasks gInfo'@GroupInfo {groupId = gId} m' newDeliveryTasks = do
let relayRemovedTask_ = find (\NewMessageDeliveryTask {jobScope} -> isRelayRemoved jobScope) newDeliveryTasks
let relayRemovedTask_ = find (\NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} -> isRelayRemoved jobScope) newDeliveryTasks
createdDeliveryTasks <- case relayRemovedTask_ of
Nothing -> do
withStore' $ \db ->
@@ -1007,7 +1017,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
where
uniqueWorkerScopes :: [NewMessageDeliveryTask] -> [DeliveryWorkerScope]
uniqueWorkerScopes createdDeliveryTasks =
let workerScopes = map (\NewMessageDeliveryTask {jobScope} -> toWorkerScope jobScope) createdDeliveryTasks
let workerScopes = map (\NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} -> toWorkerScope jobScope) createdDeliveryTasks
in foldr' addWorkerScope [] workerScopes
where
addWorkerScope workerScope acc
@@ -1128,7 +1138,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
_ -> pure Nothing
sendGroupAutoReply mc = \case
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing
void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
_ -> do
msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ MCSimple $ extMsgContent mc Nothing
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc)
@@ -1338,7 +1348,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
upsertBusinessRequestItem cd@(CDGroupRcv gInfo@GroupInfo {groupId} _ clientMember) = upsertRequestItem cd updateRequestItem markRequestItemDeleted
where
updateRequestItem (sharedMsgId, mc) =
withStore (\db -> getGroupChatItemBySharedMsgId db user gInfo (groupMemberId' clientMember) sharedMsgId) >>= \case
withStore (\db -> getGroupChatItemBySharedMsgId db user gInfo (Just $ groupMemberId' clientMember) sharedMsgId) >>= \case
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', content = CIRcvMsgContent oldMC}
| sameMemberId (memberId' clientMember) m' ->
if mc /= oldMC
@@ -1364,6 +1374,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
else markGroupCIsDeleted user gInfo Nothing [cci] Nothing currentTs
toView $ CEvtChatItemsDeleted user deletions False False
_ -> pure ()
upsertBusinessRequestItem (CDChannelRcv _ _) = const $ pure Nothing
createRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem
createRequestItem cd (sharedMsgId, mc) = do
aci <- createChatItem user cd False (CIRcvMsgContent mc) (Just sharedMsgId) Nothing
@@ -1417,12 +1428,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
Nothing ->
messageError "memberJoinRequestViaRelay: no group link info for relay link"
memberCanSend ::
GroupMember ->
Maybe MsgScope ->
CM (Maybe DeliveryJobScope) ->
CM (Maybe DeliveryJobScope)
memberCanSend m@GroupMember {memberRole} msgScope a = case msgScope of
memberCanSend :: Maybe GroupMember -> Maybe MsgScope -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext)
memberCanSend Nothing _ a = a -- channel message - was previously checked and allowed by relay
memberCanSend (Just m@GroupMember {memberRole}) msgScope a = case msgScope of
Just MSMember {} -> a
Nothing
| memberRole > GRObserver || memberPending m -> a
@@ -1618,7 +1626,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do
let ExtMsgContent content _ fInv_ _ _ _ = mcExtMsgContent mc
let ExtMsgContent content _ fInv_ _ _ _ _ = mcExtMsgContent mc
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
-- case content of
-- MCText "hello 111" ->
@@ -1629,7 +1637,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
then do
void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
else do
let ExtMsgContent _ _ _ itemTTL live_ _ = mcExtMsgContent mc
let ExtMsgContent _ _ _ itemTTL live_ _ _ = mcExtMsgContent mc
timed_ = rcvContactCITimed ct itemTTL
live = fromMaybe False live_
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
@@ -1656,22 +1664,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
pure (fileId, aci)
processFDMessage fileId aci fileDescr
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryJobScope)
groupMessageFileDescription g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId fileDescr = do
groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryTaskContext)
groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr = do
(fileId, aci) <- withStore $ \db -> do
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
aci <- getChatItemByFileId db vr user fileId
pure (fileId, aci)
case aci of
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir = CIGroupRcv m} ->
if sameMemberId memberId m
then do
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
| validSender m_ chatDir -> do
-- in processFDMessage some paths are programmed as errors,
-- for example failure on not approved relays (CEFileNotApproved).
-- we catch error, so that even if processFDMessage fails, message can still be forwarded.
processFDMessage fileId aci fileDescr `catchAllErrors` \_ -> pure ()
pure $ Just $ infoToDeliveryScope g scopeInfo
else messageError "x.msg.file.descr: file of another member" $> Nothing
pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir)
| otherwise -> messageError "x.msg.file.descr: file/sender mismatch" $> Nothing
_ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing
processFDMessage :: FileTransferId -> AChatItem -> FileDescr -> CM ()
@@ -1791,28 +1798,31 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
else pure Nothing
mapM_ toView cEvt_
groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
groupMsgReaction g m@GroupMember {memberRole} sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs
groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext)
groupMsgReaction g m sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs
| groupFeatureAllowed SGFReactions g = do
rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False
if reactionAllowed add reaction rs
then
updateChatItemReaction `catchCINotFound` \_ -> case scope_ of
Just (MSMember scopeMemberId)
| memberRole >= GRModerator || scopeMemberId == memberId' m ->
withStore $ \db -> do
| memberRole' m >= GRModerator || scopeMemberId == memberId' m -> do
djScope <- withStore $ \db -> do
liftIO $ setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs
Just . DJSMemberSupport <$> getScopeMemberIdViaMemberId db user g m scopeMemberId
pure $ fmap (\js -> DeliveryTaskContext js False) djScope
| otherwise -> pure Nothing
Nothing -> do
withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}
pure $ Just $ DeliveryTaskContext (DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}) False
else pure Nothing
| otherwise = pure Nothing
where
updateChatItemReaction = do
(CChatItem md ci, scopeInfo) <- withStore $ \db -> do
cci <- getGroupMemberCIBySharedMsgId db user g itemMemberId sharedMsgId
cci <- case itemMemberId of
Just itemMemberId' -> getGroupMemberCIBySharedMsgId db user g itemMemberId' sharedMsgId
Nothing -> getGroupChatItemBySharedMsgId db user g Nothing sharedMsgId
scopeInfo <- getGroupChatScopeInfoForItem db vr user g (cChatItemId cci)
pure (cci, scopeInfo)
if ciReactionAllowed ci
@@ -1823,7 +1833,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
let ci' = CChatItem md ci {reactions}
r = ACIReaction SCTGroup SMDRcv (GroupChat g scopeInfo) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction
toView $ CEvtChatItemReaction user add r
pure $ Just $ infoToDeliveryScope g scopeInfo
pure $ Just $ infoToDeliveryContext g scopeInfo False
else pure Nothing
reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool
@@ -1835,70 +1845,92 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId
e -> throwError e
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = do
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_
if blockedByAdmin m'
then createBlockedByAdmin gInfo' m' scopeInfo $> Nothing
else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
Just f -> rejected gInfo' m' scopeInfo f $> Nothing
Nothing ->
withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case
Just ciModeration -> do
applyModeration gInfo' m' scopeInfo ciModeration
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
pure Nothing
Nothing -> do
createContentItem gInfo' m' scopeInfo
pure $ Just $ infoToDeliveryScope gInfo scopeInfo
validSender :: Maybe GroupMember -> CIDirection 'CTGroup 'MDRcv -> Bool
validSender (Just m) (CIGroupRcv mem) = sameMemberId (memberId' m) mem
validSender m_ CIChannelRcv = maybe True (\m -> memberRole' m == GROwner) m_
validSender _ _ = False
isChannelDir :: CIDirection 'CTGroup 'MDRcv -> ShowGroupAsSender
isChannelDir CIChannelRcv = True
isChannelDir _ = False
newGroupContentMessage :: GroupInfo -> Maybe GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryTaskContext)
newGroupContentMessage gInfo m_ mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = case m_ of
Nothing -> do
createContentItem gInfo Nothing Nothing
-- no delivery task - message already forwarded by relay
pure Nothing
Just m@GroupMember {memberId} -> do
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_
if blockedByAdmin m'
then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing
else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing
Nothing ->
withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case
Just ciModeration -> do
applyModeration gInfo' m' scopeInfo ciModeration
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
pure Nothing
Nothing -> do
createContentItem gInfo' (Just m') scopeInfo
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup
where
rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
timed' gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL
timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL
live' = fromMaybe False live_
ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ = mcExtMsgContent mc
ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ asGroup_ = mcExtMsgContent mc
sentAsGroup = asGroup_ == Just True
ts@(_, ft_) = msgContentTexts content
saveRcvCI gInfo' m' scopeInfo = saveRcvChatItem' user (CDGroupRcv gInfo' scopeInfo m') msg sharedMsgId_ brokerTs
-- m' is Maybe GroupMember
saveRcvCI gInfo' m' scopeInfo =
let itemMember_ = if sentAsGroup then Nothing else m'
chatDir = maybe (CDChannelRcv gInfo' scopeInfo) (CDGroupRcv gInfo' scopeInfo) itemMember_
in saveRcvChatItem' user chatDir msg sharedMsgId_ brokerTs
createBlockedByAdmin gInfo' m' scopeInfo
| groupFeatureAllowed SGFFullDelete gInfo' = do
-- ignores member role when blocked by admin
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvBlocked) Nothing (timed' gInfo') False M.empty
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvBlocked) Nothing (timed_ gInfo') False M.empty
ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo' ci brokerTs
groupMsgToView cInfo ci'
| otherwise = do
file_ <- processFileInv m'
file_ <- processFileInv gInfo' m'
(ci, cInfo) <- createNonLive gInfo' m' scopeInfo file_
ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo' ci
groupMsgToView cInfo ci'
applyModeration gInfo' m' scopeInfo CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt}
applyModeration gInfo' m'@GroupMember {memberRole} scopeInfo CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt}
| moderatorRole < GRModerator || moderatorRole < memberRole =
createContentItem gInfo' m' scopeInfo
createContentItem gInfo' (Just m') scopeInfo
| groupFeatureMemberAllowed SGFFullDelete moderator gInfo' = do
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvModerated) Nothing (timed' gInfo') False M.empty
(ci, cInfo) <- saveRcvCI gInfo' (Just m') scopeInfo (ciContentNoParse CIRcvModerated) Nothing (timed_ gInfo') False M.empty
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo' ci moderator moderatedAt
groupMsgToView cInfo ci'
| otherwise = do
file_ <- processFileInv m'
(ci, _cInfo) <- createNonLive gInfo' m' scopeInfo file_
file_ <- processFileInv gInfo' (Just m')
(ci, _cInfo) <- createNonLive gInfo' (Just m') scopeInfo file_
deletions <- markGroupCIsDeleted user gInfo' scopeInfo [CChatItem SMDRcv ci] (Just moderator) moderatedAt
toView $ CEvtChatItemsDeleted user deletions False False
-- m' is Maybe GroupMember
createNonLive gInfo' m' scopeInfo file_ = do
saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed' gInfo') False mentions
saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions
createContentItem gInfo' m' scopeInfo = do
file_ <- processFileInv m'
newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed' gInfo') live'
unless (memberBlocked m') $ autoAcceptFile file_
processFileInv m' =
processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m'
newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed_ live = do
let mentions' = if memberBlocked m' then [] else mentions
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed_ live mentions'
ci' <- blockedMemberCI gInfo' m' ci
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId sharedMsgId) sharedMsgId_
file_ <- processFileInv gInfo' m'
newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live'
unless (maybe False memberBlocked m') $ autoAcceptFile file_
processFileInv gInfo' m' =
let fileMember_ = if sentAsGroup then Nothing else m'
in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_
newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do
let mentions' = if maybe False memberBlocked m' then [] else mentions
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions'
ci' <- maybe (pure ci) (\m -> blockedMemberCI gInfo' m ci) m'
let memberId_ = memberId' <$> m'
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId_ sharedMsgId) sharedMsgId_
groupMsgToView cInfo ci' {reactions}
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM (Maybe DeliveryJobScope)
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_
| prohibitedSimplexLinks gInfo m ft_ =
groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> CM (Maybe DeliveryTaskContext)
groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ asGroup_
| Just m <- m_, prohibitedSimplexLinks gInfo m ft_ =
messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing
| otherwise = do
updateRcvChatItem `catchCINotFound` \_ -> do
@@ -1906,103 +1938,158 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
mentions' = if memberBlocked m then [] else mentions
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_
(ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo' scopeInfo m') msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateGroupChatItem db user groupId ci content True live Nothing
ci'' <- blockedMemberCI gInfo' m' ci'
toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci'')
pure $ Just $ infoToDeliveryScope gInfo scopeInfo
showGroupAsSender = fromMaybe (isNothing m_) asGroup_
if showGroupAsSender && maybe False (\m -> memberRole' m < GROwner) m_
then messageError "x.msg.update: member attempted to update as group" $> Nothing
else do
(gInfo', chatDir, mentions', scopeInfo) <-
if showGroupAsSender
then pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing)
else case m_ of
Just m -> do
let mentions' = if memberBlocked m then [] else mentions
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_
pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo)
Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing)
(ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
ci' <- withStore' $ \db -> do
createChatItemVersion db (chatItemId' ci) brokerTs mc
updateGroupChatItem db user groupId ci content True live Nothing
ci'' <- case chatDir of
CDGroupRcv gi' _ m' -> blockedMemberCI gi' m' ci'
CDChannelRcv {} -> pure ci'
toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci'')
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo showGroupAsSender
where
content = CIRcvMsgContent mc
ts@(_, ft_) = msgContentTexts mc
live = fromMaybe False live_
updateRcvChatItem = do
(cci, scopeInfo) <- withStore $ \db -> do
cci <- getGroupChatItemBySharedMsgId db user gInfo groupMemberId sharedMsgId
cci <-
if asGroup_ == Just True
then getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId
else case m_ of
Just m -> getGroupMemberCIBySharedMsgId db user gInfo (memberId' m) sharedMsgId
Nothing -> getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId
(cci,) <$> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci)
case cci of
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} ->
if sameMemberId memberId m'
then do
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
ci' <- withStore' $ \db -> do
when changed $
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
let edited = itemLive /= Just True
ciMentions <- getRcvCIMentions db user gInfo ft_ mentions
ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId
updateGroupCIMentions db gInfo ci' ciMentions
toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci')
startUpdatedTimedItemThread user (ChatRef CTGroup groupId $ toChatScope <$> scopeInfo) ci ci'
pure $ Just $ infoToDeliveryScope gInfo scopeInfo
else do
toView $ CEvtChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci)
pure Nothing
else messageError "x.msg.update: group member attempted to update a message of another member" $> Nothing
_ -> messageError "x.msg.update: group member attempted invalid message update" $> Nothing
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
groupMessageDelete gInfo@GroupInfo {membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ scope_ RcvMessage {msgId} brokerTs = do
let msgMemberId = fromMaybe memberId sndMemberId_
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo msgMemberId sharedMsgId) >>= \case
Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of
CIGroupRcv mem -> case sndMemberId_ of
-- regular deletion
Nothing
| sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs ->
Just <$> delete cci Nothing
| otherwise ->
messageError "x.msg.del: member attempted invalid message delete" $> Nothing
-- moderation (not limited by time)
Just _
| sameMemberId memberId mem && msgMemberId == memberId ->
Just <$> delete cci (Just m)
| otherwise ->
moderate mem cci
CIGroupSnd -> moderate membership cci
Left e
| msgMemberId == memberId ->
messageError ("x.msg.del: message not found, " <> tshow e) $> Nothing
| senderRole < GRModerator -> do
messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC}
| isSender m' -> updateCI False ci scopeInfo oldMC itemLive (Just $ memberId' m')
| otherwise -> messageError "x.msg.update: group member attempted to update a message of another member" $> Nothing
CChatItem SMDRcv ci@ChatItem {chatDir = CIChannelRcv, meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC}
| maybe True (\m -> memberRole' m == GROwner) m_ -> updateCI True ci scopeInfo oldMC itemLive Nothing
| otherwise -> messageError "x.msg.update: member attempted to update channel message" $> Nothing
_ -> messageError "x.msg.update: invalid message update" $> Nothing
where
isSender m' = maybe False (\m -> sameMemberId (memberId' m) m') m_
updateCI :: ShowGroupAsSender -> ChatItem 'CTGroup 'MDRcv -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe Bool -> Maybe MemberId -> CM (Maybe DeliveryTaskContext)
updateCI showGroupAsSender ci scopeInfo oldMC itemLive memberId = do
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
ci' <- withStore' $ \db -> do
when changed $
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
let edited = itemLive /= Just True
ciMentions <- getRcvCIMentions db user gInfo ft_ mentions
ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId
updateGroupCIMentions db gInfo ci' ciMentions
toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci')
startUpdatedTimedItemThread user (ChatRef CTGroup groupId $ toChatScope <$> scopeInfo) ci ci'
pure $ Just $ infoToDeliveryContext gInfo scopeInfo showGroupAsSender
else do
toView $ CEvtChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci)
pure Nothing
| otherwise -> case scope_ of
Just (MSMember scopeMemberId) ->
withStore $ \db -> do
liftIO $ createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
Just . DJSMemberSupport <$> getScopeMemberIdViaMemberId db user gInfo m scopeMemberId
Nothing -> do
withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}
groupMessageDelete :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext)
groupMessageDelete gInfo@GroupInfo {membership} m_ sharedMsgId sndMemberId_ scope_ rcvMsg brokerTs =
findItem >>= \case
Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case (chatDir, m_) of
(CIGroupRcv mem, Just m@GroupMember {memberId}) ->
let msgMemberId = fromMaybe memberId sndMemberId_
in case sndMemberId_ of
-- regular deletion
Nothing
| sameMemberId memberId mem && rcvItemDeletable ci brokerTs ->
delete cci False Nothing
| otherwise ->
messageError "x.msg.del: member attempted invalid message delete" $> Nothing
-- moderation (not limited by time)
Just _
| sameMemberId memberId mem && msgMemberId == memberId ->
delete cci False (Just m)
| otherwise -> moderate m mem cci
(CIChannelRcv, _)
| isNothing sndMemberId_ && isOwner -> delete cci True Nothing
| otherwise -> messageError "x.msg.del: invalid channel message delete" $> Nothing
(CIGroupSnd, Just m) -> moderate m membership cci
_ -> messageError "x.msg.del: invalid message deletion" $> Nothing
Left e -> case m_ of
Just m@GroupMember {memberId, memberRole = senderRole} -> do
let msgMemberId = fromMaybe memberId sndMemberId_
if
| msgMemberId == memberId ->
messageError ("x.msg.del: message not found, " <> tshow e) $> Nothing
| senderRole < GRModerator -> do
messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
pure Nothing
| otherwise -> case scope_ of
Just (MSMember scopeMemberId) ->
withStore $ \db -> do
liftIO $ createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
supportGMId <- getScopeMemberIdViaMemberId db user gInfo m scopeMemberId
pure $ Just $ DeliveryTaskContext {jobScope = DJSMemberSupport supportGMId, sentAsGroup = False}
Nothing -> do
withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
pure $ Just $ DeliveryTaskContext {jobScope = DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}, sentAsGroup = False}
Nothing ->
messageError ("x.msg.del: channel message not found, " <> tshow e) $> Nothing
where
moderate :: GroupMember -> CChatItem 'CTGroup -> CM (Maybe DeliveryJobScope)
moderate mem cci = case sndMemberId_ of
isOwner = maybe True (\m -> memberRole' m == GROwner) m_
RcvMessage {msgId} = rcvMsg
findItem = do
let tryMemberLookup mId =
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo mId sharedMsgId)
tryChannelLookup =
withStore' (\db -> runExceptT $ getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId)
case sndMemberId_ of
Just sId -> tryMemberLookup sId
Nothing -> case m_ of
Just GroupMember {memberId} ->
tryMemberLookup memberId >>= \case
Right cci -> pure (Right cci)
Left e ->
tryChannelLookup >>= \case
Right cci -> pure (Right cci)
Left _ -> pure (Left e)
Nothing -> tryChannelLookup
moderate :: GroupMember -> GroupMember -> CChatItem 'CTGroup -> CM (Maybe DeliveryTaskContext)
moderate sender mem cci = case sndMemberId_ of
Just sndMemberId
| sameMemberId sndMemberId mem -> checkRole mem $ do
jobScope <- delete cci (Just m)
archiveMessageReports cci m
pure $ Just jobScope
| sameMemberId sndMemberId mem -> checkRole (memberRole' sender) mem $ do
ctx_ <- delete cci False (Just sender)
archiveMessageReports cci sender
pure ctx_
| otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" $> Nothing
_ -> messageError "x.msg.del: message of another member without memberId" $> Nothing
checkRole GroupMember {memberRole} a
checkRole senderRole GroupMember {memberRole} a
| senderRole < GRModerator || senderRole < memberRole =
messageError "x.msg.del: message of another member with insufficient member permissions" $> Nothing
| otherwise = a
delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM DeliveryJobScope
delete cci byGroupMember = do
delete :: CChatItem 'CTGroup -> Bool -> Maybe GroupMember -> CM (Maybe DeliveryTaskContext)
delete cci asGroup byGroupMember = do
scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci)
let fullDelete
| asGroup = groupFeatureAllowed SGFFullDelete gInfo
| otherwise = maybe False (\m -> groupFeatureMemberAllowed SGFFullDelete m gInfo) m_
deletions <-
if groupFeatureMemberAllowed SGFFullDelete m gInfo
if fullDelete
then deleteGroupCIs user gInfo scopeInfo [cci] byGroupMember brokerTs
else markGroupCIsDeleted user gInfo scopeInfo [cci] byGroupMember brokerTs
toView $ CEvtChatItemsDeleted user deletions False False
pure $ infoToDeliveryScope gInfo scopeInfo
pure $ if isNothing m_ then Nothing else Just $ infoToDeliveryContext gInfo scopeInfo asGroup
archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM ()
archiveMessageReports (CChatItem _ ci) byMember = do
ciIds <- withStore' $ \db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs
@@ -2028,7 +2115,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} brokerTs = do
ChatConfig {fileChunkSize} <- asks config
inline <- receiveInlineMode fInv Nothing fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
@@ -2139,22 +2226,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
_ -> pure ()
receiveFileChunk ft Nothing meta chunk
xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM (Maybe DeliveryJobScope)
xFileCancelGroup g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId = do
xFileCancelGroup :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> CM (Maybe DeliveryTaskContext)
xFileCancelGroup g@GroupInfo {groupId} m_ sharedMsgId = do
(fileId, aci) <- withStore $ \db -> do
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
(fileId,) <$> getChatItemByFileId db vr user fileId
case aci of
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir = CIGroupRcv m} -> do
if sameMemberId memberId m
then do
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
| validSender m_ chatDir -> do
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft
toView $ CEvtRcvFileSndCancelled user aci ft
pure $ Just $ infoToDeliveryScope g scopeInfo
else -- shouldn't happen now that query includes group member id
messageError "x.file.cancel: group member attempted to cancel file of another member" $> Nothing
pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir)
| otherwise -> messageError "x.file.cancel: file cancel sender mismatch" $> Nothing
_ -> messageError "x.file.cancel: group member attempted invalid file cancel" $> Nothing
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
@@ -2840,7 +2925,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
if membershipMemId == memId
then checkRole membership $ do
deleteGroupLinkIfExists user gInfo
-- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
-- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved
let membership' = membership {memberStatus = GSMemRemoved}
@@ -2892,7 +2977,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
forwardToMember member = do
let GroupMember {memberId} = m
memberName = Just $ memberShortenedName m
event = XGrpMsgForward memberId memberName chatMsg brokerTs
event = XGrpMsgForward (Just memberId) memberName chatMsg brokerTs
sendGroupMemberMessage gInfo member event
isUserGrpFwdRelay :: GroupInfo -> Bool
@@ -2920,7 +3005,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do
when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted
-- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
-- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False
(gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo m
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEGroupDeleted)
@@ -3048,37 +3133,47 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
toViewTE $ TEContactVerificationReset user ct
createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> UTCTime -> CM ()
xGrpMsgForward gInfo m@GroupMember {localDisplayName} memberId memberName chatMsg msgTs brokerTs = do
xGrpMsgForward :: GroupInfo -> GroupMember -> Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> UTCTime -> CM ()
xGrpMsgForward gInfo m@GroupMember {localDisplayName} memberId_ memberName_ chatMsg msgTs brokerTs = do
unless (isMemberGrpFwdRelay gInfo m) $ throwChatError (CEGroupContactRole localDisplayName)
(author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName
when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author
processForwardedMsg author
case memberId_ of
Just memberId -> do
(author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName_
when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author
processForwardedMsg (Just author)
Nothing -> processForwardedMsg Nothing
where
-- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated
processForwardedMsg :: GroupMember -> CM ()
processForwardedMsg author = do
processForwardedMsg :: Maybe GroupMember -> CM ()
processForwardedMsg author_ = do
let body = chatMsgToBody chatMsg
rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author body chatMsg brokerTs
rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ body chatMsg brokerTs
forM_ rcvMsg_ $ \rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} -> case event of
XMsgNew mc -> void $ memberCanSend author scope $ (const Nothing) <$> newGroupContentMessage gInfo author mc rcvMsg msgTs True
XMsgNew mc ->
void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True
where
ExtMsgContent {scope} = mcExtMsgContent mc
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> void $ memberCanSend author msgScope $ (const Nothing) <$> groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live
XMsgDel sharedMsgId memId scope_ -> void $ groupMessageDelete gInfo author sharedMsgId memId scope_ rcvMsg msgTs
XMsgReact sharedMsgId (Just memId) scope_ reaction add -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author sharedMsgId
XInfo p -> void $ xInfoMember gInfo author p msgTs
XGrpMemNew memInfo msgScope -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs
XGrpMemRole memId memRole -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs
XGrpMemDel memId withMessages -> void $ xGrpMemDel gInfo author memId withMessages chatMsg rcvMsg msgTs True
XGrpLeave -> void $ xGrpLeave gInfo author rcvMsg msgTs
XGrpDel -> void $ xGrpDel gInfo author rcvMsg msgTs
XGrpInfo p' -> void $ xGrpInfo gInfo author p' rcvMsg msgTs
XGrpPrefs ps' -> void $ xGrpPrefs gInfo author ps'
XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_
XMsgDel sharedMsgId memId scope_ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ rcvMsg msgTs
XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
XInfo p -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p msgTs
XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs
XGrpMemRole memId memRole -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs
XGrpMemDel memId withMessages -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel gInfo author memId withMessages chatMsg rcvMsg msgTs True
XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave gInfo author rcvMsg msgTs
XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs
XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs
XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps'
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event)
where
withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM ()
withAuthor tag action = case author_ of
Just author -> action author
Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author"
directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
@@ -3194,7 +3289,7 @@ runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
delay <- asks $ deliveryWorkerDelay . config
vr <- chatVersionRange
-- TODO [channels fwd] in future may be required to read groupInfo and user on each iteration for up to date state
-- TODO [relays] in future may be required to read groupInfo and user on each iteration for up to date state
-- TODO - same for delivery jobs (runDeliveryJobWorker)
gInfo <- withStore $ \db -> do
user <- getUserByGroupId db groupId
@@ -3233,8 +3328,11 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
| workerScope /= DWSGroup ->
throwChatError $ CEInternalError "delivery task worker: relay removed task in wrong worker scope"
| otherwise -> do
let MessageDeliveryTask {senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage} = task
fwdEvt = XGrpMsgForward senderMemberId (Just senderMemberName) chatMessage brokerTs
let MessageDeliveryTask {senderGMId, fwdSender, brokerTs, chatMessage} = task
(memberId_, memberName_) = case fwdSender of
FwdMember mid mname -> (Just mid, Just mname)
FwdChannel -> (Nothing, Nothing)
fwdEvt = XGrpMsgForward memberId_ memberName_ chatMessage brokerTs
cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt}
body = chatMsgToBody cm
withStore' $ \db -> do