diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 75b40d2809..2625212c35 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -4867,24 +4867,24 @@ processChatCommand cxt nm = \case where addItem (Right SndMessage {msgId}, Right ci) m = M.insert msgId (chatItemId' ci) m addItem _ m = m - processSentTo :: DB.Connection -> Map MessageId ChatItemId -> (GroupMember, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption)) -> IO () - processSentTo db msgToItem (m, msgIds_, deliveryResult) = forM_ msgIds_ $ \msgIds -> do + processSentTo :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption)) -> IO () + processSentTo db msgToItem (mId, msgIds_, deliveryResult) = forM_ msgIds_ $ \msgIds -> do let ciIds = mapMaybe (`M.lookup` msgToItem) msgIds status = case deliveryResult of Right _ -> GSSNew Left e -> GSSError $ SndErrOther $ tshow e - forM_ ciIds $ \ciId -> createGroupSndStatus db ciId (groupMemberId' m) status - processForwarded :: DB.Connection -> (GroupMember, BatchMode) -> IO () - processForwarded db (GroupMember {groupMemberId}, _) = + forM_ ciIds $ \ciId -> createGroupSndStatus db ciId mId status + processForwarded :: DB.Connection -> GroupMember -> IO () + processForwarded db GroupMember {groupMemberId} = forM_ cis_ $ \ci_ -> forM_ ci_ $ \ci -> createGroupSndStatus db (chatItemId' ci) groupMemberId GSSForwarded - processPending :: DB.Connection -> Map MessageId ChatItemId -> (GroupMember, Either ChatError MessageId, Either ChatError ()) -> IO () - processPending db msgToItem (m, msgId_, pendingResult) = forM_ msgId_ $ \msgId -> do + processPending :: DB.Connection -> Map MessageId ChatItemId -> (GroupMemberId, Either ChatError MessageId, Either ChatError ()) -> IO () + processPending db msgToItem (mId, msgId_, pendingResult) = forM_ msgId_ $ \msgId -> do let ciId_ = M.lookup msgId msgToItem status = case pendingResult of Right _ -> GSSInactive Left e -> GSSError $ SndErrOther $ tshow e - forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId (groupMemberId' m) status + forM_ ciId_ $ \ciId -> createGroupSndStatus db ciId mId status assertMultiSendable :: Bool -> NonEmpty ComposedMessageReq -> CM () assertMultiSendable live cmrs | length cmrs == 1 = pure () diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 6d31182bfe..665d58de12 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -2488,10 +2488,9 @@ sendGroupProfileUpdate user gInfo scope asGroup members = withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs data GroupSndResult = GroupSndResult - { sentTo :: [(GroupMember, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption))], - pending :: [(GroupMember, Either ChatError MessageId, Either ChatError ())], - forwarded :: [(GroupMember, BatchMode)], - failed :: [GroupMember] + { sentTo :: [(GroupMemberId, Either ChatError [MessageId], Either ChatError ([Int64], PQEncryption))], + pending :: [(GroupMemberId, Either ChatError MessageId, Either ChatError ())], + forwarded :: [GroupMember] } sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) @@ -2503,22 +2502,22 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents sndMsgs_ <- lift $ createSndMessages idsEvts recipientMembers' <- liftIO $ shuffleMembers recipientMembers let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} - (toSend, toPending, forwarded, failed, _, dups) = - foldr' (addMember recipientMembers') (([], []), [], [], [], S.empty, 0 :: Int) recipientMembers' + (toSend, toPending, forwarded, _, dups) = + foldr' (addMember recipientMembers') (([], []), [], [], S.empty, 0 :: Int) recipientMembers' when (dups /= 0) $ logError $ "sendGroupMessages_: " <> tshow dups <> " duplicate members" -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here -- Deliver to toSend members - let (sendToMembers, msgReqs) = prepareMsgReqs msgFlags sndMsgs_ toSend + let (sendToMemIds, msgReqs) = prepareMsgReqs msgFlags sndMsgs_ toSend delivered <- maybe (pure []) (fmap L.toList . deliverMessagesB) $ L.nonEmpty msgReqs - when (length delivered /= length sendToMembers) $ logError "sendGroupMessages_: sendToMembers and delivered length mismatch" + when (length delivered /= length sendToMemIds) $ logError "sendGroupMessages_: sendToMemIds and delivered length mismatch" -- Save as pending for toPending members - let (pendingMembers, pendingReqs) = preparePending sndMsgs_ toPending + let (pendingMemIds, pendingReqs) = preparePending sndMsgs_ toPending stored <- lift $ withStoreBatch (\db -> map (bindRight $ createPendingMsg db) pendingReqs) - when (length stored /= length pendingMembers) $ logError "sendGroupMessages_: pendingMembers and stored length mismatch" + when (length stored /= length pendingMemIds) $ logError "sendGroupMessages_: pendingMemIds and stored length mismatch" -- Zip for easier access to results - let sentTo = zipWith3 (\m mReq r -> (m, fmap (\(_, _, (_, msgIds)) -> msgIds) mReq, r)) sendToMembers msgReqs delivered - pending = zipWith3 (\m pReq r -> (m, fmap snd pReq, r)) pendingMembers pendingReqs stored - pure (sndMsgs_, GroupSndResult {sentTo, pending, forwarded, failed}) + let sentTo = zipWith3 (\mId mReq r -> (mId, fmap (\(_, _, (_, msgIds)) -> msgIds) mReq, r)) sendToMemIds msgReqs delivered + pending = zipWith3 (\mId pReq r -> (mId, fmap snd pReq, r)) pendingMemIds pendingReqs stored + pure (sndMsgs_, GroupSndResult {sentTo, pending, forwarded}) where events = L.map snd signedEvents idsEvts = L.map (\(signing, evt) -> (GroupId groupId, signing, evt)) signedEvents @@ -2528,24 +2527,23 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents liftM2 (<>) (shuffle adminMs) (shuffle otherMs) where isAdmin GroupMember {memberRole} = memberRole >= GRAdmin - addMember members m acc@(toSend@(toSendBin, toSendJson), pending, forwarded, failed, !mIds, !dups) = + addMember members m acc@(toSend@(toSendBin, toSendJson), pending, forwarded, !mIds, !dups) = case memberSendAction gInfo events members m of Just a - | mId `S.member` mIds -> (toSend, pending, forwarded, failed, mIds, dups + 1) + | mId `S.member` mIds -> (toSend, pending, forwarded, mIds, dups + 1) | otherwise -> case a of MSASend conn -> let toSend' = case batchMode gInfo m of BMBinary -> ((m, conn) : toSendBin, toSendJson) BMJson -> (toSendBin, (m, conn) : toSendJson) - in (toSend', pending, forwarded, failed, mIds', dups) - MSAPending -> (toSend, m : pending, forwarded, failed, mIds', dups) - MSAForwarded mode -> (toSend, pending, (m, mode) : forwarded, failed, mIds', dups) - MSAFail -> (toSend, pending, forwarded, m : failed, mIds', dups) + in (toSend', pending, forwarded, mIds', dups) + MSAPending -> (toSend, m : pending, forwarded, mIds', dups) + MSAForwarded -> (toSend, pending, m : forwarded, mIds', dups) Nothing -> acc where mId = groupMemberId' m mIds' = S.insert mId mIds - prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> ([(GroupMember, Connection)], [(GroupMember, Connection)]) -> ([GroupMember], [Either ChatError ChatMsgReq]) + prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> ([(GroupMember, Connection)], [(GroupMember, Connection)]) -> ([GroupMemberId], [Either ChatError ChatMsgReq]) prepareMsgReqs msgFlags msgs (toSendBin, toSendJson) = batchReqs BMBinary msgs toSendBin <> batchReqs BMJson msgs toSendJson where @@ -2553,31 +2551,31 @@ sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents batchReqs mode msgs' toSend' = case L.nonEmpty (batchSndMessagesJSON mode msgs') of Just batched -> foldMembers (length batched + length msgs') msgBatchMBR batched toSend' Nothing -> ([], []) - foldMembers :: forall a. Int -> (Maybe Int -> Int -> a -> (ValueOrRef MsgBody, [MessageId])) -> NonEmpty (Either ChatError a) -> [(GroupMember, Connection)] -> ([GroupMember], [Either ChatError ChatMsgReq]) + 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 lastMemIdx_ = let len = length mems in if len > 1 then Just len else Nothing - foldMsgBodies :: (GroupMember, Connection) -> (Maybe Int, ([GroupMember], [Either ChatError ChatMsgReq])) -> (Maybe Int, ([GroupMember], [Either ChatError ChatMsgReq])) - foldMsgBodies (m, conn) (memIdx_, memsReqs) = - (subtract 1 <$> memIdx_,) $ snd $ foldr' addBody (lastRef, memsReqs) mbs + foldMsgBodies :: (GroupMember, Connection) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Maybe Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) + foldMsgBodies (GroupMember {groupMemberId}, conn) (memIdx_, memIdsReqs) = + (subtract 1 <$> memIdx_,) $ snd $ foldr' addBody (lastRef, memIdsReqs) mbs where - addBody :: Either ChatError a -> (Int, ([GroupMember], [Either ChatError ChatMsgReq])) -> (Int, ([GroupMember], [Either ChatError ChatMsgReq])) - addBody mb (i, (ms, reqs)) = + addBody :: Either ChatError a -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) -> (Int, ([GroupMemberId], [Either ChatError ChatMsgReq])) + addBody mb (i, (memIds, reqs)) = let req = (conn,msgFlags,) . mkMb memIdx_ i <$> mb - in (i - 1, (m : ms, req : reqs)) + in (i - 1, (groupMemberId : memIds, req : reqs)) msgBatchMBR :: Maybe Int -> Int -> MsgBatch -> (ValueOrRef MsgBody, [MessageId]) msgBatchMBR memIdx_ i (MsgBatch batchBody sndMsgs) = (vrValue_ memIdx_ i batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs) vrValue_ memIdx_ i v = case memIdx_ of Nothing -> VRValue Nothing v -- sending to one member, do not reference bodies Just 1 -> VRValue (Just i) v Just _ -> VRRef i - preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMember], [Either ChatError (GroupMemberId, MessageId)]) + preparePending :: NonEmpty (Either ChatError SndMessage) -> [GroupMember] -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) preparePending msgs_ = foldr' foldMsgs ([], []) where - foldMsgs :: GroupMember -> ([GroupMember], [Either ChatError (GroupMemberId, MessageId)]) -> ([GroupMember], [Either ChatError (GroupMemberId, MessageId)]) - foldMsgs m@GroupMember {groupMemberId} memsReqs = - foldr' (\msg_ (ms, reqs) -> (m : ms, fmap pendingReq msg_ : reqs)) memsReqs msgs_ + foldMsgs :: GroupMember -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) -> ([GroupMemberId], [Either ChatError (GroupMemberId, MessageId)]) + foldMsgs GroupMember {groupMemberId} memIdsReqs = + foldr' (\msg_ (memIds, reqs) -> (groupMemberId : memIds, fmap pendingReq msg_ : reqs)) memIdsReqs msgs_ where pendingReq :: SndMessage -> (GroupMemberId, MessageId) pendingReq SndMessage {msgId} = (groupMemberId, msgId) @@ -2590,7 +2588,7 @@ batchMode gInfo m | useRelays' gInfo || m `supportsVersion` relayWebCapVersion = BMBinary | otherwise = BMJson -data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded BatchMode | MSAFail +data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction memberSendAction gInfo@GroupInfo {membership} events members m@GroupMember {memberStatus} @@ -2605,7 +2603,7 @@ memberSendAction gInfo@GroupInfo {membership} events members m@GroupMember {memb | otherwise = case memberConn m of Nothing -> pendingOrForwarded Just conn@Connection {connStatus} - | connDisabled conn || connStatus == ConnDeleted || isConnFailed connStatus || memberStatus == GSMemRejected -> Just MSAFail + | connDisabled conn || connStatus == ConnDeleted || isConnFailed connStatus || memberStatus == GSMemRejected -> Nothing | connInactive conn -> Just MSAPending | connStatus == ConnSndReady || connStatus == ConnReady -> Just (MSASend conn) | otherwise -> pendingOrForwarded @@ -2617,15 +2615,16 @@ memberSendAction gInfo@GroupInfo {membership} events members m@GroupMember {memb GCPreMember -> forwardSupportedOrPending (invitedByGroupMemberId membership) GCPostMember -> forwardSupportedOrPending (invitedByGroupMemberId m) where - forwardSupportedOrPending invitingMemberId_ = case invitingMember_ of - Just forwarder | all isForwardedGroupMsg events -> Just (MSAForwarded (batchMode gInfo forwarder)) - _ - | any isXGrpMsgForward events -> Nothing - | otherwise -> Just MSAPending + forwardSupportedOrPending invitingMemberId_ + | hasInvitingMember && all isForwardedGroupMsg events = Just MSAForwarded + | any isXGrpMsgForward events = Nothing + | otherwise = Just MSAPending where - invitingMember_ = invitingMemberId_ >>= \invMemberId -> - -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember - find (\m' -> groupMemberId' m' == invMemberId) members + hasInvitingMember = case invitingMemberId_ of + Just invMemberId -> + -- can be optimized for large groups by replacing [GroupMember] with Map GroupMemberId GroupMember + any (\m' -> groupMemberId' m' == invMemberId) members + Nothing -> False isXGrpMsgForward event = case event of XGrpMsgForward {} -> True _ -> False @@ -2650,8 +2649,7 @@ sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} c messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo (chatMsgEvent :| []) [m] m) $ \case MSASend conn -> void $ deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId - MSAForwarded _ -> pure () - MSAFail -> pure () + MSAForwarded -> pure () -- Send pre-encoded forwarded message preserving original signature sendFwdMemberMessage :: GroupMember -> GrpMsgForward -> VerifiedMsg 'Json -> CM ()