diff

2026-08-14 04:59:56 +00:00 · 2026-08-02 18:25:49 +00:00
parent 89c4986f4a
commit d31bd2073b
2 changed files with 49 additions and 51 deletions
@@ -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 ()
@@ -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 ()