core: optimize bulk chat item deletion (#1168)

* core: optimize bulk chat item deletion

* test file deletion

* refactor

* refactor
This commit is contained in:
JRoberts
2022-10-03 22:33:36 +01:00
committed by GitHub
parent e8ad216b26
commit cd6cad9a96
4 changed files with 153 additions and 126 deletions
+53 -85
View File
@@ -55,7 +55,7 @@ import Simplex.Chat.ProfileGenerator (generateRandomProfile)
import Simplex.Chat.Protocol
import Simplex.Chat.Store
import Simplex.Chat.Types
import Simplex.Chat.Util (lastMaybe, safeDecodeUtf8, uncurry3)
import Simplex.Chat.Util (safeDecodeUtf8, uncurry3)
import Simplex.Messaging.Agent as Agent
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), AgentDatabase (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
import Simplex.Messaging.Agent.Protocol
@@ -450,8 +450,7 @@ processChatCommand = \case
deleteCIFile user file =
forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
let fileInfo = CIFileInfo {fileId, fileStatus = AFS msgDirection fileStatus, filePath}
cancelFile user fileInfo `catchError` \_ -> pure ()
withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo
deleteFile user fileInfo
APIChatRead (ChatRef cType chatId) fromToIds -> withChatLock $ case cType of
CTDirect -> withStore' (\db -> updateDirectChatItemsRead db chatId fromToIds) $> CRCmdOk
CTGroup -> withStore' (\db -> updateGroupChatItemsRead db chatId fromToIds) $> CRCmdOk
@@ -462,12 +461,10 @@ processChatCommand = \case
ct@Contact {localDisplayName} <- withStore $ \db -> getContact db userId chatId
withStore' (\db -> getContactGroupNames db userId ct) >>= \case
[] -> do
filesInfo <- withStore' $ \db -> getContactFileInfo db userId ct
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
conns <- withStore $ \db -> getContactConnections db userId ct
withChatLock . procCmd $ do
forM_ filesInfo $ \fileInfo -> do
cancelFile user fileInfo `catchError` \_ -> pure ()
withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo
forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
forM_ conns $ \conn -> deleteAgentConnectionAsync user conn `catchError` \_ -> pure ()
-- functions below are called in separate transactions to prevent crashes on android
-- (possibly, race condition on integrity check?)
@@ -485,8 +482,9 @@ processChatCommand = \case
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId
let canDelete = memberRole (membership :: GroupMember) == GROwner || not (memberCurrent membership)
unless canDelete $ throwChatError CEGroupUserRole
void $ clearGroupContent user gInfo
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
withChatLock . procCmd $ do
forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel
forM_ members $ deleteMemberConnection user
-- functions below are called in separate transactions to prevent crashes on android
@@ -499,22 +497,26 @@ processChatCommand = \case
APIClearChat (ChatRef cType chatId) -> withUser $ \user@User {userId} -> case cType of
CTDirect -> do
ct <- withStore $ \db -> getContact db userId chatId
ciIdsAndFileInfo <- withStore' $ \db -> getContactChatItemIdsAndFileInfo db user chatId
forM_ ciIdsAndFileInfo $ \(itemId, _, fileInfo_) -> deleteDirectChatItem user ct (itemId, fileInfo_)
ct' <- case ciIdsAndFileInfo of
[] -> pure ct
_ -> do
let (_, lastItemTs, _) = last ciIdsAndFileInfo
withStore' $ \db -> updateContactTs db user ct lastItemTs
pure (ct :: Contact) {updatedAt = lastItemTs}
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
maxItemTs_ <- withStore' $ \db -> getContactMaxItemTs db user ct
forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
withStore' $ \db -> deleteContactCIs db user ct
ct' <- case maxItemTs_ of
Just ts -> do
withStore' $ \db -> updateContactTs db user ct ts
pure (ct :: Contact) {updatedAt = ts}
_ -> pure ct
pure $ CRChatCleared (AChatInfo SCTDirect (DirectChat ct'))
CTGroup -> do
gInfo <- withStore $ \db -> getGroupInfo db user chatId
lastItemTs_ <- clearGroupContent user gInfo
gInfo' <- case lastItemTs_ of
Just lastItemTs -> do
withStore' $ \db -> updateGroupTs db user gInfo lastItemTs
pure (gInfo :: GroupInfo) {updatedAt = lastItemTs}
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
maxItemTs_ <- withStore' $ \db -> getGroupMaxItemTs db user gInfo
forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
withStore' $ \db -> deleteGroupCIs db user gInfo
gInfo' <- case maxItemTs_ of
Just ts -> do
withStore' $ \db -> updateGroupTs db user gInfo ts
pure (gInfo :: GroupInfo) {updatedAt = ts}
_ -> pure gInfo
pure $ CRChatCleared (AChatInfo SCTGroup (GroupChat gInfo'))
CTContactConnection -> pure $ chatCmdError "not supported"
@@ -1074,12 +1076,6 @@ processChatCommand = \case
isReady ct =
let s = connStatus $ activeConn (ct :: Contact)
in s == ConnReady || s == ConnSndReady
clearGroupContent :: User -> GroupInfo -> m (Maybe UTCTime)
clearGroupContent user gInfo@GroupInfo {groupId} = do
ciIdsAndFileInfo <- withStore' $ \db -> getGroupChatItemIdsAndFileInfo db user groupId
forM_ ciIdsAndFileInfo $ \(itemId, _, itemDeleted, fileInfo_) ->
unless itemDeleted $ deleteGroupChatItem user gInfo (itemId, fileInfo_)
pure $ (\(_, lastItemTs, _, _) -> lastItemTs) <$> lastMaybe ciIdsAndFileInfo
withCurrentCall :: ContactId -> (UserId -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
withCurrentCall ctId action = withUser $ \user@User {userId} -> do
ct <- withStore $ \db -> getContact db userId ctId
@@ -1128,41 +1124,26 @@ setExpireCIs b = do
expire <- asks expireCIs
atomically $ writeTVar expire b
deleteDirectChatItem :: ChatMonad m => User -> Contact -> (ChatItemId, Maybe CIFileInfo) -> m ()
deleteDirectChatItem user@User {userId} ct (itemId, fileInfo_) = do
forM_ fileInfo_ $ \fileInfo -> do
cancelFile user fileInfo `catchError` \_ -> pure ()
withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo
void $ withStore $ \db -> deleteDirectChatItemLocal db userId ct itemId CIDMInternal
deleteGroupChatItem :: ChatMonad m => User -> GroupInfo -> (ChatItemId, Maybe CIFileInfo) -> m ()
deleteGroupChatItem user gInfo (itemId, fileInfo_) = do
forM_ fileInfo_ $ \fileInfo -> do
cancelFile user fileInfo `catchError` \_ -> pure ()
withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo
void $ withStore $ \db -> deleteGroupChatItemLocal db user gInfo itemId CIDMInternal
-- perform an action only if filesFolder is set (i.e. on mobile devices)
withFilesFolder :: ChatMonad m => (FilePath -> m ()) -> m ()
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
deleteFile :: ChatMonad m => FilePath -> CIFileInfo -> m ()
deleteFile filesFolder CIFileInfo {filePath} =
forM_ filePath $ \fPath -> do
let fsFilePath = filesFolder <> "/" <> fPath
removeFile fsFilePath `E.catch` \(_ :: E.SomeException) ->
removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure ()
cancelFile :: ChatMonad m => User -> CIFileInfo -> m ()
cancelFile user CIFileInfo {fileId, fileStatus = (AFS dir status)} =
unless (ciFileEnded status) $
case dir of
SMDSnd -> do
(ftm@FileTransferMeta {cancelled}, fts) <- withStore (\db -> getSndFileTransfer db user fileId)
unless cancelled $ cancelSndFile user ftm fts
SMDRcv -> do
ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId)
unless cancelled $ cancelRcvFileTransfer user ft
deleteFile :: forall m. ChatMonad m => User -> CIFileInfo -> m ()
deleteFile user CIFileInfo {filePath, fileId, fileStatus = (AFS dir status)} =
cancel' >> delete
where
cancel' = unless (ciFileEnded status) $
case dir of
SMDSnd -> do
(ftm@FileTransferMeta {cancelled}, fts) <- withStore (\db -> getSndFileTransfer db user fileId)
unless cancelled $ cancelSndFile user ftm fts
SMDRcv -> do
ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId)
unless cancelled $ cancelRcvFileTransfer user ft
delete = withFilesFolder $ \filesFolder ->
forM_ filePath $ \fPath -> do
let fsFilePath = filesFolder <> "/" <> fPath
removeFile fsFilePath `E.catch` \(_ :: E.SomeException) ->
removePathForcibly fsFilePath `E.catch` \(_ :: E.SomeException) -> pure ()
-- perform an action only if filesFolder is set (i.e. on mobile devices)
withFilesFolder :: (FilePath -> m ()) -> m ()
withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action
updateCallItemStatus :: ChatMonad m => UserId -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> m ()
updateCallItemStatus userId ct Call {chatItemId} receivedStatus msgId_ = do
@@ -1420,33 +1401,20 @@ subscribeUserConnections agentBatchSubscribe user = do
_ -> Just . ChatError . CEAgentNoSubResult $ AgentConnId connId
expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m ()
expireChatItems user@User {userId} ttl sync = do
expireChatItems user ttl sync = do
currentTs <- liftIO getCurrentTime
let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs
chats <- withStore' $ \db -> getChatsWithExpiredItems db user expirationDate
expire <- asks expireCIs
chatsLoop chats expirationDate expire
filesInfo <- withStore' $ \db -> getExpiredFileInfo db user expirationDate
loop filesInfo expirationDate expire
where
chatsLoop :: [ChatRef] -> UTCTime -> TVar Bool -> m ()
chatsLoop [] _ _ = pure ()
chatsLoop ((ChatRef cType chatId) : chats) expirationDate expire = continue $ do
case cType of
CTDirect -> do
ct <- withStore $ \db -> getContact db userId chatId
cis <- withStore' $ \db -> getContactExpiredCIs db user chatId expirationDate
ciLoop cis $ deleteDirectChatItem user ct
CTGroup -> do
gInfo <- withStore $ \db -> getGroupInfo db user chatId
cis <- withStore' $ \db -> getGroupExpiredCIs db user chatId expirationDate
ciLoop cis $ deleteGroupChatItem user gInfo
_ -> pure ()
chatsLoop chats expirationDate expire
where
ciLoop :: [(ChatItemId, Maybe CIFileInfo)] -> ((ChatItemId, Maybe CIFileInfo) -> m ()) -> m ()
ciLoop [] _ = pure ()
ciLoop (ci : cis) f = continue $ f ci >> ciLoop cis f
continue :: m () -> m ()
continue = if sync then id else \a -> whenM (readTVarIO expire) $ threadDelay 100000 >> a
loop :: [CIFileInfo] -> UTCTime -> TVar Bool -> m ()
loop [] expirationDate expire = continue expire $ withStore' (\db -> deleteExpiredCIs db user expirationDate)
loop (fileInfo : filesInfo) expirationDate expire = continue expire $ do
deleteFile user fileInfo
loop filesInfo expirationDate expire
continue :: TVar Bool -> m () -> m ()
continue expire = if sync then id else \a -> whenM (readTVarIO expire) $ threadDelay 100000 >> a
processAgentMessage :: forall m. ChatMonad m => Maybe User -> ConnId -> ACorrId -> ACommand 'Agent -> m ()
processAgentMessage Nothing _ _ _ = throwChatError CENoActiveUser
+85 -33
View File
@@ -137,9 +137,12 @@ module Simplex.Chat.Store
getFileTransferProgress,
getSndFileTransfer,
getContactFileInfo,
getContactChatItemIdsAndFileInfo,
getContactMaxItemTs,
deleteContactCIs,
updateContactTs,
getGroupChatItemIdsAndFileInfo,
getGroupFileInfo,
getGroupMaxItemTs,
deleteGroupCIs,
updateGroupTs,
createNewSndMessage,
createSndMsgDelivery,
@@ -191,6 +194,8 @@ module Simplex.Chat.Store
getXGrpMemIntroContGroup,
getChatItemTTL,
setChatItemTTL,
getExpiredFileInfo,
deleteExpiredCIs,
getChatsWithExpiredItems,
getContactExpiredCIs,
getGroupExpiredCIs,
@@ -2438,8 +2443,8 @@ getFileTransferMeta_ db userId fileId =
fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) =
FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_}
getContactFileInfo :: DB.Connection -> UserId -> Contact -> IO [CIFileInfo]
getContactFileInfo db userId Contact {contactId} =
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
getContactFileInfo db User {userId} Contact {contactId} =
map toFileInfo
<$> DB.query
db
@@ -2454,25 +2459,27 @@ getContactFileInfo db userId Contact {contactId} =
toFileInfo :: (Int64, ACIFileStatus, Maybe FilePath) -> CIFileInfo
toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath}
getContactChatItemIdsAndFileInfo :: DB.Connection -> User -> ContactId -> IO [(ChatItemId, UTCTime, Maybe CIFileInfo)]
getContactChatItemIdsAndFileInfo db User {userId} contactId =
map toItemIdAndFileInfo
<$> DB.query
db
[sql|
SELECT i.chat_item_id, i.item_ts, f.file_id, f.ci_file_status, f.file_path
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE i.user_id = ? AND i.contact_id = ?
ORDER BY i.item_ts ASC
|]
(userId, contactId)
getContactMaxItemTs :: DB.Connection -> User -> Contact -> IO (Maybe UTCTime)
getContactMaxItemTs db User {userId} Contact {contactId} =
fmap join . maybeFirstRow fromOnly $
DB.query db "SELECT MAX(item_ts) FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId)
toItemIdAndFileInfo :: (ChatItemId, UTCTime, Maybe Int64, Maybe ACIFileStatus, Maybe FilePath) -> (ChatItemId, UTCTime, Maybe CIFileInfo)
toItemIdAndFileInfo (chatItemId, itemTs, fileId_, fileStatus_, filePath) =
case (fileId_, fileStatus_) of
(Just fileId, Just fileStatus) -> (chatItemId, itemTs, Just CIFileInfo {fileId, fileStatus, filePath})
_ -> (chatItemId, itemTs, Nothing)
deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
deleteContactCIs db User {userId} Contact {contactId} = do
deleteContactCIsMessages_
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId)
where
deleteContactCIsMessages_ =
DB.execute
db
[sql|
DELETE FROM messages WHERE message_id IN (
SELECT message_id FROM chat_item_messages WHERE chat_item_id IN (
SELECT chat_item_id FROM chat_items WHERE user_id = ? AND contact_id = ?
)
)
|]
(userId, contactId)
updateContactTs :: DB.Connection -> User -> Contact -> UTCTime -> IO ()
updateContactTs db User {userId} Contact {contactId} updatedAt =
@@ -2481,25 +2488,40 @@ updateContactTs db User {userId} Contact {contactId} updatedAt =
"UPDATE contacts SET updated_at = ? WHERE user_id = ? AND contact_id = ?"
(updatedAt, userId, contactId)
getGroupChatItemIdsAndFileInfo :: DB.Connection -> User -> Int64 -> IO [(ChatItemId, UTCTime, Bool, Maybe CIFileInfo)]
getGroupChatItemIdsAndFileInfo db User {userId} groupId =
map toItemIdDeletedAndFileInfo
getGroupFileInfo :: DB.Connection -> User -> GroupInfo -> IO [CIFileInfo]
getGroupFileInfo db User {userId} GroupInfo {groupId} =
map toFileInfo
<$> DB.query
db
[sql|
SELECT i.chat_item_id, i.item_ts, i.item_deleted, f.file_id, f.ci_file_status, f.file_path
SELECT f.file_id, f.ci_file_status, f.file_path
FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE i.user_id = ? AND i.group_id = ?
ORDER BY i.item_ts ASC
|]
(userId, groupId)
toItemIdDeletedAndFileInfo :: (ChatItemId, UTCTime, Bool, Maybe Int64, Maybe ACIFileStatus, Maybe FilePath) -> (ChatItemId, UTCTime, Bool, Maybe CIFileInfo)
toItemIdDeletedAndFileInfo (chatItemId, itemTs, itemDeleted, fileId_, fileStatus_, filePath) =
case (fileId_, fileStatus_) of
(Just fileId, Just fileStatus) -> (chatItemId, itemTs, itemDeleted, Just CIFileInfo {fileId, fileStatus, filePath})
_ -> (chatItemId, itemTs, itemDeleted, Nothing)
getGroupMaxItemTs :: DB.Connection -> User -> GroupInfo -> IO (Maybe UTCTime)
getGroupMaxItemTs db User {userId} GroupInfo {groupId} =
fmap join . maybeFirstRow fromOnly $
DB.query db "SELECT MAX(item_ts) FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId)
deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO ()
deleteGroupCIs db User {userId} GroupInfo {groupId} = do
deleteGroupCIsMessages_
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId)
where
deleteGroupCIsMessages_ =
DB.execute
db
[sql|
DELETE FROM messages WHERE message_id IN (
SELECT message_id FROM chat_item_messages WHERE chat_item_id IN (
SELECT chat_item_id FROM chat_items WHERE user_id = ? AND group_id = ?
)
)
|]
(userId, groupId)
updateGroupTs :: DB.Connection -> User -> GroupInfo -> UTCTime -> IO ()
updateGroupTs db User {userId} GroupInfo {groupId} updatedAt =
@@ -4085,6 +4107,36 @@ setChatItemTTL db User {userId} chatItemTTL = do
"INSERT INTO settings (user_id, chat_item_ttl, created_at, updated_at) VALUES (?,?,?,?)"
(userId, chatItemTTL, currentTs, currentTs)
getExpiredFileInfo :: DB.Connection -> User -> UTCTime -> IO [CIFileInfo]
getExpiredFileInfo db User {userId} expirationDate =
map toFileInfo
<$> DB.query
db
[sql|
SELECT f.file_id, f.ci_file_status, f.file_path
FROM chat_items i
JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE i.user_id = ? AND i.item_ts <= ?
|]
(userId, expirationDate)
deleteExpiredCIs :: DB.Connection -> User -> UTCTime -> IO ()
deleteExpiredCIs db User {userId} expirationDate = do
deleteExpiredCIsMessages_
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND item_ts <= ?" (userId, expirationDate)
where
deleteExpiredCIsMessages_ =
DB.execute
db
[sql|
DELETE FROM messages WHERE message_id IN (
SELECT message_id FROM chat_item_messages WHERE chat_item_id IN (
SELECT chat_item_id FROM chat_items WHERE user_id = ? AND item_ts <= ?
)
)
|]
(userId, expirationDate)
getChatsWithExpiredItems :: DB.Connection -> User -> UTCTime -> IO [ChatRef]
getChatsWithExpiredItems db User {userId} expirationDate =
mapMaybe toChatRef
-4
View File
@@ -11,7 +11,3 @@ safeDecodeUtf8 = decodeUtf8With onError
uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
uncurry3 f ~(a, b, c) = f a b c
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
lastMaybe xs = Just $ last xs
+15 -4
View File
@@ -3014,15 +3014,26 @@ testSetChatItemTTL =
bob <# "alice> 1"
bob #> "@alice 2"
alice <# "bob> 2"
threadDelay 2000000
-- chat item with file
alice #$> ("/_files_folder ./tests/tmp/app_files", id, "ok")
copyFile "./tests/fixtures/test.jpg" "./tests/tmp/app_files/test.jpg"
alice ##> "/_send @2 json {\"filePath\": \"test.jpg\", \"msgContent\": {\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}"
alice <# "/f @bob test.jpg"
alice <## "use /fc 1 to cancel sending"
bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
-- above items should be deleted after we set ttl
threadDelay 3000000
alice #> "@bob 3"
bob <# "alice> 3"
bob #> "@alice 4"
alice <# "bob> 4"
alice #$> ("/_ttl 1", id, "ok")
alice #$> ("/_get chat @2 count=100", chatF, [((1, "1"), Nothing), ((0, "2"), Nothing), ((1, ""), Just "test.jpg"), ((1, "3"), Nothing), ((0, "4"), Nothing)])
checkActionDeletesFile "./tests/tmp/app_files/test.jpg" $
alice #$> ("/_ttl 2", id, "ok")
alice #$> ("/_get chat @2 count=100", chat, [(1, "3"), (0, "4")]) -- when expiration is turned on, first cycle is synchronous
bob #$> ("/_get chat @2 count=100", chat, [(0, "1"), (1, "2"), (0, "3"), (1, "4")])
alice #$> ("/ttl", id, "old messages are set to be deleted after: 1 second(s)")
bob #$> ("/_get chat @2 count=100", chat, [(0, "1"), (1, "2"), (0, ""), (0, "3"), (1, "4")])
alice #$> ("/ttl", id, "old messages are set to be deleted after: 2 second(s)")
alice #$> ("/ttl week", id, "ok")
alice #$> ("/ttl", id, "old messages are set to be deleted after: one week")
alice #$> ("/ttl none", id, "ok")