mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-28 09:44:15 +00:00
core: optimize marking chat items as read, batch API (#4843)
* core: optimize marking chat items as read * tests, ui types * ios: fix api * refactor
This commit is contained in:
Evgeny
+33
-16
@@ -55,9 +55,9 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay, nominalDiffTimeToSeconds)
|
||||
import Data.Time.Clock.System (systemToUTCTime)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as V4
|
||||
import Data.Word (Word32)
|
||||
import qualified Database.SQLite.Simple as SQL
|
||||
import Simplex.Chat.Archive
|
||||
import Simplex.Chat.Call
|
||||
@@ -115,7 +115,7 @@ import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (base64P)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), EntityId, ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolServer, ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), ErrorType (..), MsgBody, MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolServer, ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer, userProtocol)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.ServiceScheme (ServiceScheme (..))
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
@@ -1114,26 +1114,24 @@ 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 cType chatId) fromToIds -> withUser $ \_ -> case cType of
|
||||
APIChatRead chatRef@(ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of
|
||||
CTDirect -> do
|
||||
user <- withFastStore $ \db -> getUserByContactId db chatId
|
||||
timedItems <- withFastStore' $ \db -> getDirectUnreadTimedItems db user chatId fromToIds
|
||||
ts <- liftIO getCurrentTime
|
||||
forM_ timedItems $ \(itemId, ttl) -> do
|
||||
let deleteAt = addUTCTime (realToFrac ttl) ts
|
||||
withFastStore' $ \db -> setDirectChatItemDeleteAt db user chatId itemId deleteAt
|
||||
startProximateTimedItemThread user (ChatRef CTDirect chatId, itemId) deleteAt
|
||||
withFastStore' $ \db -> updateDirectChatItemsRead db user chatId fromToIds
|
||||
timedItems <- withFastStore' $ \db -> do
|
||||
timedItems <- getDirectUnreadTimedItems db user chatId fromToIds
|
||||
updateDirectChatItemsRead db user chatId fromToIds
|
||||
setDirectChatItemsDeleteAt db user chatId timedItems ts
|
||||
forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt
|
||||
ok user
|
||||
CTGroup -> do
|
||||
user@User {userId} <- withFastStore $ \db -> getUserByGroupId db chatId
|
||||
timedItems <- withFastStore' $ \db -> getGroupUnreadTimedItems db user chatId fromToIds
|
||||
user <- withFastStore $ \db -> getUserByGroupId db chatId
|
||||
ts <- liftIO getCurrentTime
|
||||
forM_ timedItems $ \(itemId, ttl) -> do
|
||||
let deleteAt = addUTCTime (realToFrac ttl) ts
|
||||
withFastStore' $ \db -> setGroupChatItemDeleteAt db user chatId itemId deleteAt
|
||||
startProximateTimedItemThread user (ChatRef CTGroup chatId, itemId) deleteAt
|
||||
withFastStore' $ \db -> updateGroupChatItemsRead db userId chatId fromToIds
|
||||
timedItems <- withFastStore' $ \db -> do
|
||||
timedItems <- getGroupUnreadTimedItems db user chatId fromToIds
|
||||
updateGroupChatItemsRead db user chatId fromToIds
|
||||
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
|
||||
@@ -1141,6 +1139,24 @@ processChatCommand' vr = \case
|
||||
ok user
|
||||
CTContactRequest -> pure $ chatCmdError Nothing "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError Nothing "not supported"
|
||||
APIChatItemsRead chatRef@(ChatRef cType chatId) itemIds -> withUser $ \_ -> case cType of
|
||||
CTDirect -> do
|
||||
user <- withFastStore $ \db -> getUserByContactId db chatId
|
||||
timedItems <- withFastStore' $ \db -> do
|
||||
timedItems <- updateDirectChatItemsReadList db user chatId itemIds
|
||||
setDirectChatItemsDeleteAt db user chatId timedItems =<< getCurrentTime
|
||||
forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt
|
||||
ok user
|
||||
CTGroup -> do
|
||||
user <- withFastStore $ \db -> getUserByGroupId db chatId
|
||||
timedItems <- withFastStore' $ \db -> do
|
||||
timedItems <- updateGroupChatItemsReadList db user chatId itemIds
|
||||
setGroupChatItemsDeleteAt db user chatId timedItems =<< getCurrentTime
|
||||
forM_ timedItems $ \(itemId, deleteAt) -> startProximateTimedItemThread user (chatRef, itemId) deleteAt
|
||||
ok user
|
||||
CTLocal -> pure $ chatCmdError Nothing "not supported"
|
||||
CTContactRequest -> pure $ chatCmdError Nothing "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError Nothing "not supported"
|
||||
APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of
|
||||
CTDirect -> do
|
||||
withFastStore $ \db -> do
|
||||
@@ -7873,6 +7889,7 @@ chatCommandP =
|
||||
"/_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 items " *> (APIChatItemsRead <$> chatRefP <*> _strP),
|
||||
"/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP),
|
||||
"/_delete " *> (APIDeleteChat <$> chatRefP <*> chatDeleteMode),
|
||||
"/_clear chat " *> (APIClearChat <$> chatRefP),
|
||||
|
||||
@@ -302,6 +302,7 @@ data ChatCommand
|
||||
| APIUserRead UserId
|
||||
| UserRead
|
||||
| APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId))
|
||||
| APIChatItemsRead ChatRef (NonEmpty ChatItemId)
|
||||
| APIChatUnread ChatRef Bool
|
||||
| APIDeleteChat ChatRef ChatDeleteMode -- currently delete mode settings are only applied to direct chats
|
||||
| APIClearChat ChatRef
|
||||
|
||||
@@ -60,10 +60,12 @@ module Simplex.Chat.Store.Messages
|
||||
deleteLocalChatItem,
|
||||
updateDirectChatItemsRead,
|
||||
getDirectUnreadTimedItems,
|
||||
setDirectChatItemDeleteAt,
|
||||
updateDirectChatItemsReadList,
|
||||
setDirectChatItemsDeleteAt,
|
||||
updateGroupChatItemsRead,
|
||||
getGroupUnreadTimedItems,
|
||||
setGroupChatItemDeleteAt,
|
||||
updateGroupChatItemsReadList,
|
||||
setGroupChatItemsDeleteAt,
|
||||
updateLocalChatItemsRead,
|
||||
getChatRefViaItemId,
|
||||
getChatItemVersions,
|
||||
@@ -126,7 +128,9 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Either (fromRight, rights)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)
|
||||
import Data.Ord (Down (..), comparing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@@ -1339,15 +1343,27 @@ getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRan
|
||||
|]
|
||||
(userId, contactId, CISRcvNew)
|
||||
|
||||
setDirectChatItemDeleteAt :: DB.Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO ()
|
||||
setDirectChatItemDeleteAt db User {userId} contactId chatItemId deleteAt =
|
||||
updateDirectChatItemsReadList :: DB.Connection -> User -> ContactId -> NonEmpty ChatItemId -> IO [(ChatItemId, Int)]
|
||||
updateDirectChatItemsReadList db user contactId itemIds = do
|
||||
catMaybes . L.toList <$> mapM getUpdateDirectItem 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
|
||||
|
||||
setDirectChatItemsDeleteAt :: DB.Connection -> User -> ContactId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)]
|
||||
setDirectChatItemsDeleteAt db User {userId} contactId itemIds currentTs = forM itemIds $ \(chatItemId, ttl) -> do
|
||||
let deleteAt = addUTCTime (realToFrac ttl) currentTs
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?"
|
||||
(deleteAt, userId, contactId, chatItemId)
|
||||
pure (chatItemId, deleteAt)
|
||||
|
||||
updateGroupChatItemsRead :: DB.Connection -> UserId -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateGroupChatItemsRead db userId groupId itemsRange_ = do
|
||||
updateGroupChatItemsRead :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateGroupChatItemsRead db User {userId} groupId itemsRange_ = do
|
||||
currentTs <- getCurrentTime
|
||||
case itemsRange_ of
|
||||
Just (fromItemId, toItemId) ->
|
||||
@@ -1392,12 +1408,24 @@ getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_
|
||||
|]
|
||||
(userId, groupId, CISRcvNew)
|
||||
|
||||
setGroupChatItemDeleteAt :: DB.Connection -> User -> GroupId -> ChatItemId -> UTCTime -> IO ()
|
||||
setGroupChatItemDeleteAt db User {userId} groupId chatItemId deleteAt =
|
||||
updateGroupChatItemsReadList :: DB.Connection -> User -> GroupId -> NonEmpty ChatItemId -> IO [(ChatItemId, Int)]
|
||||
updateGroupChatItemsReadList db user groupId itemIds = do
|
||||
catMaybes . L.toList <$> mapM getUpdateGroupItem 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
|
||||
|
||||
setGroupChatItemsDeleteAt :: DB.Connection -> User -> GroupId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)]
|
||||
setGroupChatItemsDeleteAt db User {userId} groupId itemIds currentTs = forM itemIds $ \(chatItemId, ttl) -> do
|
||||
let deleteAt = addUTCTime (realToFrac ttl) currentTs
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?"
|
||||
(deleteAt, userId, groupId, chatItemId)
|
||||
pure (chatItemId, deleteAt)
|
||||
|
||||
updateLocalChatItemsRead :: DB.Connection -> User -> NoteFolderId -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateLocalChatItemsRead db User {userId} noteFolderId itemsRange_ = do
|
||||
|
||||
Reference in New Issue
Block a user