diff --git a/docs/rfcs/2024-07-09-group-snd-status.md b/docs/rfcs/2024-07-09-group-snd-status.md new file mode 100644 index 0000000000..43f491880d --- /dev/null +++ b/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. diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 131fbb7089..786f065ae0 100644 --- a/src/Simplex/Chat.hs +++ b/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 () diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 9e0eccbbde..e59429b7ea 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/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) diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 853d34995a..5d9f5a7619 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/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