core: differentiate inactive and forwarded group snd statuses (#4420)

* core: GroupSndStatus

* rfc

* encoding, db apis

* pending, forwarded statuses

* encoding

docs/rfcs/2024-07-09-group-snd-status.md

@@ -0,0 +1,47 @@
+# Group messages sending status
+
+## Problem
+
+Currently in UI chat item info:
+- There's no differentiation between sent messages and pending messages.
+- There's no differentiation between pending messages reasons (establishing connection or member inactivity).
+  - Since the former is usually not a case due to group forwarding, this can be ignored.
+- Messages to be forwarded by admin are not accounted.
+
+## Solution
+
+Differentiate new statuses for group sending in chat item info:
+- forwarded
+- inactive / pending
+
+Option 1 is to add statuses to CIStatus / ACIStatus types.
+
+Pros:
+- simple.
+
+Cons:
+- further muddies type of statuses for chat item with impossible states / different dimension, as it's not applicable directly to chat item but a technicality of group sending process.
+
+Option 2 is to create a new type, GroupSndStatus.
+
+```haskell
+data GroupSndStatus
+  = GSSNew
+  | GSSForwarded
+  | GSSInactive
+  | GSSSent
+  | GSSRcvd {msgRcptStatus :: MsgReceiptStatus}
+  | GSSError {agentError :: SndError}
+  | GSSWarning {agentError :: SndError}
+  | GSSInvalid {text :: Text}
+```
+
+Most statuses repeat CIStatus sending statuses, with addition of forwarded and inactive for group sending process.
+
+Pros:
+- separates concerns of chat item presentation from group sending process.
+- allows future extension without further muddying CIStatus types.
+
+Cons:
+- more work.
+- requires backwards compatible decoding with ACIStatus to read previous data from db.

src/Simplex/Chat.hs

@@ -2786,14 +2786,19 @@ processChatCommand' vr = \case
               (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer g (length $ filter memberCurrent ms)
               timed_ <- sndGroupCITimed live gInfo itemTTL
               (msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ itemForwarded fInv_ timed_ live
-              (msg, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
+              (msg, groupSndResult) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
               ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ itemForwarded timed_ live
-              withStore' $ \db ->
-                forM_ sentToMembers $ \GroupMember {groupMemberId} ->
-                  createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew
+              withStore' $ \db -> do
+                let GroupSndResult {sentTo, pending, forwarded} = groupSndResult
+                createMemberSndStatuses db ci sentTo GSSNew
+                createMemberSndStatuses db ci forwarded GSSForwarded
+                createMemberSndStatuses db ci pending GSSInactive
               forM_ (timed_ >>= timedDeleteAt') $
                 startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
               pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
+              where
+                createMemberSndStatuses db ci ms' gss =
+                  forM_ ms' $ \GroupMember {groupMemberId} -> createGroupSndStatus db (chatItemId' ci) groupMemberId gss
         notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f))
         setupSndFileTransfer :: Group -> Int -> CM (Maybe (FileInvitation, CIFile 'MDSnd))
         setupSndFileTransfer g n = forM file_ $ \file -> do
@@ -4574,7 +4579,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
         continued <- continueSending connEntity conn
         sentMsgDeliveryEvent conn msgId
         checkSndInlineFTComplete conn msgId
-        updateGroupItemStatus gInfo m conn msgId (CISSndSent SSPComplete) (Just $ isJust proxy)
+        updateGroupItemStatus gInfo m conn msgId GSSSent (Just $ isJust proxy)
         when continued $ sendPendingGroupMessages user m conn
       SWITCH qd phase cStats -> do
         toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
@@ -4615,15 +4620,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
         continued <- continueSending connEntity conn
         when continued $ sendPendingGroupMessages user m conn
       MWARN msgId err -> do
-        withStore' $ \db -> updateGroupItemErrorStatus db msgId (groupMemberId' m) (CISSndWarning $ agentSndError err)
+        withStore' $ \db -> updateGroupItemErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err)
         processConnMWARN connEntity conn err
       MERR msgId err -> do
-        withStore' $ \db -> updateGroupItemErrorStatus db msgId (groupMemberId' m) (CISSndError $ agentSndError err)
+        withStore' $ \db -> updateGroupItemErrorStatus db msgId (groupMemberId' m) (GSSError $ agentSndError err)
         -- group errors are silenced to reduce load on UI event log
         -- toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
         processConnMERR connEntity conn err
       MERRS msgIds err -> do
-        let newStatus = CISSndError $ agentSndError err
+        let newStatus = GSSError $ agentSndError err
         -- error cannot be AUTH error here
         withStore' $ \db -> forM_ msgIds $ \msgId ->
           updateGroupItemErrorStatus db msgId (groupMemberId' m) newStatus `catchAll_` pure ()
@@ -4634,7 +4639,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
       -- TODO add debugging output
       _ -> pure ()
       where
-        updateGroupItemErrorStatus :: DB.Connection -> AgentMsgId -> GroupMemberId -> CIStatus 'MDSnd -> IO ()
+        updateGroupItemErrorStatus :: DB.Connection -> AgentMsgId -> GroupMemberId -> GroupSndStatus -> IO ()
         updateGroupItemErrorStatus db msgId groupMemberId newStatus = do
           chatItemId_ <- getChatItemIdByAgentMsgId db connId msgId
           forM_ chatItemId_ $ \itemId -> updateGroupMemSndStatus' db itemId groupMemberId newStatus
@@ -6290,7 +6295,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
       checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure ()
       forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
         withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
-        updateGroupItemStatus gInfo m conn agentMsgId (CISSndRcvd msgRcptStatus SSPComplete) Nothing
+        updateGroupItemStatus gInfo m conn agentMsgId (GSSRcvd msgRcptStatus) Nothing
 
     updateDirectItemsStatus :: Contact -> Connection -> [AgentMsgId] -> CIStatus 'MDSnd -> CM ()
     updateDirectItemsStatus ct conn msgIds newStatus = do
@@ -6314,20 +6319,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
           | otherwise -> Just <$> updateDirectChatItemStatus db user ct itemId newStatus
         _ -> pure Nothing
 
-    updateGroupMemSndStatus :: ChatItemId -> GroupMemberId -> CIStatus 'MDSnd -> CM Bool
+    updateGroupMemSndStatus :: ChatItemId -> GroupMemberId -> GroupSndStatus -> CM Bool
     updateGroupMemSndStatus itemId groupMemberId newStatus =
       withStore' $ \db -> updateGroupMemSndStatus' db itemId groupMemberId newStatus
 
-    updateGroupMemSndStatus' :: DB.Connection -> ChatItemId -> GroupMemberId -> CIStatus 'MDSnd -> IO Bool
+    updateGroupMemSndStatus' :: DB.Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO Bool
     updateGroupMemSndStatus' db itemId groupMemberId newStatus =
       runExceptT (getGroupSndStatus db itemId groupMemberId) >>= \case
-        Right (CISSndRcvd _ _) -> pure False
+        Right (GSSRcvd _) -> pure False
         Right memStatus
           | memStatus == newStatus -> pure False
           | otherwise -> updateGroupSndStatus db itemId groupMemberId newStatus $> True
         _ -> pure False
 
-    updateGroupItemStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> Maybe Bool -> CM ()
+    updateGroupItemStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM ()
     updateGroupItemStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ =
       withStore' (\db -> getGroupChatItemByAgentMsgId db user groupId connId msgId) >>= \case
         Just (CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ SSPComplete}}) -> pure ()
@@ -6778,7 +6783,7 @@ deliverMessagesB msgReqs = do
 
 -- TODO combine profile update and message into one batch
 -- Take into account that it may not fit, and that we currently don't support sending multiple messages to the same connection in one call.
-sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, [GroupMember])
+sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResult)
 sendGroupMessage user gInfo members chatMsgEvent = do
   when shouldSendProfileUpdate $
     sendProfileUpdate `catchChatError` (\e -> toView (CRChatError (Just user) e))
@@ -6800,12 +6805,18 @@ sendGroupMessage user gInfo members chatMsgEvent = do
       currentTs <- liftIO getCurrentTime
       withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
 
-sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, [GroupMember])
+data GroupSndResult = GroupSndResult
+  { sentTo :: [GroupMember],
+    pending :: [GroupMember],
+    forwarded :: [GroupMember]
+  }
+
+sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResult)
 sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do
   msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId)
   recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members)
   let msgFlags = MsgFlags {notification = hasNotification $ toCMEventTag chatMsgEvent}
-      (toSend, pending, _, dups) = foldr addMember ([], [], S.empty, 0 :: Int) recipientMembers
+      (toSend, pending, forwarded, _, dups) = foldr addMember ([], [], [], S.empty, 0 :: Int) recipientMembers
       -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here
       msgReqs = map (\(_, conn) -> (conn, msgFlags, msgBody, msgId)) toSend
   when (dups /= 0) $ logError $ "sendGroupMessage: " <> tshow dups <> " duplicate members"
@@ -6813,8 +6824,13 @@ sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do
   let errors = lefts delivered
   unless (null errors) $ toView $ CRChatErrors (Just user) errors
   stored <- lift . withStoreBatch' $ \db -> map (\m -> createPendingGroupMessage db (groupMemberId' m) msgId Nothing) pending
-  let sentToMembers = filterSent delivered toSend fst <> filterSent stored pending id
-  pure (msg, sentToMembers)
+  let gsr =
+        GroupSndResult
+          { sentTo = filterSent delivered toSend fst,
+            pending = filterSent stored pending id,
+            forwarded
+          }
+  pure (msg, gsr)
   where
     shuffleMembers :: [GroupMember] -> IO [GroupMember]
     shuffleMembers ms = do
@@ -6822,12 +6838,13 @@ sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do
       liftM2 (<>) (shuffle adminMs) (shuffle otherMs)
       where
         isAdmin GroupMember {memberRole} = memberRole >= GRAdmin
-    addMember m acc@(toSend, pending, !mIds, !dups) = case memberSendAction chatMsgEvent members m of
+    addMember m acc@(toSend, pending, forwarded, !mIds, !dups) = case memberSendAction chatMsgEvent members m of
       Just a
-        | mId `S.member` mIds -> (toSend, pending, mIds, dups + 1)
+        | mId `S.member` mIds -> (toSend, pending, forwarded, mIds, dups + 1)
         | otherwise -> case a of
-            MSASend conn -> ((m, conn) : toSend, pending, mIds', dups)
-            MSAPending -> (toSend, m : pending, mIds', dups)
+            MSASend conn -> ((m, conn) : 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
@@ -6835,7 +6852,7 @@ sendGroupMessage' user GroupInfo {groupId} members chatMsgEvent = do
     filterSent :: [Either ChatError a] -> [mem] -> (mem -> GroupMember) -> [GroupMember]
     filterSent rs ms mem = [mem m | (Right _, m) <- zip rs ms]
 
-data MemberSendAction = MSASend Connection | MSAPending
+data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded
 
 memberSendAction :: ChatMsgEvent e -> [GroupMember] -> GroupMember -> Maybe MemberSendAction
 memberSendAction chatMsgEvent members m@GroupMember {invitedByGroupMemberId} = case memberConn m of
@@ -6847,7 +6864,7 @@ memberSendAction chatMsgEvent members m@GroupMember {invitedByGroupMemberId} = c
     | otherwise -> pendingOrForwarded
   where
     pendingOrForwarded
-      | forwardSupported && isForwardedGroupMsg chatMsgEvent = Nothing
+      | forwardSupported && isForwardedGroupMsg chatMsgEvent = Just MSAForwarded
       | isXGrpMsgForward chatMsgEvent = Nothing
       | otherwise = Just MSAPending
       where
@@ -6872,6 +6889,7 @@ sendGroupMemberMessage user m@GroupMember {groupMemberId} chatMsgEvent groupId i
     messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction chatMsgEvent [m] m) $ \case
       MSASend conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver
       MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_
+      MSAForwarded -> pure ()
 
 -- TODO ensure order - pending messages interleave with user input messages
 sendPendingGroupMessages :: User -> GroupMember -> Connection -> CM ()

src/Simplex/Chat/Messages.hs

@@ -873,7 +873,7 @@ ciCreateStatus content = case msgDirection @d of
   SMDSnd -> ciStatusNew
   SMDRcv -> if ciRequiresAttention content then ciStatusNew else CISRcvRead
 
-membersGroupItemStatus :: [(CIStatus 'MDSnd, Int)] -> CIStatus 'MDSnd
+membersGroupItemStatus :: [(GroupSndStatus, Int)] -> CIStatus 'MDSnd
 membersGroupItemStatus memStatusCounts
   | rcvdOk == total = CISSndRcvd MROk SSPComplete
   | rcvdOk + rcvdBad == total = CISSndRcvd MRBadMsgHash SSPComplete
@@ -884,9 +884,9 @@ membersGroupItemStatus memStatusCounts
   | otherwise = CISSndNew
   where
     total = sum $ map snd memStatusCounts
-    rcvdOk = fromMaybe 0 $ lookup (CISSndRcvd MROk SSPComplete) memStatusCounts
-    rcvdBad = fromMaybe 0 $ lookup (CISSndRcvd MRBadMsgHash SSPComplete) memStatusCounts
-    sent = fromMaybe 0 $ lookup (CISSndSent SSPComplete) memStatusCounts
+    rcvdOk = fromMaybe 0 $ lookup (GSSRcvd MROk) memStatusCounts
+    rcvdBad = fromMaybe 0 $ lookup (GSSRcvd MRBadMsgHash) memStatusCounts
+    sent = fromMaybe 0 $ lookup GSSSent memStatusCounts
 
 data SndCIStatusProgress
   = SSPPartial
@@ -903,6 +903,47 @@ instance StrEncoding SndCIStatusProgress where
       "complete" -> pure SSPComplete
       _ -> fail "bad SndCIStatusProgress"
 
+data GroupSndStatus
+  = GSSNew
+  | GSSForwarded
+  | GSSInactive
+  | GSSSent
+  | GSSRcvd {msgRcptStatus :: MsgReceiptStatus}
+  | GSSError {agentError :: SndError}
+  | GSSWarning {agentError :: SndError}
+  | GSSInvalid {text :: Text}
+
+deriving instance Eq GroupSndStatus
+
+deriving instance Show GroupSndStatus
+
+-- Preserve CIStatus encoding for backwards compatibility
+instance StrEncoding GroupSndStatus where
+  strEncode = \case
+    GSSNew -> "snd_new"
+    GSSForwarded -> "snd_forwarded"
+    GSSInactive -> "snd_inactive"
+    GSSSent -> "snd_sent complete"
+    GSSRcvd msgRcptStatus -> "snd_rcvd " <> strEncode msgRcptStatus <> " complete"
+    GSSError sndErr -> "snd_error " <> strEncode sndErr
+    GSSWarning sndErr -> "snd_warning " <> strEncode sndErr
+    GSSInvalid {} -> "invalid"
+  strP =
+    (statusP <* A.endOfInput) -- see ACIStatus decoding
+      <|> (GSSInvalid . safeDecodeUtf8 <$> A.takeByteString)
+    where
+      statusP =
+        A.takeTill (== ' ') >>= \case
+          "snd_new" -> pure GSSNew
+          "snd_forwarded" -> pure GSSForwarded
+          "snd_inactive" -> pure GSSInactive
+          "snd_sent" -> GSSSent <$ " complete"
+          "snd_rcvd" -> GSSRcvd <$> (_strP <* " complete")
+          "snd_error_auth" -> pure $ GSSError SndErrAuth
+          "snd_error" -> GSSError <$> (A.space *> strP)
+          "snd_warning" -> GSSWarning <$> (A.space *> strP)
+          _ -> fail "bad status"
+
 type ChatItemId = Int64
 
 type ChatItemTs = UTCTime
@@ -1176,7 +1217,7 @@ mkItemVersion ChatItem {content, meta} = version <$> ciMsgContent content
 
 data MemberDeliveryStatus = MemberDeliveryStatus
   { groupMemberId :: GroupMemberId,
-    memberDeliveryStatus :: CIStatus 'MDSnd,
+    memberDeliveryStatus :: GroupSndStatus,
     sentViaProxy :: Maybe Bool
   }
   deriving (Eq, Show)
@@ -1234,6 +1275,12 @@ instance (Typeable d, MsgDirectionI d) => FromField (CIStatus d) where fromField
 
 instance FromField ACIStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
 
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GSS") ''GroupSndStatus)
+
+instance ToField GroupSndStatus where toField = toField . decodeLatin1 . strEncode
+
+instance FromField GroupSndStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
+
 $(JQ.deriveJSON defaultJSON ''MemberDeliveryStatus)
 
 $(JQ.deriveJSON defaultJSON ''ChatItemVersion)

src/Simplex/Chat/Store/Messages.hs

@@ -2531,14 +2531,14 @@ deleteCIModeration db GroupInfo {groupId} itemMemberId (Just sharedMsgId) =
     "DELETE FROM chat_item_moderations WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ?"
     (groupId, itemMemberId, sharedMsgId)
 
-createGroupSndStatus :: DB.Connection -> ChatItemId -> GroupMemberId -> CIStatus 'MDSnd -> IO ()
+createGroupSndStatus :: DB.Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO ()
 createGroupSndStatus db itemId memberId status =
   DB.execute
     db
     "INSERT INTO group_snd_item_statuses (chat_item_id, group_member_id, group_snd_item_status) VALUES (?,?,?)"
     (itemId, memberId, status)
 
-getGroupSndStatus :: DB.Connection -> ChatItemId -> GroupMemberId -> ExceptT StoreError IO (CIStatus 'MDSnd)
+getGroupSndStatus :: DB.Connection -> ChatItemId -> GroupMemberId -> ExceptT StoreError IO GroupSndStatus
 getGroupSndStatus db itemId memberId =
   ExceptT . firstRow fromOnly (SENoGroupSndStatus itemId memberId) $
     DB.query
@@ -2551,7 +2551,7 @@ getGroupSndStatus db itemId memberId =
       |]
       (itemId, memberId)
 
-updateGroupSndStatus :: DB.Connection -> ChatItemId -> GroupMemberId -> CIStatus 'MDSnd -> IO ()
+updateGroupSndStatus :: DB.Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO ()
 updateGroupSndStatus db itemId memberId status = do
   currentTs <- liftIO getCurrentTime
   DB.execute
@@ -2589,7 +2589,7 @@ getGroupSndStatuses db itemId =
     memStatus (groupMemberId, memberDeliveryStatus, sentViaProxy) =
       MemberDeliveryStatus {groupMemberId, memberDeliveryStatus, sentViaProxy}
 
-getGroupSndStatusCounts :: DB.Connection -> ChatItemId -> IO [(CIStatus 'MDSnd, Int)]
+getGroupSndStatusCounts :: DB.Connection -> ChatItemId -> IO [(GroupSndStatus, Int)]
 getGroupSndStatusCounts db itemId =
   DB.query
     db