diff --git a/simplex-chat.cabal b/simplex-chat.cabal index bf4dc7e10b..fe2a57e2be 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -152,6 +152,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260715_profile_description Simplex.Chat.Store.Postgres.Migrations.M20260716_signed_history Simplex.Chat.Store.Postgres.Migrations.M20260720_server_roles + Simplex.Chat.Store.Postgres.Migrations.M20260727_member_key_sent else exposed-modules: Simplex.Chat.Archive @@ -321,6 +322,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260715_profile_description Simplex.Chat.Store.SQLite.Migrations.M20260716_signed_history Simplex.Chat.Store.SQLite.Migrations.M20260720_server_roles + Simplex.Chat.Store.SQLite.Migrations.M20260727_member_key_sent other-modules: Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 8dd5d33711..a35c811765 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -40,7 +40,7 @@ import Data.Foldable (foldr') import Data.Functor (($>)) import Data.Functor.Identity import Data.Int (Int64) -import Data.List (find, foldl', mapAccumL, nubBy, partition) +import Data.List (find, foldl', mapAccumL, partition) import Data.List.NonEmpty (NonEmpty (..), (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -2252,14 +2252,15 @@ sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do dropSignature :: SndMessage -> SndMessage dropSignature m = m {signedMsg_ = Nothing} +signedSnd :: SndMessage -> Bool +signedSnd SndMessage {signedMsg_} = isJust signedMsg_ + memberBatch :: GroupInfo -> Connection -> NonEmpty SndMessage -> (BatchMode, NonEmpty SndMessage) memberBatch gInfo conn msgs | useRelays' gInfo = (BMBinary, msgs) - | not anySigned = (BMJson, msgs) + | not (any signedSnd msgs) = (BMJson, msgs) | maxVersion (peerChatVRange conn) >= relayWebCapVersion = (BMBinary, msgs) | otherwise = (BMJson, L.map dropSignature msgs) - where - anySigned = any (\SndMessage {signedMsg_} -> isJust signedMsg_) msgs batchSendConnMessages :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption) batchSendConnMessages mode user conn msgFlags msgs = @@ -2518,13 +2519,10 @@ sendGroupProfileUpdate user gInfo scope asGroup members = (Nothing, Just _) -> True _ -> False ownKey = groupMemberKey gInfo - profileMembers - | shouldSendProfileUpdate = filter (`supportsVersion` memberProfileUpdateVersion) members - | otherwise = [] - keyMembers - | isJust ownKey = filter (\m -> m `supportsVersion` groupMemberKeyVersion && not (userMemberKeySent m)) members - | otherwise = [] - recipients = nubBy (\a b -> groupMemberId' a == groupMemberId' b) (profileMembers <> keyMembers) + keyMember m = isJust ownKey && m `supportsVersion` groupMemberKeyVersion && not (userMemberKeySent m) + profileMember m = shouldSendProfileUpdate && m `supportsVersion` memberProfileUpdateVersion + keyMembers = filter keyMember members + recipients = filter (\m -> profileMember m || keyMember m) members sendProfileAndKey = do let incognitoProfile = incognitoMembershipProfile gInfo profile <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) @@ -2533,7 +2531,7 @@ sendGroupProfileUpdate user gInfo scope asGroup members = currentTs <- liftIO getCurrentTime withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs let delivered = [mId | (mId, _, r) <- sentTo, isRight r] <> [mId | (mId, _, _) <- pending] <> map groupMemberId' forwarded - keyDelivered = [groupMemberId' m | m <- keyMembers, groupMemberId' m `elem` delivered] + keyDelivered = filter (`elem` delivered) (map groupMemberId' keyMembers) unless (null keyDelivered) $ withStore' $ \db -> setMembersMemberKeySent db keyDelivered data GroupSndResult = GroupSndResult @@ -2590,27 +2588,22 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents mId = groupMemberId' m mIds' = S.insert mId mIds prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) - prepareMsgReqs msgFlags msgs toSendSeparate toSendBatched - | useRelays' gInfo = single BMBinary msgs toSendSeparate toSendBatched - | not anySigned = single BMJson msgs toSendSeparate toSendBatched - | otherwise = - let (sepBin, sepJson) = partition binaryCapable toSendSeparate - (btchBin, btchJson) = partition binaryCapable toSendBatched - (binIds, binReqs) = single BMBinary msgs sepBin btchBin - (jsonIds, jsonReqs) = single BMJson (L.map (fmap dropSignature) msgs) sepJson btchJson - in (binIds <> jsonIds, binReqs <> jsonReqs) + prepareMsgReqs msgFlags msgs toSendSeparate toSendBatched = + batchReqs BMBinary msgs binSep binBtch <> batchReqs BMJson jsonMsgs jsonSep jsonBtch where - anySigned = any (either (const False) (\SndMessage {signedMsg_} -> isJust signedMsg_)) (L.toList msgs) - binaryCapable (m, _) = m `supportsVersion` relayWebCapVersion - single mode msgs' sep btch = - let batched_ = batchSndMessagesJSON mode msgs' - in case L.nonEmpty batched_ of - Just batched' -> - let lenMsgs = length msgs' - (memsSep, mreqsSep) = foldMembers lenMsgs sndMessageMBR msgs' sep - (memsBtch, mreqsBtch) = foldMembers (length batched' + lenMsgs) msgBatchMBR batched' btch - in (memsSep <> memsBtch, mreqsSep <> mreqsBtch) - Nothing -> ([], []) + signed = not (useRelays' gInfo) && any (either (const False) signedSnd) (L.toList msgs) + jsonMsgs = if signed then L.map (fmap dropSignature) msgs else msgs + toBinary (m, _) = useRelays' gInfo || (signed && m `supportsVersion` relayWebCapVersion) + (binSep, jsonSep) = partition toBinary toSendSeparate + (binBtch, jsonBtch) = partition toBinary toSendBatched + batchReqs _ _ [] [] = ([], []) + batchReqs mode msgs' sep btch = case L.nonEmpty (batchSndMessagesJSON mode msgs') of + Just batched -> + let lenMsgs = length msgs' + (memsSep, mreqsSep) = foldMembers lenMsgs sndMessageMBR msgs' sep + (memsBtch, mreqsBtch) = foldMembers (length batched + lenMsgs) msgBatchMBR batched btch + in (memsSep <> memsBtch, mreqsSep <> mreqsBtch) + Nothing -> ([], []) foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) foldMembers lastRef mkMb mbs mems = snd $ foldr' foldMsgBodies (lastMemIdx_, ([], [])) mems where diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 280ee470da..55583def13 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -960,7 +960,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = _ -> pure () toView $ CEvtJoinedGroupMember user gInfo'' m' {memberStatus = mStatus} let Connection {viaUserContactLink} = conn - when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo'' + when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo'' m' when (connChatVersion < batchSend2Version) $ getAutoReplyMsg >>= mapM_ (\mc -> sendGroupAutoReply mc Nothing) if useRelays' gInfo'' then do @@ -976,11 +976,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = _ -> False when (groupFeatureAllowed SGFHistory gInfo'' && not memberIsCustomer) $ sendHistory user gInfo'' m' where - sendXGrpLinkMem gInfo'' = do - gInfo3 <- ensureUserMemberKey gInfo'' - let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo3 - profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo3 (fromIncognitoProfile <$> incognitoProfile) - sendGroupMemberMessages user gInfo3 conn (XGrpLinkMem profileToSend (groupMemberKey gInfo3) :| []) + sendXGrpLinkMem gInfo'' m' = do + gInfoK <- ensureUserMemberKey gInfo'' + let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfoK + profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfoK (fromIncognitoProfile <$> incognitoProfile) + sendGroupMemberMessages user gInfoK conn (XGrpLinkMem profileToSend (groupMemberKey gInfoK) :| []) + withStore' $ \db -> setMembersMemberKeySent db [groupMemberId' m'] _ -> do unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected notifyMemberConnected gInfo m Nothing