dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-14 21:15:37 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: improve performance of marking chat items as read (#5290)

Browse Source 
* core: improve performance of marking chat items as read

* fix tests
This commit is contained in:
Evgeny
2024-12-01 13:11:30 +00:00
committed by GitHub
parent 98a3437f43
commit b8442d92a4
7 changed files with 117 additions and 136 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+9 -9
View File
@@ -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),
src/Simplex/Chat/Controller.hs
+1 -1
View File
@@ -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
src/Simplex/Chat/Store/Messages.hs
+104 -119
View File
@@ -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)
src/Simplex/Chat/Terminal/Output.hs
+2 -1
View File
@@ -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 =
tests/ChatTests/Direct.hs
-2
View File
@@ -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")
tests/ChatTests/Groups.hs
-3
View File
@@ -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")
tests/ChatTests/Local.hs
+1 -1
View File
@@ -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"