diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 6e61895c52..4317221f23 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 16ef3c8ab0..462e836c81 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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 diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs index b6c97fed8a..835dedce55 100644 --- a/src/Simplex/Chat/Util.hs +++ b/src/Simplex/Chat/Util.hs @@ -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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index a9664f2675..6eb78375bb 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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 [