dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-10 23:47:11 +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/Controller.hs
+2 -7
View File
@@ -338,7 +338,7 @@ data ChatCommand
| APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction}
| APIGetReactionMembers {userId :: UserId, groupId :: GroupId, chatItemId :: ChatItemId, reaction :: MsgReaction}
| APIPlanForwardChatItems {fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId}
| APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int}
| APIForwardChatItems {toChatRef :: ChatRef, sendAsGroup :: ShowGroupAsSender, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int}
| APIUserRead UserId
| UserRead
| APIChatRead {chatRef :: ChatRef}
@@ -934,14 +934,9 @@ logEventToFile = \case
data SendRef
= SRDirect ContactId
| SRGroup GroupId (Maybe GroupChatScope)
| SRGroup GroupId (Maybe GroupChatScope) ShowGroupAsSender
deriving (Eq, Show)
sendToChatRef :: SendRef -> ChatRef
sendToChatRef = \case
SRDirect cId -> ChatRef CTDirect cId Nothing
SRGroup gId scope -> ChatRef CTGroup gId scope
data ChatPagination
= CPLast Int
| CPAfter ChatItemId Int
src/Simplex/Chat/Delivery.hs
+27 -13
View File
@@ -10,7 +10,7 @@ import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import Data.Time.Clock (UTCTime)
import Simplex.Chat.Messages (GroupChatScopeInfo (..), MessageId)
import Simplex.Chat.Messages (GroupChatScopeInfo (..), MessageId, ShowGroupAsSender)
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Chat.Protocol
import Simplex.Chat.Types
@@ -41,6 +41,16 @@ instance TextEncoding DeliveryWorkerScope where
DWSMemberSupport -> "member_support"
-- DWSMemberProfileUpdate -> "member_profile_update"
-- Context for creating a delivery task. Separate from DeliveryJobScope because
-- sentAsGroup is only needed for task persistence and batching into XGrpMsgForward events.
-- Once batched into jobs, sentAsGroup=True and sentAsGroup=False messages can be mixed,
-- so jobs don't need this flag.
data DeliveryTaskContext = DeliveryTaskContext
{ jobScope :: DeliveryJobScope,
sentAsGroup :: ShowGroupAsSender
}
deriving (Show)
data DeliveryJobScope
= DJSGroup {jobSpec :: DeliveryJobSpec}
| DJSMemberSupport {supportGMId :: GroupMemberId}
@@ -93,12 +103,14 @@ jobSpecImpliedPending = \case
DJDeliveryJob {includePending} -> includePending
DJRelayRemoved -> True
infoToDeliveryScope :: GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope
infoToDeliveryScope GroupInfo {membership} = \case
Nothing -> DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}
Just GCSIMemberSupport {groupMember_} ->
let supportGMId = groupMemberId' $ fromMaybe membership groupMember_
in DJSMemberSupport {supportGMId}
infoToDeliveryContext :: GroupInfo -> Maybe GroupChatScopeInfo -> ShowGroupAsSender -> DeliveryTaskContext
infoToDeliveryContext GroupInfo {membership} scopeInfo sentAsGroup = DeliveryTaskContext {jobScope, sentAsGroup}
where
jobScope = case scopeInfo of
Nothing -> DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}
Just GCSIMemberSupport {groupMember_} ->
let supportGMId = groupMemberId' $ fromMaybe membership groupMember_
in DJSMemberSupport {supportGMId}
memberEventDeliveryScope :: GroupMember -> Maybe DeliveryJobScope
memberEventDeliveryScope m@GroupMember {memberRole, memberStatus}
@@ -109,20 +121,22 @@ memberEventDeliveryScope m@GroupMember {memberRole, memberStatus}
data NewMessageDeliveryTask = NewMessageDeliveryTask
{ messageId :: MessageId,
jobScope :: DeliveryJobScope,
messageFromChannel :: MessageFromChannel
taskContext :: DeliveryTaskContext
}
deriving (Show)
data FwdSender
= FwdMember MemberId ContactName
| FwdChannel
deriving (Show)
data MessageDeliveryTask = MessageDeliveryTask
{ taskId :: Int64,
jobScope :: DeliveryJobScope,
senderGMId :: GroupMemberId,
senderMemberId :: MemberId,
senderMemberName :: ContactName,
fwdSender :: FwdSender,
brokerTs :: UTCTime,
chatMessage :: ChatMessage 'Json,
messageFromChannel :: MessageFromChannel
chatMessage :: ChatMessage 'Json
}
deriving (Show)
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
src/Simplex/Chat/Messages.hs
+31 -23
View File
@@ -116,8 +116,7 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
Just Refl -> Right x
Nothing -> Left "bad chat type"
data GroupChatScope
= GCSMemberSupport {groupMemberId_ :: Maybe GroupMemberId} -- Nothing means own conversation with support
data GroupChatScope = GCSMemberSupport {groupMemberId_ :: Maybe GroupMemberId} -- Nothing means own conversation with support
deriving (Eq, Show, Ord)
data GroupChatScopeTag
@@ -172,8 +171,7 @@ data ChatInfo (c :: ChatType) where
deriving instance Show (ChatInfo c)
data GroupChatScopeInfo
= GCSIMemberSupport {groupMember_ :: Maybe GroupMember}
data GroupChatScopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember}
deriving (Show)
toChatScope :: GroupChatScopeInfo -> GroupChatScope
@@ -292,6 +290,7 @@ data CIDirection (c :: ChatType) (d :: MsgDirection) where
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
CIGroupSnd :: CIDirection 'CTGroup 'MDSnd
CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv
CIChannelRcv :: CIDirection 'CTGroup 'MDRcv
CILocalSnd :: CIDirection 'CTLocal 'MDSnd
CILocalRcv :: CIDirection 'CTLocal 'MDRcv
@@ -306,6 +305,7 @@ data JSONCIDirection
| JCIDirectRcv
| JCIGroupSnd
| JCIGroupRcv {groupMember :: GroupMember}
| JCIChannelRcv
| JCILocalSnd
| JCILocalRcv
deriving (Show)
@@ -316,6 +316,7 @@ jsonCIDirection = \case
CIDirectRcv -> JCIDirectRcv
CIGroupSnd -> JCIGroupSnd
CIGroupRcv m -> JCIGroupRcv m
CIChannelRcv -> JCIChannelRcv
CILocalSnd -> JCILocalSnd
CILocalRcv -> JCILocalRcv
@@ -325,6 +326,7 @@ jsonACIDirection = \case
JCIDirectRcv -> ACID SCTDirect SMDRcv CIDirectRcv
JCIGroupSnd -> ACID SCTGroup SMDSnd CIGroupSnd
JCIGroupRcv m -> ACID SCTGroup SMDRcv $ CIGroupRcv m
JCIChannelRcv -> ACID SCTGroup SMDRcv CIChannelRcv
JCILocalSnd -> ACID SCTLocal SMDSnd CILocalSnd
JCILocalRcv -> ACID SCTLocal SMDRcv CILocalRcv
@@ -359,10 +361,13 @@ chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed
timedDeleteAt' :: CITimed -> Maybe UTCTime
timedDeleteAt' CITimed {deleteAt} = deleteAt
chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> GroupMember
chatItemMember GroupInfo {membership} ChatItem {chatDir} = case chatDir of
CIGroupSnd -> membership
CIGroupRcv m -> m
chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> Maybe GroupMember
chatItemMember GroupInfo {membership} ChatItem {chatDir, meta = CIMeta {showGroupAsSender}} = case chatDir of
CIGroupSnd
| showGroupAsSender -> Nothing
| otherwise -> Just membership
CIGroupRcv m -> Just m
CIChannelRcv -> Nothing
chatItemRcvFromMember :: ChatItem c d -> Maybe GroupMember
chatItemRcvFromMember ChatItem {chatDir} = case chatDir of
@@ -383,6 +388,7 @@ data ChatDirection (c :: ChatType) (d :: MsgDirection) where
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
CDGroupSnd :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd
CDGroupRcv :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
CDChannelRcv :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDRcv
CDLocalSnd :: NoteFolder -> ChatDirection 'CTLocal 'MDSnd
CDLocalRcv :: NoteFolder -> ChatDirection 'CTLocal 'MDRcv
@@ -392,6 +398,7 @@ toCIDirection = \case
CDDirectRcv _ -> CIDirectRcv
CDGroupSnd _ _ -> CIGroupSnd
CDGroupRcv _ _ m -> CIGroupRcv m
CDChannelRcv _ _ -> CIChannelRcv
CDLocalSnd _ -> CILocalSnd
CDLocalRcv _ -> CILocalRcv
@@ -401,6 +408,7 @@ toChatInfo = \case
CDDirectRcv c -> DirectChat c
CDGroupSnd g s -> GroupChat g s
CDGroupRcv g s _ -> GroupChat g s
CDChannelRcv g s -> GroupChat g s
CDLocalSnd l -> LocalChat l
CDLocalRcv l -> LocalChat l
@@ -634,23 +642,23 @@ deriving instance Show (CIQDirection c)
data ACIQDirection = forall c. (ChatTypeI c, ChatTypeQuotable c) => ACIQDirection (SChatType c) (CIQDirection c)
jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection
jsonCIQDirection :: CIQDirection c -> JSONCIDirection
jsonCIQDirection = \case
CIQDirectSnd -> Just JCIDirectSnd
CIQDirectRcv -> Just JCIDirectRcv
CIQGroupSnd -> Just JCIGroupSnd
CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m
CIQGroupRcv Nothing -> Nothing
CIQDirectSnd -> JCIDirectSnd
CIQDirectRcv -> JCIDirectRcv
CIQGroupSnd -> JCIGroupSnd
CIQGroupRcv (Just m) -> JCIGroupRcv m
CIQGroupRcv Nothing -> JCIChannelRcv
jsonACIQDirection :: Maybe JSONCIDirection -> Either String ACIQDirection
jsonACIQDirection :: JSONCIDirection -> Either String ACIQDirection
jsonACIQDirection = \case
Just JCIDirectSnd -> Right $ ACIQDirection SCTDirect CIQDirectSnd
Just JCIDirectRcv -> Right $ ACIQDirection SCTDirect CIQDirectRcv
Just JCIGroupSnd -> Right $ ACIQDirection SCTGroup CIQGroupSnd
Just (JCIGroupRcv m) -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv (Just m)
Nothing -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing
Just JCILocalSnd -> Left "unquotable"
Just JCILocalRcv -> Left "unquotable"
JCIDirectSnd -> Right $ ACIQDirection SCTDirect CIQDirectSnd
JCIDirectRcv -> Right $ ACIQDirection SCTDirect CIQDirectRcv
JCIGroupSnd -> Right $ ACIQDirection SCTGroup CIQGroupSnd
JCIGroupRcv m -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv (Just m)
JCIChannelRcv -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing
JCILocalSnd -> Left "unquotable"
JCILocalRcv -> Left "unquotable"
quoteMsgDirection :: CIQDirection c -> MsgDirection
quoteMsgDirection = \case
@@ -1468,7 +1476,7 @@ instance FromJSON ACIDirection where
parseJSON v = jsonACIDirection <$> J.parseJSON v
instance ChatTypeI c => FromJSON (CIQDirection c) where
parseJSON v = (jsonACIQDirection >=> \(ACIQDirection _ x) -> checkChatType x) <$?> J.parseJSON v
parseJSON v = (jsonACIQDirection . fromMaybe JCIChannelRcv >=> \(ACIQDirection _ x) -> checkChatType x) <$?> J.parseJSON v
instance ToJSON (CIQDirection c) where
toJSON = J.toJSON . jsonCIQDirection
src/Simplex/Chat/Messages/Batch.hs
+6 -4
View File
@@ -71,12 +71,14 @@ batchDeliveryTasks1 vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0)
-- doesn’t fit: stop adding further messages
| otherwise = (msgBodies, taskIds, largeTaskIds, len, n)
where
MessageDeliveryTask {taskId, senderMemberId, senderMemberName, brokerTs, chatMessage, messageFromChannel = _messageFromChannel} = task
-- TODO [channels fwd] handle messageFromChannel (null memberId in XGrpMsgForward)
MessageDeliveryTask {taskId, fwdSender, brokerTs, chatMessage} = task
msgBody =
let fwdEvt = XGrpMsgForward senderMemberId (Just senderMemberName) chatMessage brokerTs
let (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}
in chatMsgToBody cm
in chatMsgToBody cm
msgLen = B.length msgBody
len'
| n == 0 = msgLen
src/Simplex/Chat/Protocol.hs
+15 -14
View File
@@ -238,7 +238,7 @@ data MsgRef = MsgRef
{ msgId :: Maybe SharedMsgId,
sentAt :: UTCTime,
sent :: Bool,
memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received
memberId :: Maybe MemberId -- present in group message references, Nothing for channel messages
}
deriving (Eq, Show)
@@ -305,12 +305,10 @@ data ChatMessage e = ChatMessage
data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)
type MessageFromChannel = Bool
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope} -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope, asGroup :: Maybe Bool} -> ChatMsgEvent 'Json
XMsgDel :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope} -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json
XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json
@@ -345,7 +343,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json
XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json
XGrpMsgForward :: MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
XGrpMsgForward :: Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json
XInfoProbe :: Probe -> ChatMsgEvent 'Json
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
XInfoProbeOk :: Probe -> ChatMsgEvent 'Json
@@ -624,7 +622,8 @@ data ExtMsgContent = ExtMsgContent
file :: Maybe FileInvitation,
ttl :: Maybe Int,
live :: Maybe Bool,
scope :: Maybe MsgScope
scope :: Maybe MsgScope,
asGroup :: Maybe Bool
}
deriving (Eq, Show)
@@ -714,10 +713,11 @@ parseMsgContainer v =
live <- v .:? "live"
mentions <- fromMaybe M.empty <$> (v .:? "mentions")
scope <- v .:? "scope"
pure ExtMsgContent {content, mentions, file, ttl, live, scope}
asGroup <- v .:? "asGroup"
pure ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup}
extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent
extMsgContent mc file = ExtMsgContent mc M.empty file Nothing Nothing Nothing
extMsgContent mc file = ExtMsgContent mc M.empty file Nothing Nothing Nothing Nothing
justTrue :: Bool -> Maybe Bool
justTrue True = Just True
@@ -770,8 +770,8 @@ msgContainerJSON = \case
MCSimple mc -> o $ msgContent mc
where
o = JM.fromList
msgContent ExtMsgContent {content, mentions, file, ttl, live, scope} =
("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) $ ("scope" .=? scope) ["content" .= content]
msgContent ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup} =
("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) $ ("scope" .=? scope) $ ("asGroup" .=? asGroup) ["content" .= content]
nonEmptyMap :: Map k v -> Maybe (Map k v)
nonEmptyMap m = if M.null m then Nothing else Just m
@@ -1089,7 +1089,8 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
ttl <- opt "ttl"
live <- opt "live"
scope <- opt "scope"
pure XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope}
asGroup <- opt "asGroup"
pure XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup}
XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId" <*> opt "scope"
XMsgDeleted_ -> pure XMsgDeleted
XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> opt "scope" <*> p "reaction" <*> p "add"
@@ -1131,7 +1132,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences"
XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope"
XGrpMsgForward_ -> XGrpMsgForward <$> p "memberId" <*> opt "memberName" <*> p "msg" <*> p "msgTs"
XGrpMsgForward_ -> XGrpMsgForward <$> opt "memberId" <*> opt "memberName" <*> p "msg" <*> p "msgTs"
XInfoProbe_ -> XInfoProbe <$> p "probe"
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
@@ -1158,7 +1159,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
params = \case
XMsgNew container -> msgContainerJSON container
XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope} -> o $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup} -> o $ ("asGroup" .=? asGroup) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' memberId scope -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) ["msgId" .= msgId']
XMsgDeleted -> JM.empty
XMsgReact msgId' memberId scope reaction add -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add]
@@ -1193,7 +1194,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
XGrpInfo p -> o ["groupProfile" .= p]
XGrpPrefs p -> o ["groupPreferences" .= p]
XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq]
XGrpMsgForward memberId memberName msg msgTs -> o $ ("memberName" .=? memberName) ["memberId" .= memberId, "msg" .= msg, "msgTs" .= msgTs]
XGrpMsgForward memberId memberName msg msgTs -> o $ ("memberId" .=? memberId) $ ("memberName" .=? memberName) ["msg" .= msg, "msgTs" .= msgTs]
XInfoProbe probe -> o ["probe" .= probe]
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
XInfoProbeOk probe -> o ["probe" .= probe]
src/Simplex/Chat/Store/Delivery.hs
+8 -6
View File
@@ -81,10 +81,10 @@ createMsgDeliveryTask db gInfo sender newTask = do
created_at, updated_at
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
|]
((Only groupId) :. jobScopeRow_ jobScope :. (groupMemberId' sender, messageId, BI messageFromChannel, DTSNew, currentTs, currentTs))
((Only groupId) :. jobScopeRow_ jobScope :. (groupMemberId' sender, messageId, BI sentAsGroup, DTSNew, currentTs, currentTs))
where
GroupInfo {groupId} = gInfo
NewMessageDeliveryTask {messageId, jobScope, messageFromChannel} = newTask
NewMessageDeliveryTask {messageId, taskContext = DeliveryTaskContext {jobScope, sentAsGroup}} = newTask
deleteGroupDeliveryTasks :: DB.Connection -> GroupInfo -> IO ()
deleteGroupDeliveryTasks db GroupInfo {groupId} =
@@ -146,16 +146,18 @@ getMsgDeliveryTask_ db taskId =
(Only taskId)
where
toTask :: MessageDeliveryTaskRow -> Either StoreError MessageDeliveryTask
toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, BI messageFromChannel)) =
toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, BI showGroupAsSender)) =
case toJobScope_ jobScopeRow of
Just jobScope -> Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, messageFromChannel}
Just jobScope ->
let fwdSender = if showGroupAsSender then FwdChannel else FwdMember senderMemberId senderMemberName
in Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, fwdSender, brokerTs, chatMessage}
Nothing -> Left $ SEInvalidDeliveryTask taskId'
markDeliveryTaskFailed_ :: DB.Connection -> Int64 -> IO ()
markDeliveryTaskFailed_ db taskId =
DB.execute db "UPDATE delivery_tasks SET failed = 1 where delivery_task_id = ?" (Only taskId)
-- TODO [channels fwd] possible optimization is to read and add tasks to batch iteratively to avoid reading too many tasks
-- TODO [relays] possible optimization is to read and add tasks to batch iteratively to avoid reading too many tasks
-- passed MessageDeliveryTask defines the jobScope to search for
getNextDeliveryTasks :: DB.Connection -> GroupInfo -> MessageDeliveryTask -> IO (Either StoreError [Either StoreError MessageDeliveryTask])
getNextDeliveryTasks db gInfo task =
@@ -316,7 +318,7 @@ updateDeliveryJobStatus_ db jobId status errReason_ = do
"UPDATE delivery_jobs SET job_status = ?, job_err_reason = ?, updated_at = ? WHERE delivery_job_id = ?"
(status, errReason_, currentTs, jobId)
-- TODO [channels fwd] possible improvement is to prioritize owners and "active" members
-- TODO [relays] possible improvement is to prioritize owners and "active" members
getGroupMembersByCursor :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMemberId -> Maybe GroupMemberId -> Int -> IO [GroupMember]
getGroupMembersByCursor db vr user@User {userContactId} GroupInfo {groupId} cursorGMId_ singleSenderGMId_ count = do
gmIds :: [Int64] <-
src/Simplex/Chat/Store/Files.hs
+11 -8
View File
@@ -380,14 +380,16 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing}
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do
currentTs <- liftIO getCurrentTime
rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr
let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_
-- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it
xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, userApprovedRelays = False}) <$> rfd_
fileProtocol = if isJust rfd_ then FPXFTP else FPSMP
grpMemberId_ = groupMemberId' <$> m_
senderName = maybe gName (\GroupMember {localDisplayName = c} -> c) m_
fileId <- liftIO $ do
DB.execute
db
@@ -398,8 +400,8 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId, cryptoArgs = Nothing}
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, grpMemberId_, rfdId, currentTs, currentTs)
pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing}
createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64
createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do
@@ -528,11 +530,12 @@ getRcvFileTransfer_ db userId fileId = do
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name
FROM rcv_files r
JOIN files f USING (file_id)
LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
LEFT JOIN group_members m ON m.group_member_id = r.group_member_id
LEFT JOIN groups g ON g.group_id = f.group_id
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
@@ -541,10 +544,10 @@ getRcvFileTransfer_ db userId fileId = do
where
rcvFileTransfer ::
Maybe RcvFileDescr ->
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) ->
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. Only (Maybe ContactName) ->
ExceptT StoreError IO RcvFileTransfer
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays)) =
case contactName_ <|> memberName_ <|> standaloneName_ of
rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. Only groupName_) =
case contactName_ <|> memberName_ <|> groupName_ <|> standaloneName_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just name ->
case fileStatus' of
src/Simplex/Chat/Store/Groups.hs
+13 -9
View File
@@ -582,23 +582,27 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile {
DB.execute db "DELETE FROM contacts WHERE contact_id = ?" (Only contactId)
DB.execute db "DELETE FROM contact_profiles WHERE contact_profile_id = ?" (Only profileId)
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> ExceptT StoreError IO (GroupInfo, GroupMember)
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
createPreparedGroup db gVar vr user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays = do
currentTs <- liftIO getCurrentTime
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
(groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing currentTs
hostMemberId <- insertHost_ currentTs groupId groupLDN
hostMemberId_ <-
if useRelays
then pure Nothing
else Just <$> insertHost_ currentTs groupId groupLDN
userMemberId <-
if useRelays
then liftIO $ MemberId <$> encodedRandomBytes gVar 12
else pure $ MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id"
let userMember = MemberIdRole userMemberId GRMember
-- TODO [member keys] user key must be included here. Should key be added when group is prepared?
membership <- createContactMemberInv_ db user groupId (Just hostMemberId) user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs vr
hostMember <- getGroupMember db vr user groupId hostMemberId
when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs vr
hostMember_ <- forM hostMemberId_ $ getGroupMember db vr user groupId
forM_ hostMember_ $ \hostMember ->
when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember
g <- getGroupInfo db vr user groupId
pure (g, hostMember)
pure (g, hostMember_)
where
insertHost_ currentTs groupId groupLDN = do
randHostId <- liftIO $ encodedRandomBytes gVar 12
@@ -637,12 +641,12 @@ updateBusinessChatInfo db groupId businessChatInfo =
|]
(businessChatInfoRow businessChatInfo :. (Only groupId))
updatePreparedGroupUser :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> User -> ExceptT StoreError IO GroupInfo
updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMember newUser@User {userId = newUserId} = do
updatePreparedGroupUser :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMember -> User -> ExceptT StoreError IO GroupInfo
updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMember_ newUser@User {userId = newUserId} = do
currentTs <- liftIO getCurrentTime
updateGroup gInfo currentTs
liftIO $ updateMembership membership currentTs
updateHostMember hostMember currentTs
forM_ hostMember_ $ \hostMember -> updateHostMember hostMember currentTs
getGroupInfo db vr newUser groupId
where
updateGroup GroupInfo {localDisplayName = oldGroupLDN, groupProfile = GroupProfile {displayName = groupDisplayName}} currentTs =
src/Simplex/Chat/Store/Messages.hs
+35 -18
View File
@@ -525,9 +525,9 @@ setSupportChatMemberAttention db vr user g m memberAttention = do
m_ <- runExceptT $ getGroupMemberById db vr user (groupMemberId' m)
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live hasLink createdAt =
createNewChatItem_ db user chatDirection False createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing createdAt
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live hasLink createdAt =
createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing createdAt
where
createdByMsgId = if msgId == 0 then Nothing else Just msgId
quoteRow :: NewQuoteRow
@@ -543,7 +543,8 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom)
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do
ciId <- createNewChatItem_ db user chatDirection False (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember createdAt
let showAsGroup = case chatDirection of CDChannelRcv {} -> True; _ -> False
ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember createdAt
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
pure (ciId, quotedItem, itemForwarded)
where
@@ -557,6 +558,8 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw
CDDirectRcv _ -> (Just $ not sent, Nothing)
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ _ ->
(Just $ Just userMemberId == memberId, memberId)
CDChannelRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
(Just $ Just userMemberId == memberId, memberId)
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> UTCTime -> UTCTime -> IO ChatItemId
createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink itemTs =
@@ -596,12 +599,14 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
CDGroupRcv GroupInfo {groupId} _ GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId, Nothing)
CDGroupSnd GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing)
CDChannelRcv GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing)
CDLocalRcv NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId)
CDLocalSnd NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId)
groupScope :: Maybe (Maybe GroupChatScopeInfo)
groupScope = case chatDirection of
CDGroupRcv _ scope _ -> Just scope
CDGroupSnd _ scope -> Just scope
CDChannelRcv _ scope -> Just scope
_ -> Nothing
groupScopeRow :: (Maybe GroupChatScopeTag, Maybe GroupMemberId)
groupScopeRow = case groupScope of
@@ -640,6 +645,12 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
| mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId senderGMId
| otherwise -> getGroupChatItemQuote_ groupId mId
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
CDChannelRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} _s ->
case memberId of
Just mId
| mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId
| otherwise -> getGroupChatItemQuote_ groupId mId
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
where
ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c
ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content
@@ -2313,6 +2324,12 @@ toGroupChatItem
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus)
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) ->
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing, Just (AFS SMDRcv fileStatus))
| showGroupAsSender ->
Right $ cItem SMDRcv CIChannelRcv ciStatus ciContent (maybeCIFile fileStatus)
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing, Nothing)
| showGroupAsSender ->
Right $ cItem SMDRcv CIChannelRcv ciStatus ciContent Nothing
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) ->
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus)
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) ->
@@ -2668,7 +2685,7 @@ groupCIWithReactions db g cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemId,
mentions <- getGroupCIMentions db itemId
case itemSharedMsgId of
Just sharedMsgId -> do
let GroupMember {memberId} = chatItemMember g ci
let memberId = memberId' <$> chatItemMember g ci
reactions <- getGroupCIReactions db g memberId sharedMsgId
pure $ CChatItem md ci {reactions, mentions}
Nothing -> pure $ if null mentions then cci else CChatItem md ci {mentions}
@@ -2913,8 +2930,8 @@ markReceivedGroupReportsDeleted db User {userId} GroupInfo {groupId, membership}
|]
(DBCIDeleted, deletedTs, groupMemberId' membership, currentTs, userId, groupId, MCReport_, DBCINotDeleted)
getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupInfo -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId db user@User {userId} g@GroupInfo {groupId} groupMemberId sharedMsgId = do
getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupInfo -> Maybe GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId db user@User {userId} g@GroupInfo {groupId} groupMemberId_ sharedMsgId = do
itemId <-
ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $
DB.query
@@ -2922,11 +2939,11 @@ getGroupChatItemBySharedMsgId db user@User {userId} g@GroupInfo {groupId} groupM
[sql|
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ?
WHERE user_id = ? AND group_id = ? AND group_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ?
ORDER BY chat_item_id DESC
LIMIT 1
|]
(userId, groupId, groupMemberId, sharedMsgId)
(userId, groupId, groupMemberId_, sharedMsgId)
getGroupCIWithReactions db user g itemId
getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupInfo -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
@@ -3254,7 +3271,7 @@ getDirectCIReactions db Contact {contactId} itemSharedMsgId =
|]
(contactId, itemSharedMsgId)
getGroupCIReactions :: DB.Connection -> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount]
getGroupCIReactions :: DB.Connection -> GroupInfo -> Maybe MemberId -> SharedMsgId -> IO [CIReactionCount]
getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId =
map toCIReaction
<$> DB.query
@@ -3262,7 +3279,7 @@ getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId =
[sql|
SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id)
FROM chat_item_reactions
WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ?
WHERE group_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ?
GROUP BY reaction
|]
(groupId, itemMemberId, itemSharedMsgId)
@@ -3296,7 +3313,7 @@ getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemShar
reactions <- getDirectCIReactions db ct itemSharedMId
pure $ AChatItem SCTDirect md chat ci {reactions}
GroupChat g _s -> do
let GroupMember {memberId} = chatItemMember g ci
let memberId = memberId' <$> chatItemMember g ci
reactions <- getGroupCIReactions db g memberId itemSharedMId
pure $ AChatItem SCTGroup md chat ci {reactions}
_ -> pure aci
@@ -3310,10 +3327,10 @@ deleteDirectCIReactions_ db contactId ChatItem {meta = CIMeta {itemSharedMsgId}}
deleteGroupCIReactions_ :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> IO ()
deleteGroupCIReactions_ db g@GroupInfo {groupId} ci@ChatItem {meta = CIMeta {itemSharedMsgId}} =
forM_ itemSharedMsgId $ \itemSharedMId -> do
let GroupMember {memberId} = chatItemMember g ci
let memberId = memberId' <$> chatItemMember g ci
DB.execute
db
"DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ?"
"DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ?"
(groupId, itemSharedMId, memberId)
toCIReaction :: (MsgReaction, BoolInt, Int) -> CIReactionCount
@@ -3351,7 +3368,7 @@ setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs
|]
(contactId' ct, itemSharedMId, BI sent, reaction)
getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction]
getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> Maybe MemberId -> SharedMsgId -> Bool -> IO [MsgReaction]
getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
map fromOnly
<$> DB.query
@@ -3359,11 +3376,11 @@ getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent =
[sql|
SELECT reaction
FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND item_member_id = ? AND shared_msg_id = ? AND reaction_sent = ?
WHERE group_id = ? AND group_member_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? AND reaction_sent = ?
|]
(groupId, groupMemberId' m, itemMemberId, itemSharedMId, BI sent)
setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> Maybe MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO ()
setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs
| add =
DB.execute
@@ -3379,7 +3396,7 @@ setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reacti
db
[sql|
DELETE FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND reaction_sent = ? AND reaction = ?
|]
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, BI sent, reaction)
src/Simplex/Chat/Store/SQLite/Migrations/M20230511_reactions.hs
+1 -1
View File
@@ -10,7 +10,7 @@ m20230511_reactions =
[sql|
CREATE TABLE chat_item_reactions (
chat_item_reaction_id INTEGER PRIMARY KEY AUTOINCREMENT,
item_member_id BLOB, -- member that created item, NULL for items in direct chats
item_member_id BLOB,
shared_msg_id BLOB NOT NULL,
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs
+2 -2
View File
@@ -5,7 +5,7 @@ module Simplex.Chat.Store.SQLite.Migrations.M20250813_delivery_tasks where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
-- TODO [channels fwd] add later in new migration for MemberProfileUpdate delivery jobs:
-- TODO [relays] add later in new migration for MemberProfileUpdate delivery jobs:
-- TODO - ALTER TABLE group_members ADD COLUMN last_profile_delivery_ts TEXT;
-- TODO - ALTER TABLE group_members ADD COLUMN join_ts TEXT;
@@ -21,7 +21,7 @@ import Database.SQLite.Simple.QQ (sql)
-- delivery_tasks table:
-- - sender_group_member_id <-> GroupMemberId (sender of the original message that created task),
-- - message_id <-> MessageId (reference to the original message that created task),
-- - message_from_channel <-> Maybe MessageFromChannel (for MessageDeliveryTask),
-- - message_from_channel <-> ShowGroupAsSender (for MessageDeliveryTask),
-- - task_status <-> DeliveryTaskStatus,
-- - task_err_reason <-> Maybe Text (set when task status is DTSError, not encoded in status to allow filtering by DTSError in queries).
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+8 -6
View File
@@ -1105,7 +1105,7 @@ SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_contact (contact_
Query:
DELETE FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ?
WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND reaction_sent = ? AND reaction = ?
Plan:
SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?)
@@ -1406,7 +1406,7 @@ SEARCH ct USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT chat_item_id
FROM chat_items
WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ?
WHERE user_id = ? AND group_id = ? AND group_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ?
ORDER BY chat_item_id DESC
LIMIT 1
@@ -1611,11 +1611,12 @@ Query:
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline,
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays
r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name
FROM rcv_files r
JOIN files f USING (file_id)
LEFT JOIN contacts cs ON cs.contact_id = f.contact_id
LEFT JOIN group_members m ON m.group_member_id = r.group_member_id
LEFT JOIN groups g ON g.group_id = f.group_id
WHERE f.user_id = ? AND f.file_id = ?
Plan:
@@ -1623,6 +1624,7 @@ SEARCH f USING INTEGER PRIMARY KEY (rowid=?)
SEARCH r USING INTEGER PRIMARY KEY (rowid=?)
SEARCH cs USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
SEARCH g USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
Query:
SELECT r.probe, r.contact_id, g.group_id, r.group_member_id
@@ -3700,7 +3702,7 @@ SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_contact (contact_
Query:
SELECT reaction
FROM chat_item_reactions
WHERE group_id = ? AND group_member_id = ? AND item_member_id = ? AND shared_msg_id = ? AND reaction_sent = ?
WHERE group_id = ? AND group_member_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? AND reaction_sent = ?
Plan:
SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?)
@@ -3718,7 +3720,7 @@ USE TEMP B-TREE FOR GROUP BY
Query:
SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id)
FROM chat_item_reactions
WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ?
WHERE group_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ?
GROUP BY reaction
Plan:
@@ -5885,7 +5887,7 @@ Query: DELETE FROM chat_item_reactions WHERE group_id = ?
Plan:
SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_group_id (group_id=?)
Query: DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ?
Query: DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ?
Plan:
SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?)
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+1 -1
View File
@@ -541,7 +541,7 @@ CREATE TABLE chat_item_versions(
) STRICT;
CREATE TABLE chat_item_reactions(
chat_item_reaction_id INTEGER PRIMARY KEY AUTOINCREMENT,
item_member_id BLOB, -- member that created item, NULL for items in direct chats
item_member_id BLOB,
shared_msg_id BLOB NOT NULL,
contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
src/Simplex/Chat/Terminal/Output.hs
+2 -1
View File
@@ -180,7 +180,8 @@ chatEventNotification t@ChatTerminal {sendNotification} cc = \case
whenCurrUser cc u $ setActiveChat t cInfo
case (cInfo, chatDir) of
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
(GroupChat g scopeInfo, CIGroupRcv m) -> sendNtf (fromGroup_ g scopeInfo m, text)
(GroupChat g scopeInfo, CIGroupRcv m) -> sendNtf (fromGroup_ g scopeInfo (Just m), text)
(GroupChat g scopeInfo, CIChannelRcv) -> sendNtf (fromGroup_ g scopeInfo Nothing, text)
_ -> pure ()
where
text = msgText mc formattedText
src/Simplex/Chat/Types.hs
+6
View File
@@ -494,6 +494,12 @@ data GroupInfo = GroupInfo
useRelays' :: GroupInfo -> Bool
useRelays' GroupInfo {useRelays} = isTrue useRelays
sendAsGroup' :: GroupInfo -> Bool
sendAsGroup' gInfo@GroupInfo {membership} = useRelays' gInfo && memberRole' membership == GROwner
groupId' :: GroupInfo -> GroupId
groupId' GroupInfo {groupId} = groupId
data BusinessChatType
= BCBusiness -- used on the customer side
| BCCustomer -- used on the business side
src/Simplex/Chat/View.hs
+62 -48
View File
@@ -552,6 +552,7 @@ chatDirNtf :: User -> ChatInfo c -> CIDirection c d -> Bool -> Bool
chatDirNtf user cInfo chatDir mention = case (cInfo, chatDir) of
(DirectChat ct, CIDirectRcv) -> contactNtf user ct mention
(GroupChat g _scopeInfo, CIGroupRcv m) -> groupNtf user g mention && not (memberBlocked m)
(GroupChat g _scopeInfo, CIChannelRcv) -> groupNtf user g mention
_ -> True
contactNtf :: User -> Contact -> Bool -> Bool
@@ -673,16 +674,18 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
_ -> showSndItem to
where
to = ttyToGroup g scopeInfo
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m) context meta [plainContent content] False
CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m) context meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroupAttention g scopeInfo m userMention
CIGroupRcv m -> rcvGroupItem (Just m)
CIChannelRcv -> rcvGroupItem Nothing
where
rcvGroupItem m_ = case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvGroupInvitation {} | isJust m_ -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m_) context meta [plainContent content] False
CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m_) context meta [plainContent content] False
_ -> showRcvItem from
where
from = ttyFromGroupAttention g scopeInfo m_ userMention
context =
maybe
(maybe [] forwardedFrom itemForwarded)
@@ -813,19 +816,22 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, itemEd
(directQuote chatDir)
quotedItem
GroupChat g scopeInfo -> case chatDir of
CIGroupRcv m -> case content of
CIRcvMsgContent mc
| itemLive == Just True && not liveItems -> []
| otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta
_ -> []
where
from = if itemEdited then ttyFromGroupEdited g scopeInfo m else ttyFromGroup g scopeInfo m
CIGroupRcv m -> updGroupItem (Just m)
CIChannelRcv -> updGroupItem Nothing
CIGroupSnd -> case content of
CISndMsgContent mc -> hideLive meta $ viewSentMessage to context mc ts tz meta
_ -> []
where
to = if itemEdited then ttyToGroupEdited g scopeInfo else ttyToGroup g scopeInfo
where
updGroupItem :: Maybe GroupMember -> [StyledString]
updGroupItem m_ = case content of
CIRcvMsgContent mc
| itemLive == Just True && not liveItems -> []
| otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta
_ -> []
where
from = if itemEdited then ttyFromGroupEdited g scopeInfo m_ else ttyFromGroup g scopeInfo m_
context =
maybe
(maybe [] forwardedFrom itemForwarded)
@@ -881,7 +887,7 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem
prohibited = [styled (colored Red) ("[unexpected message deletion, please report to developers]" :: String)]
viewItemReaction :: forall c d. Bool -> ChatInfo c -> CIReaction c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md ChatItem {chatDir = itemDir, content}, sentAt, reaction} added ts tz =
viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md ChatItem {chatDir = itemDir, content, meta = CIMeta {showGroupAsSender}}, sentAt, reaction} added ts tz =
case (chat, chatDir) of
(DirectChat c, CIDirectRcv) -> case ciMsgContent content of
Just mc -> view from $ reactionMsg mc
@@ -889,12 +895,8 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md
where
from = ttyFromContact c
reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">"
(GroupChat g scopeInfo, CIGroupRcv m) -> case ciMsgContent content of
Just mc -> view from $ reactionMsg mc
_ -> []
where
from = ttyFromGroup g scopeInfo m
reactionMsg mc = quoteText mc . ttyQuotedMember . Just $ sentByMember' g itemDir
(GroupChat g scopeInfo, CIGroupRcv m) -> groupReaction g scopeInfo (Just m) (sentByMember' g itemDir)
(GroupChat g scopeInfo, CIChannelRcv) -> groupReaction g scopeInfo Nothing (sentByMember' g itemDir)
(LocalChat _, CILocalRcv) -> case ciMsgContent content of
Just mc -> view from $ reactionMsg mc
_ -> []
@@ -906,6 +908,13 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md
(_, CILocalSnd) -> [sentText]
(CInfoInvalidJSON {}, _) -> []
where
groupReaction g scopeInfo m_ sentBy = case ciMsgContent content of
Just mc -> view from $ reactionMsg mc
_ -> []
where
from = ttyFromGroup g scopeInfo m_
reactionMsg mc = quoteText mc . ttyQuotedMember $
if showGroupAsSender then Nothing else sentBy
view from msg
| showReactions = viewReceivedReaction from msg reactionText ts tz sentAt
| otherwise = []
@@ -946,10 +955,11 @@ sentByMember GroupInfo {membership} = \case
CIQGroupSnd -> Just membership
CIQGroupRcv m -> m
sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> GroupMember
sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> Maybe GroupMember
sentByMember' GroupInfo {membership} = \case
CIGroupSnd -> membership
CIGroupRcv m -> m
CIGroupSnd -> Just membership
CIGroupRcv m -> Just m
CIChannelRcv -> Nothing
quoteText :: MsgContent -> StyledString -> [StyledString]
quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc
@@ -2270,6 +2280,7 @@ cryptoFileArgsStr testView cfArgs@(CFArgs key nonce)
fileFrom :: ChatInfo c -> CIDirection c d -> StyledString
fileFrom (DirectChat ct) CIDirectRcv = " from " <> ttyContact' ct
fileFrom _ (CIGroupRcv m) = " from " <> ttyMember m
fileFrom (GroupChat g _) CIChannelRcv = " from " <> ttyGroup' g
fileFrom _ _ = ""
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
@@ -2698,7 +2709,7 @@ ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ viewName c <> ">"
ttyQuotedMember :: Maybe GroupMember -> StyledString
ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom (viewName c)
ttyQuotedMember _ = "> " <> ttyFrom "?"
ttyQuotedMember Nothing = ">"
ttyFromContact :: Contact -> StyledString
ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> ")
@@ -2734,26 +2745,29 @@ ttyFullGroup :: GroupInfo -> StyledString
ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName, shortDescr}} =
ttyGroup g <> optFullName g fullName shortDescr
ttyFromGroup :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> StyledString
ttyFromGroup g scopeInfo m = ttyFromGroupAttention g scopeInfo m False
ttyFromGroup :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> StyledString
ttyFromGroup g scopeInfo m_ = ttyFromGroupAttention g scopeInfo m_ False
ttyFromGroupAttention :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Bool -> StyledString
ttyFromGroupAttention g scopeInfo m attention = membershipIncognito g <> ttyFrom (fromGroupAttention_ g scopeInfo m attention)
ttyFromGroupAttention :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Bool -> StyledString
ttyFromGroupAttention g scopeInfo m_ attention = membershipIncognito g <> ttyFrom (fromGroupAttention_ g scopeInfo m_ attention)
ttyFromGroupEdited :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> StyledString
ttyFromGroupEdited g scopeInfo m = membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m <> "[edited] ")
ttyFromGroupEdited :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> StyledString
ttyFromGroupEdited g scopeInfo m_ = membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m_ <> "[edited] ")
ttyFromGroupDeleted :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Maybe Text -> StyledString
ttyFromGroupDeleted g scopeInfo m deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
ttyFromGroupDeleted :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Maybe Text -> StyledString
ttyFromGroupDeleted g scopeInfo m_ deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m_ <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
fromGroup_ :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Text
fromGroup_ g scopeInfo m = fromGroupAttention_ g scopeInfo m False
fromGroup_ :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Text
fromGroup_ g scopeInfo m_ = fromGroupAttention_ g scopeInfo m_ False
fromGroupAttention_ :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Bool -> Text
fromGroupAttention_ g scopeInfo m attention =
fromGroupAttention_ :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Bool -> Text
fromGroupAttention_ g scopeInfo m_ attention =
let attn = if attention then "!" else ""
in "#" <> viewGroupName g <> " " <> groupScopeInfoStr scopeInfo <> viewMemberName m <> attn <> "> "
in "#" <> viewGroupName g
<> maybe "" (" " <>) (groupScopeInfoStr scopeInfo)
<> maybe "" ((" " <>) . viewMemberName) m_
<> attn <> "> "
ttyFrom :: Text -> StyledString
ttyFrom = styled $ colored Yellow
@@ -2762,17 +2776,17 @@ ttyTo :: Text -> StyledString
ttyTo = styled $ colored Cyan
ttyToGroup :: GroupInfo -> Maybe GroupChatScopeInfo -> StyledString
ttyToGroup g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " " <> groupScopeInfoStr scopeInfo)
ttyToGroup g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> maybe "" (" " <>) (groupScopeInfoStr scopeInfo) <> " ")
ttyToGroupEdited :: GroupInfo -> Maybe GroupChatScopeInfo -> StyledString
ttyToGroupEdited g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> groupScopeInfoStr scopeInfo <> " [edited] ")
ttyToGroupEdited g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> maybe "" (" " <>) (groupScopeInfoStr scopeInfo) <> " [edited] ")
groupScopeInfoStr :: Maybe GroupChatScopeInfo -> Text
groupScopeInfoStr :: Maybe GroupChatScopeInfo -> Maybe Text
groupScopeInfoStr = \case
Nothing -> ""
Just (GCSIMemberSupport {groupMember_}) -> case groupMember_ of
Nothing -> "(support) "
Just m -> "(support: " <> viewMemberName m <> ") "
Nothing -> Nothing
Just (GCSIMemberSupport {groupMember_}) -> Just $ case groupMember_ of
Nothing -> "(support)"
Just m -> "(support: " <> viewMemberName m <> ")"
ttyFilePath :: FilePath -> StyledString
ttyFilePath = plain