From b8442d92a4817f95ff8fde6664e2c9312fc58f05 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 1 Dec 2024 13:11:30 +0000 Subject: [PATCH] core: improve performance of marking chat items as read (#5290) * core: improve performance of marking chat items as read * fix tests --- src/Simplex/Chat.hs | 18 +-- src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Store/Messages.hs | 223 +++++++++++++--------------- src/Simplex/Chat/Terminal/Output.hs | 3 +- tests/ChatTests/Direct.hs | 2 - tests/ChatTests/Groups.hs | 3 - tests/ChatTests/Local.hs | 2 +- 7 files changed, 117 insertions(+), 136 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index cc06d1b677..cc7fc992fb 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1250,13 +1250,13 @@ processChatCommand' vr = \case when (size' > 0) $ copyChunks r w size' APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId - APIChatRead chatRef@(ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of + APIChatRead chatRef@(ChatRef cType chatId) -> withUser $ \_ -> case cType of CTDirect -> do user <- withFastStore $ \db -> getUserByContactId db chatId ts <- liftIO getCurrentTime timedItems <- withFastStore' $ \db -> do - timedItems <- getDirectUnreadTimedItems db user chatId fromToIds - updateDirectChatItemsRead db user chatId fromToIds + timedItems <- getDirectUnreadTimedItems db user chatId + updateDirectChatItemsRead db user chatId setDirectChatItemsDeleteAt db user chatId timedItems ts forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt ok user @@ -1264,14 +1264,14 @@ processChatCommand' vr = \case user <- withFastStore $ \db -> getUserByGroupId db chatId ts <- liftIO getCurrentTime timedItems <- withFastStore' $ \db -> do - timedItems <- getGroupUnreadTimedItems db user chatId fromToIds - updateGroupChatItemsRead db user chatId fromToIds + timedItems <- getGroupUnreadTimedItems db user chatId + updateGroupChatItemsRead db user chatId setGroupChatItemsDeleteAt db user chatId timedItems ts forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt ok user CTLocal -> do user <- withFastStore $ \db -> getUserByNoteFolderId db chatId - withFastStore' $ \db -> updateLocalChatItemsRead db user chatId fromToIds + withFastStore' $ \db -> updateLocalChatItemsRead db user chatId ok user CTContactRequest -> pure $ chatCmdError Nothing "not supported" CTContactConnection -> pure $ chatCmdError Nothing "not supported" @@ -1471,7 +1471,7 @@ processChatCommand' vr = \case withCurrentCall contactId $ \user ct Call {chatItemId, callState} -> case callState of CallInvitationReceived {} -> do let aciContent = ACIContent SMDRcv $ CIRcvCall CISCallRejected 0 - withFastStore' $ \db -> updateDirectChatItemsRead db user contactId $ Just (chatItemId, chatItemId) + withFastStore' $ \db -> setDirectChatItemRead db user contactId chatItemId timed_ <- contactCITimed ct updateDirectChatItemView user ct chatItemId aciContent False False timed_ Nothing forM_ (timed_ >>= timedDeleteAt') $ @@ -1487,7 +1487,7 @@ processChatCommand' vr = \case callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey} aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0 (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XCallOffer callId offer) - withFastStore' $ \db -> updateDirectChatItemsRead db user contactId $ Just (chatItemId, chatItemId) + withFastStore' $ \db -> setDirectChatItemRead db user contactId chatItemId updateDirectChatItemView user ct chatItemId aciContent False False Nothing $ Just msgId pure $ Just call {callState = callState'} _ -> throwChatError . CECallState $ callStateTag callState @@ -8277,7 +8277,7 @@ chatCommandP = "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), "/_read user " *> (APIUserRead <$> A.decimal), "/read user" $> UserRead, - "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))), + "/_read chat " *> (APIChatRead <$> chatRefP), "/_read chat items " *> (APIChatItemsRead <$> chatRefP <*> _strP), "/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP), "/_delete " *> (APIDeleteChat <$> chatRefP <*> chatDeleteMode), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index b6f8d5e093..d208efce77 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -309,7 +309,7 @@ data ChatCommand | APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int} | APIUserRead UserId | UserRead - | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) + | APIChatRead ChatRef | APIChatItemsRead ChatRef (NonEmpty ChatItemId) | APIChatUnread ChatRef Bool | APIDeleteChat ChatRef ChatDeleteMode -- currently delete mode settings are only applied to direct chats diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index f94cbbd81d..cff7f6b785 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -62,6 +62,7 @@ module Simplex.Chat.Store.Messages updateDirectChatItemsRead, getDirectUnreadTimedItems, updateDirectChatItemsReadList, + setDirectChatItemRead, setDirectChatItemsDeleteAt, updateGroupChatItemsRead, getGroupUnreadTimedItems, @@ -1670,61 +1671,61 @@ toChatItemRef = \case (itemId, Nothing, Nothing, Just folderId) -> Right (ChatRef CTLocal folderId, itemId) (itemId, _, _, _) -> Left $ SEBadChatItem itemId Nothing -updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO () -updateDirectChatItemsRead db User {userId} contactId itemsRange_ = do +updateDirectChatItemsRead :: DB.Connection -> User -> ContactId -> IO () +updateDirectChatItemsRead db User {userId} contactId = do currentTs <- getCurrentTime - case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, contactId, fromItemId, toItemId, CISRcvNew) - _ -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND contact_id = ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, contactId, CISRcvNew) + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, contactId, CISRcvNew) -getDirectUnreadTimedItems :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] -getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND contact_id = ? - AND chat_item_id >= ? AND chat_item_id <= ? - AND item_status = ? - AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - AND (item_live IS NULL OR item_live = ?) - |] - (userId, contactId, fromItemId, toItemId, CISRcvNew, False) - _ -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND contact_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - |] - (userId, contactId, CISRcvNew) +getDirectUnreadTimedItems :: DB.Connection -> User -> ContactId -> IO [(ChatItemId, Int)] +getDirectUnreadTimedItems db User {userId} contactId = + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND contact_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + |] + (userId, contactId, CISRcvNew) updateDirectChatItemsReadList :: DB.Connection -> User -> ContactId -> NonEmpty ChatItemId -> IO [(ChatItemId, Int)] -updateDirectChatItemsReadList db user contactId itemIds = do - catMaybes . L.toList <$> mapM getUpdateDirectItem itemIds +updateDirectChatItemsReadList db user@User {userId} contactId itemIds = do + currentTs <- getCurrentTime + catMaybes . L.toList <$> mapM (getUpdateDirectItem currentTs) itemIds where - getUpdateDirectItem chatItemId = do - let itemsRange = Just (chatItemId, chatItemId) - timedItem <- maybeFirstRow id $ getDirectUnreadTimedItems db user contactId itemsRange - updateDirectChatItemsRead db user contactId itemsRange - pure timedItem + getUpdateDirectItem currentTs itemId = do + ttl_ <- maybeFirstRow fromOnly getUnreadTimedItem + setDirectChatItemRead_ db user contactId itemId currentTs + pure $ (itemId,) <$> ttl_ + where + getUnreadTimedItem = + DB.query + db + [sql| + SELECT timed_ttl + FROM chat_items + WHERE user_id = ? AND contact_id = ? AND item_status = ? AND chat_item_id = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + |] + (userId, contactId, CISRcvNew, itemId) + +setDirectChatItemRead :: DB.Connection -> User -> ContactId -> ChatItemId -> IO () +setDirectChatItemRead db user contactId itemId = + setDirectChatItemRead_ db user contactId itemId =<< getCurrentTime + +setDirectChatItemRead_ :: DB.Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO () +setDirectChatItemRead_ db User {userId} contactId itemId currentTs = + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND contact_id = ? AND item_status = ? AND chat_item_id = ? + |] + (CISRcvRead, currentTs, userId, contactId, CISRcvNew, itemId) setDirectChatItemsDeleteAt :: DB.Connection -> User -> ContactId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)] setDirectChatItemsDeleteAt db User {userId} contactId itemIds currentTs = forM itemIds $ \(chatItemId, ttl) -> do @@ -1735,61 +1736,55 @@ setDirectChatItemsDeleteAt db User {userId} contactId itemIds currentTs = forM i (deleteAt, userId, contactId, chatItemId) pure (chatItemId, deleteAt) -updateGroupChatItemsRead :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO () -updateGroupChatItemsRead db User {userId} groupId itemsRange_ = do +updateGroupChatItemsRead :: DB.Connection -> User -> GroupId -> IO () +updateGroupChatItemsRead db User {userId} groupId = do currentTs <- getCurrentTime - case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, groupId, fromItemId, toItemId, CISRcvNew) - _ -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND group_id = ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, groupId, CISRcvNew) + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, groupId, CISRcvNew) -getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)] -getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND group_id = ? - AND chat_item_id >= ? AND chat_item_id <= ? - AND item_status = ? - AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - AND (item_live IS NULL OR item_live = ?) - |] - (userId, groupId, fromItemId, toItemId, CISRcvNew, False) - _ -> - DB.query - db - [sql| - SELECT chat_item_id, timed_ttl - FROM chat_items - WHERE user_id = ? AND group_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL - |] - (userId, groupId, CISRcvNew) +getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> IO [(ChatItemId, Int)] +getGroupUnreadTimedItems db User {userId} groupId = + DB.query + db + [sql| + SELECT chat_item_id, timed_ttl + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + |] + (userId, groupId, CISRcvNew) updateGroupChatItemsReadList :: DB.Connection -> User -> GroupId -> NonEmpty ChatItemId -> IO [(ChatItemId, Int)] -updateGroupChatItemsReadList db user groupId itemIds = do - catMaybes . L.toList <$> mapM getUpdateGroupItem itemIds +updateGroupChatItemsReadList db User {userId} groupId itemIds = do + currentTs <- getCurrentTime + catMaybes . L.toList <$> mapM (getUpdateGroupItem currentTs) itemIds where - getUpdateGroupItem chatItemId = do - let itemsRange = Just (chatItemId, chatItemId) - timedItem <- maybeFirstRow id $ getGroupUnreadTimedItems db user groupId itemsRange - updateGroupChatItemsRead db user groupId itemsRange - pure timedItem + getUpdateGroupItem currentTs itemId = do + ttl_ <- maybeFirstRow fromOnly getUnreadTimedItem + setItemRead + pure $ (itemId,) <$> ttl_ + where + getUnreadTimedItem = + DB.query + db + [sql| + SELECT timed_ttl + FROM chat_items + WHERE user_id = ? AND group_id = ? AND item_status = ? AND chat_item_id = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + |] + (userId, groupId, CISRcvNew, itemId) + setItemRead = + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND item_status = ? AND chat_item_id = ? + |] + (CISRcvRead, currentTs, userId, groupId, CISRcvNew, itemId) setGroupChatItemsDeleteAt :: DB.Connection -> User -> GroupId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)] setGroupChatItemsDeleteAt db User {userId} groupId itemIds currentTs = forM itemIds $ \(chatItemId, ttl) -> do @@ -1800,26 +1795,16 @@ setGroupChatItemsDeleteAt db User {userId} groupId itemIds currentTs = forM item (deleteAt, userId, groupId, chatItemId) pure (chatItemId, deleteAt) -updateLocalChatItemsRead :: DB.Connection -> User -> NoteFolderId -> Maybe (ChatItemId, ChatItemId) -> IO () -updateLocalChatItemsRead db User {userId} noteFolderId itemsRange_ = do +updateLocalChatItemsRead :: DB.Connection -> User -> NoteFolderId -> IO () +updateLocalChatItemsRead db User {userId} noteFolderId = do currentTs <- getCurrentTime - case itemsRange_ of - Just (fromItemId, toItemId) -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND note_folder_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, noteFolderId, fromItemId, toItemId, CISRcvNew) - _ -> - DB.execute - db - [sql| - UPDATE chat_items SET item_status = ?, updated_at = ? - WHERE user_id = ? AND note_folder_id = ? AND item_status = ? - |] - (CISRcvRead, currentTs, userId, noteFolderId, CISRcvNew) + DB.execute + db + [sql| + UPDATE chat_items SET item_status = ?, updated_at = ? + WHERE user_id = ? AND note_folder_id = ? AND item_status = ? + |] + (CISRcvRead, currentTs, userId, noteFolderId, CISRcvNew) type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol) diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 0ead850b86..37c5c039c1 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -164,7 +165,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha (True, CISRcvNew) -> do let itemId = chatItemId' ci chatRef = chatInfoToRef chat - void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc + void $ runReaderT (runExceptT $ processChatCommand (APIChatItemsRead chatRef [itemId])) cc _ -> pure () logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s getRemoteUser rhId = diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 25bcc8659b..72a28c3ada 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -217,8 +217,6 @@ testAddContact = versionTestMatrix2 runTestAddContact -- search alice #$> ("/_get chat @2 count=100 search=ello ther", chat, [(1, "hello there 🙂"), (0, "hello there")]) -- read messages - alice #$> ("/_read chat @2 from=1 to=100", id, "ok") - bob #$> ("/_read chat @2 from=1 to=100", id, "ok") alice #$> ("/_read chat @2", id, "ok") bob #$> ("/_read chat @2", id, "ok") alice #$> ("/read user", id, "ok") diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index a1d9951088..89462b2b61 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -353,9 +353,6 @@ testGroupShared alice bob cath checkMessages directConnections = do bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "added cath (Catherine)"), (0, "connected"), (0, "hello"), (1, "hi there"), (0, "hey team")]) cath @@@ [("@bob", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")] cath #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "connected"), (0, "hello"), (0, "hi there"), (1, "hey team")]) - alice #$> ("/_read chat #1 from=1 to=100", id, "ok") - bob #$> ("/_read chat #1 from=1 to=100", id, "ok") - cath #$> ("/_read chat #1 from=1 to=100", id, "ok") alice #$> ("/_read chat #1", id, "ok") bob #$> ("/_read chat #1", id, "ok") cath #$> ("/_read chat #1", id, "ok") diff --git a/tests/ChatTests/Local.hs b/tests/ChatTests/Local.hs index 40df02252d..c17b893be1 100644 --- a/tests/ChatTests/Local.hs +++ b/tests/ChatTests/Local.hs @@ -41,7 +41,7 @@ testNotes tmp = withNewTestChat tmp "alice" aliceProfile $ \alice -> do alice ##> "/? keep" alice <# "* keep in mind" - alice #$> ("/_read chat *1 from=1 to=100", id, "ok") + alice #$> ("/_read chat *1", id, "ok") alice ##> "/_unread chat *1 on" alice <## "ok"