mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-28 00:44:27 +00:00
core: optimize bulk chat item deletion (#1168)
* core: optimize bulk chat item deletion * test file deletion * refactor * refactor
This commit is contained in:
+53
-85
@@ -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
@@ -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
|
||||
|
||||
@@ -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
@@ -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")
|
||||
|
||||
Reference in New Issue
Block a user