diff --git a/docs/rfcs/2022-09-20-chat-history-deletion.md b/docs/rfcs/2022-09-20-chat-history-deletion.md new file mode 100644 index 0000000000..0974fbeb8c --- /dev/null +++ b/docs/rfcs/2022-09-20-chat-history-deletion.md @@ -0,0 +1,88 @@ +# Chat history deletion + +## Problem + +Currently chat history is preserved indefinitely and can only be cleared manually, either individual messages or per chat. This leads to privacy concerns as well as growing memory consumption. + +## Solution + +An option to turn on scheduled deletion of chat history (chat items and files). Initially only as a global setting but we can also consider setting per conversation. + +## Implementation plan + +Scheduled deletion implementation plan: + +- Enum ChatItemTTL - None, Day, Week, Month, etc. + +- Functions to convert ChatItemTTL to number of seconds for chatItemTTL and expireChatItemsInterval + +- Interval can be: + + - TTL / 2 + - depend on TTL (e.g. 1 day for a 1 week TTL) (reuse ExpirationConfig and have fixed configs?) + - fixed - 30 min? + +- iOS is not a long running process so we have to check after start + +- To prevent NSE from running this process parameterize startChat to allow starting without scheduled deletion even if it is configured + +- Don't update chats and previews? + +### Chat global expiration + +Api: + + - API Command - SetChatItemTTL ChatItemTTL, response is CRCmdOk + - API Command - GetChatItemTTL, response is CRChatItemTTL + +UI: + + - New view in settings, on start GetChatItemTTL to load into model + - When changed in UI - SetChatItemTTL, update in model + - UI options match ChatItemTTL + +Core: + + - Add expireChatItems to ChatController: TVar (Maybe (Async ())) similar to agentAsync? + - Thread is created/stopped in runtime because interval has to be figured out dynamically when TTL is changed (e.g. if it was changed from 1 week to 30 mins and interval for 1 week is 1 day, we shouldn't wait 1 day before reading new interval) + - Add table settings, field chat_item_ttl + - On chat start - read settings, convert chat_item_ttl into chatItemTTL and expireChatItemsInterval (may be Nothing); if not Nothing - run expireMessages thread and put into controller + - On SetChatItemTTL - update settings + - If Nothing - cancel expireMessages, remove from controller, update setting in store + - If Just - start expireMessages, put into controller, update setting in store + - expireMessages thread: + forever $ do + threadDelay interval + expiration logic + - Expiration logic: + - Select all (chat ref, chat item id) older than (current time - TTL), comparing with updated_at (created_at?) + - Reuse logic from APIDeleteChatItem to delete each item (should messages be deleted or updated to XMsgDeleted?) + +#### Questions + +- single thread (don't re-create on change), read flag on each cycle and on each chat item +- if ttl changed from none to some value - first run sync, no delay between chat items on first run +- seconds instead of enum in api / backend +- part of APISetChatSettings api? - unclear can block for long on first deletion +- fixed interval +- if ttl became smaller, set flag to false, then one sync cycle + +### Per chat expiration + +API: + + - API Command - SetChatCITTL ChatRef ChatItemTTL, response is CRCmdOk + - API Command - GetChatCITTL ChatRef, response is CRChatItemTTL + - If we do both global and contact API can be SetChatItemTTL (Maybe ChatRef) ChatItemTTL or SetChatItemTTL GlobalOrChatRef ChatItemTTL, same for Get + +UI: + + - In UI - in ChatInfo views, loaded on opening + +Core: + + - Add expireChatCIs in ChatController: map [ChatRef, Async ()] + - Added and started/cancelled by chatRef + - Saved in contacts/groups tables + - On chat start - read from contacts/groups + - Expiration logic: select per chat diff --git a/packages/simplex-chat-client/typescript/src/command.ts b/packages/simplex-chat-client/typescript/src/command.ts index 241ce2f0e9..e3b017284f 100644 --- a/packages/simplex-chat-client/typescript/src/command.ts +++ b/packages/simplex-chat-client/typescript/src/command.ts @@ -132,6 +132,7 @@ export interface CreateActiveUser extends IChatCommand { export interface StartChat extends IChatCommand { type: "startChat" subscribeConnections?: boolean + expireChatItems?: boolean } export interface APIStopChat extends IChatCommand { @@ -451,7 +452,7 @@ export function cmdString(cmd: ChatCommand): string { case "createActiveUser": return `/u ${JSON.stringify(cmd.profile)}` case "startChat": - return `/_start subscribe=${cmd.subscribeConnections ? "on" : "off"}` + return `/_start subscribe=${cmd.subscribeConnections ? "on" : "off"} expire=${cmd.expireChatItems ? "on" : "off"}` case "apiStopChat": return "/_stop" case "setFilesFolder": diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 0f318dd82a..0e32a1c029 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -50,6 +50,7 @@ library Simplex.Chat.Migrations.M20220824_profiles_local_alias Simplex.Chat.Migrations.M20220909_commands Simplex.Chat.Migrations.M20220926_connection_alias + Simplex.Chat.Migrations.M20220928_settings Simplex.Chat.Mobile Simplex.Chat.Options Simplex.Chat.ProfileGenerator diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index b281da86ff..76e0ac8f6c 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -13,7 +13,7 @@ module Simplex.Chat where import Control.Applicative (optional, (<|>)) -import Control.Concurrent.STM (stateTVar) +import Control.Concurrent.STM (retry, stateTVar) import Control.Logger.Simple import Control.Monad.Except import Control.Monad.IO.Unlift @@ -39,6 +39,7 @@ import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.Text (Text) import qualified Data.Text as T +import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) import Data.Time.Clock.System (SystemTime, systemToUTCTime) import Data.Time.LocalTime (getCurrentTimeZone, getZonedTime) @@ -151,7 +152,9 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen filesFolder <- newTVarIO Nothing incognitoMode <- newTVarIO False chatStoreChanged <- newTVarIO False - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder} + expireCIsAsync <- newTVarIO Nothing + expireCIs <- newTVarIO False + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIsAsync, expireCIs} where resolveServers :: InitialAgentServers -> IO InitialAgentServers resolveServers ss@InitialAgentServers {smp = defaultSMPServers} = case nonEmpty smpServers of @@ -162,8 +165,8 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen pure ss {smp = fromMaybe defaultSMPServers $ nonEmpty userSmpServers} _ -> pure ss -startChatController :: (MonadUnliftIO m, MonadReader ChatController m) => User -> Bool -> m (Async ()) -startChatController user subConns = do +startChatController :: (MonadUnliftIO m, MonadReader ChatController m) => User -> Bool -> Bool -> m (Async ()) +startChatController user subConns enableExpireCIs = do asks smpAgent >>= resumeAgentClient restoreCalls user s <- asks agentAsync @@ -176,7 +179,24 @@ startChatController user subConns = do then Just <$> async (void . runExceptT $ subscribeUserConnections Agent.subscribeConnections user) else pure Nothing atomically . writeTVar s $ Just (a1, a2) + when enableExpireCIs startExpireCIs pure a1 + startExpireCIs = do + expireAsync <- asks expireCIsAsync + readTVarIO expireAsync >>= \case + Nothing -> do + a <- Just <$> async (void $ runExceptT runExpireCIs) + atomically $ writeTVar expireAsync a + setExpireCIs True + _ -> setExpireCIs True + runExpireCIs = do + let interval = 1800 * 1000000 -- 30 minutes + forever $ do + expire <- asks expireCIs + atomically $ readTVar expire >>= \b -> unless b retry + ttl <- withStore' (`getChatItemTTL` user) + forM_ ttl $ \t -> expireChatItems user t False + threadDelay interval restoreCalls :: (MonadUnliftIO m, MonadReader ChatController m) => User -> m () restoreCalls user = do @@ -186,10 +206,12 @@ restoreCalls user = do atomically $ writeTVar calls callsMap stopChatController :: MonadUnliftIO m => ChatController -> m () -stopChatController ChatController {smpAgent, agentAsync = s} = do +stopChatController ChatController {smpAgent, agentAsync = s, expireCIs} = do disconnectAgentClient smpAgent readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) - atomically (writeTVar s Nothing) + atomically $ do + writeTVar expireCIs False + writeTVar s Nothing withLock :: MonadUnliftIO m => TMVar () -> m a -> m a withLock lock = @@ -219,17 +241,22 @@ processChatCommand = \case user <- withStore $ \db -> createUser db p True atomically . writeTVar u $ Just user pure $ CRActiveUser user - StartChat subConns -> withUser' $ \user -> + StartChat subConns enableExpireCIs -> withUser' $ \user -> asks agentAsync >>= readTVarIO >>= \case Just _ -> pure CRChatRunning - _ -> checkStoreNotChanged $ startChatController user subConns $> CRChatStarted + _ -> checkStoreNotChanged $ startChatController user subConns enableExpireCIs $> CRChatStarted APIStopChat -> do ask >>= stopChatController pure CRChatStopped APIActivateChat -> do withUser $ \user -> restoreCalls user - withAgent activateAgent $> CRCmdOk - APISuspendChat t -> withAgent (`suspendAgent` t) $> CRCmdOk + withAgent activateAgent + setExpireCIs True + pure CRCmdOk + APISuspendChat t -> do + setExpireCIs False + withAgent (`suspendAgent` t) + pure CRCmdOk ResubscribeAllConnections -> withUser (subscribeUserConnections Agent.resubscribeConnections) $> CRCmdOk SetFilesFolder filesFolder' -> do createDirectoryIfMissing True filesFolder' @@ -474,11 +501,7 @@ processChatCommand = \case CTDirect -> do ct <- withStore $ \db -> getContact db userId chatId ciIdsAndFileInfo <- withStore' $ \db -> getContactChatItemIdsAndFileInfo db user chatId - forM_ ciIdsAndFileInfo $ \(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 + forM_ ciIdsAndFileInfo $ \(itemId, _, fileInfo_) -> deleteDirectChatItem user ct (itemId, fileInfo_) ct' <- case ciIdsAndFileInfo of [] -> pure ct _ -> do @@ -619,6 +642,20 @@ processChatCommand = \case ChatConfig {defaultServers = InitialAgentServers {smp = defaultSMPServers}} <- asks config withAgent $ \a -> setSMPServers a (fromMaybe defaultSMPServers (nonEmpty smpServers)) pure CRCmdOk + APISetChatItemTTL newTTL_ -> withUser $ \user -> withChatLock $ do + case newTTL_ of + Nothing -> do + withStore' $ \db -> setChatItemTTL db user newTTL_ + setExpireCIs False + Just newTTL -> do + oldTTL <- withStore' (`getChatItemTTL` user) + when (maybe True (newTTL <) oldTTL) $ do + setExpireCIs False + expireChatItems user newTTL True + withStore' $ \db -> setChatItemTTL db user newTTL_ + setExpireCIs True + pure CRCmdOk + APIGetChatItemTTL -> CRChatItemTTL <$> withUser (\user -> withStore' (`getChatItemTTL` user)) APISetNetworkConfig cfg -> withUser' $ \_ -> withAgent (`setNetworkConfig` cfg) $> CRCmdOk APIGetNetworkConfig -> CRNetworkConfig <$> withUser' (\_ -> withAgent getNetworkConfig) APISetChatSettings (ChatRef cType chatId) chatSettings -> withUser $ \user@User {userId} -> case cType of @@ -1020,34 +1057,11 @@ processChatCommand = \case isReady ct = let s = connStatus $ activeConn (ct :: Contact) in s == ConnReady || s == ConnSndReady - -- perform an action only if filesFolder is set (i.e. on mobile devices) - withFilesFolder :: (FilePath -> m ()) -> m () - withFilesFolder action = asks filesFolder >>= readTVarIO >>= mapM_ action - deleteFile :: 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 :: 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 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 $ do - forM_ fileInfo_ $ \fileInfo -> do - cancelFile user fileInfo `catchError` \_ -> pure () - withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo - void $ withStore $ \db -> deleteGroupChatItemInternal db user gInfo itemId + 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 @@ -1083,6 +1097,47 @@ processChatCommand = \case groupMemberId <- getGroupMemberIdByName db user groupId groupMemberName pure (groupId, groupMemberId) +setExpireCIs :: (MonadUnliftIO m, MonadReader ChatController m) => Bool -> m () +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 -> deleteGroupChatItemInternal db user gInfo itemId + +-- 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 + updateCallItemStatus :: ChatMonad m => UserId -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> m () updateCallItemStatus userId ct Call {chatItemId} receivedStatus msgId_ = do aciContent_ <- callStatusItemContent userId ct chatItemId receivedStatus @@ -1338,6 +1393,35 @@ subscribeUserConnections agentBatchSubscribe user = do Just _ -> Nothing _ -> Just . ChatError . CEAgentNoSubResult $ AgentConnId connId +expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m () +expireChatItems user@User {userId} 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 + 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 + processAgentMessage :: forall m. ChatMonad m => Maybe User -> ConnId -> ACorrId -> ACommand 'Agent -> m () processAgentMessage Nothing _ _ _ = throwChatError CENoActiveUser processAgentMessage (Just User {userId}) _ "" agentMessage = case agentMessage of @@ -2676,8 +2760,8 @@ chatCommandP = "/unmute " *> ((`ShowMessages` True) <$> chatNameP'), ("/user " <|> "/u ") *> (CreateActiveUser <$> userProfile), ("/user" <|> "/u") $> ShowActiveUser, - "/_start subscribe=" *> (StartChat <$> ("on" $> True <|> "off" $> False)), - "/_start" $> StartChat True, + "/_start subscribe=" *> (StartChat <$> onOffP <* " expire=" <*> onOffP), + "/_start" $> StartChat True True, "/_stop" $> APIStopChat, "/_app activate" $> APIActivateChat, "/_app suspend " *> (APISuspendChat <$> A.decimal), @@ -2729,6 +2813,9 @@ chatCommandP = "/smp_servers default" $> SetUserSMPServers [], "/smp_servers " *> (SetUserSMPServers <$> smpServersP), "/smp_servers" $> GetUserSMPServers, + "/_ttl " *> (APISetChatItemTTL <$> ciTTLDecimal), + "/ttl " *> (APISetChatItemTTL <$> ciTTL), + "/ttl" $> APIGetChatItemTTL, "/_network " *> (APISetNetworkConfig <$> jsonP), ("/network " <|> "/net ") *> (APISetNetworkConfig <$> netCfgP), ("/network" <|> "/net") $> APIGetNetworkConfig, @@ -2837,6 +2924,12 @@ chatCommandP = chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName chatRefP = ChatRef <$> chatTypeP <*> A.decimal msgCountP = A.space *> A.decimal <|> pure 10 + ciTTLDecimal = ("none" $> Nothing) <|> (Just <$> A.decimal) + ciTTL = + ("day" $> Just 86400) + <|> ("week" $> Just (7 * 86400)) + <|> ("month" $> Just (30 * 86400)) + <|> ("none" $> Nothing) netCfgP = do socksProxy <- "socks=" *> ("off" $> Nothing <|> "on" $> Just defaultSocksProxy <|> Just <$> strP) t_ <- optional $ " timeout=" *> A.decimal diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 1f856386cb..1af22ddb95 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -96,7 +96,9 @@ data ChatController = ChatController currentCalls :: TMap ContactId Call, config :: ChatConfig, filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps, - incognitoMode :: TVar Bool + incognitoMode :: TVar Bool, + expireCIsAsync :: TVar (Maybe (Async ())), + expireCIs :: TVar Bool } data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSMessages | HSSettings @@ -109,7 +111,7 @@ instance ToJSON HelpSection where data ChatCommand = ShowActiveUser | CreateActiveUser Profile - | StartChat {subscribeConnections :: Bool} + | StartChat {subscribeConnections :: Bool, enableExpireChatItems :: Bool} | APIStopChat | APIActivateChat | APISuspendChat {suspendTimeout :: Int} @@ -160,6 +162,8 @@ data ChatCommand | APIUpdateGroupProfile GroupId GroupProfile | GetUserSMPServers | SetUserSMPServers [SMPServer] + | APISetChatItemTTL (Maybe Int64) + | APIGetChatItemTTL | APISetNetworkConfig NetworkConfig | APIGetNetworkConfig | APISetChatSettings ChatRef ChatSettings @@ -225,6 +229,7 @@ data ChatResponse | CRLastMessages {chatItems :: [AChatItem]} | CRApiParsedMarkdown {formattedText :: Maybe MarkdownList} | CRUserSMPServers {smpServers :: [SMPServer]} + | CRChatItemTTL {chatItemTTL :: Maybe Int64} | CRNetworkConfig {networkConfig :: NetworkConfig} | CRContactInfo {contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile} | CRGroupMemberInfo {groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats} diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 4165a281ff..b1bf9b1f55 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -30,7 +30,7 @@ runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController runSimplexChat ChatOpts {maintenance} u cc chat | maintenance = wait =<< async (chat u cc) | otherwise = do - a1 <- runReaderT (startChatController u True) cc + a1 <- runReaderT (startChatController u True True) cc a2 <- async $ chat u cc waitEither_ a1 a2 diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index fa431fa3e6..1196553f84 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -398,6 +398,7 @@ data CIFileInfo = CIFileInfo fileStatus :: ACIFileStatus, filePath :: Maybe FilePath } + deriving (Show) data CIStatus (d :: MsgDirection) where CISSndNew :: CIStatus 'MDSnd diff --git a/src/Simplex/Chat/Migrations/M20220928_settings.hs b/src/Simplex/Chat/Migrations/M20220928_settings.hs new file mode 100644 index 0000000000..56b3613b05 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20220928_settings.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20220928_settings where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20220928_settings :: Query +m20220928_settings = + [sql| +CREATE TABLE settings ( + settings_id INTEGER PRIMARY KEY, + chat_item_ttl INTEGER, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index fda7e3e05d..2924e1acbd 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -413,3 +413,10 @@ CREATE TABLE commands( updated_at TEXT NOT NULL DEFAULT(datetime('now')) ); CREATE TABLE sqlite_sequence(name,seq); +CREATE TABLE settings( + settings_id INTEGER PRIMARY KEY, + chat_item_ttl INTEGER, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 37a42b54ab..c5c45da5db 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -189,6 +189,11 @@ module Simplex.Chat.Store setConnConnReqInv, getXGrpMemIntroContDirect, getXGrpMemIntroContGroup, + getChatItemTTL, + setChatItemTTL, + getChatsWithExpiredItems, + getContactExpiredCIs, + getGroupExpiredCIs, getPendingContactConnection, deletePendingContactConnection, updateContactSettings, @@ -214,7 +219,7 @@ import Data.Functor (($>)) import Data.Int (Int64) import Data.List (find, sortBy, sortOn) import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) import Data.Ord (Down (..)) import Data.Text (Text) import qualified Data.Text as T @@ -250,6 +255,7 @@ import Simplex.Chat.Migrations.M20220823_delete_broken_group_event_chat_items import Simplex.Chat.Migrations.M20220824_profiles_local_alias import Simplex.Chat.Migrations.M20220909_commands import Simplex.Chat.Migrations.M20220926_connection_alias +import Simplex.Chat.Migrations.M20220928_settings import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..)) @@ -286,7 +292,8 @@ schemaMigrations = ("20220823_delete_broken_group_event_chat_items", m20220823_delete_broken_group_event_chat_items), ("20220824_profiles_local_alias", m20220824_profiles_local_alias), ("20220909_commands", m20220909_commands), - ("20220926_connection_alias", m20220926_connection_alias) + ("20220926_connection_alias", m20220926_connection_alias), + ("20220928_settings", m20220928_settings) ] -- | The list of migrations in ascending order by date @@ -4074,6 +4081,79 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do Just connReq -> Just (hostConnId, connReq) _ -> Nothing +getChatItemTTL :: DB.Connection -> User -> IO (Maybe Int64) +getChatItemTTL db User {userId} = + fmap join . maybeFirstRow fromOnly $ DB.query db "SELECT chat_item_ttl FROM settings WHERE user_id = ? LIMIT 1" (Only userId) + +setChatItemTTL :: DB.Connection -> User -> Maybe Int64 -> IO () +setChatItemTTL db User {userId} chatItemTTL = do + currentTs <- getCurrentTime + r :: (Maybe Int64) <- maybeFirstRow fromOnly $ DB.query db "SELECT 1 FROM settings WHERE user_id = ? LIMIT 1" (Only userId) + case r of + Just _ -> do + DB.execute + db + "UPDATE settings SET chat_item_ttl = ?, updated_at = ? WHERE user_id = ?" + (chatItemTTL, currentTs, userId) + Nothing -> do + DB.execute + db + "INSERT INTO settings (user_id, chat_item_ttl, created_at, updated_at) VALUES (?,?,?,?)" + (userId, chatItemTTL, currentTs, currentTs) + +getChatsWithExpiredItems :: DB.Connection -> User -> UTCTime -> IO [ChatRef] +getChatsWithExpiredItems db User {userId} expirationDate = + mapMaybe toChatRef + <$> DB.query + db + [sql| + SELECT contact_id, group_id + FROM chat_items + WHERE user_id = ? AND item_ts <= ? AND item_deleted != 1 + GROUP BY contact_id, group_id + ORDER BY contact_id ASC, group_id ASC + |] + (userId, expirationDate) + where + toChatRef :: (Maybe ContactId, Maybe GroupId) -> Maybe ChatRef + toChatRef (Just contactId, Nothing) = Just $ ChatRef CTDirect contactId + toChatRef (Nothing, Just groupId) = Just $ ChatRef CTGroup groupId + toChatRef _ = Nothing + +getContactExpiredCIs :: DB.Connection -> User -> ContactId -> UTCTime -> IO [(ChatItemId, Maybe CIFileInfo)] +getContactExpiredCIs db User {userId} contactId expirationDate = + map toItemIdAndFileInfo' + <$> DB.query + db + [sql| + SELECT i.chat_item_id, 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 = ? AND i.item_ts <= ? + ORDER BY i.item_ts ASC + |] + (userId, contactId, expirationDate) + +getGroupExpiredCIs :: DB.Connection -> User -> Int64 -> UTCTime -> IO [(ChatItemId, Maybe CIFileInfo)] +getGroupExpiredCIs db User {userId} groupId expirationDate = + map toItemIdAndFileInfo' + <$> DB.query + db + [sql| + SELECT i.chat_item_id, 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.group_id = ? AND i.item_ts <= ? AND i.item_deleted != 1 + ORDER BY i.item_ts ASC + |] + (userId, groupId, expirationDate) + +toItemIdAndFileInfo' :: (ChatItemId, Maybe Int64, Maybe ACIFileStatus, Maybe FilePath) -> (ChatItemId, Maybe CIFileInfo) +toItemIdAndFileInfo' (chatItemId, fileId_, fileStatus_, filePath) = + case (fileId_, fileStatus_) of + (Just fileId, Just fileStatus) -> (chatItemId, Just CIFileInfo {fileId, fileStatus, filePath}) + _ -> (chatItemId, Nothing) + -- | Saves unique local display name based on passed displayName, suffixed with _N if required. -- This function should be called inside transaction. withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO (Either StoreError a)) -> IO (Either StoreError a) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index abefa88407..78a6553ea1 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -63,6 +63,7 @@ responseToView testView = \case CRApiChat chat -> if testView then testViewChat chat else [plain . bshow $ J.encode chat] CRApiParsedMarkdown ft -> [plain . bshow $ J.encode ft] CRUserSMPServers smpServers -> viewSMPServers smpServers testView + CRChatItemTTL ttl -> viewChatItemTTL ttl CRNetworkConfig cfg -> viewNetworkConfig cfg CRContactInfo ct cStats customUserProfile -> viewContactInfo ct cStats customUserProfile CRGroupMemberInfo g m cStats -> viewGroupMemberInfo g m cStats @@ -578,6 +579,17 @@ viewSMPServers smpServers testView = then "no custom SMP servers saved" else viewServers smpServers +viewChatItemTTL :: Maybe Int64 -> [StyledString] +viewChatItemTTL = \case + Nothing -> ["old messages are not being deleted"] + Just ttl + | ttl == 86400 -> deletedAfter "one day" + | ttl == 7 * 86400 -> deletedAfter "one week" + | ttl == 30 * 86400 -> deletedAfter "one month" + | otherwise -> deletedAfter $ sShow ttl <> " second(s)" + where + deletedAfter ttlStr = ["old messages are set to be deleted after: " <> ttlStr] + viewNetworkConfig :: NetworkConfig -> [StyledString] viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} = [ plain $ maybe "direct network connection" (("using SOCKS5 proxy " <>) . show) socksProxy, diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index e92b0c8e8f..61b1ccb1c6 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -121,6 +121,8 @@ chatTests = do describe "mute/unmute messages" $ do it "mute/unmute contact" testMuteContact it "mute/unmute group" testMuteGroup + describe "chat item expiration" $ do + it "set chat item TTL" testSetChatItemTTL versionTestMatrix2 :: (TestCC -> TestCC -> IO ()) -> Spec versionTestMatrix2 runTest = do @@ -2874,6 +2876,29 @@ testMuteGroup = bob ##> "/gs" bob <## "#team" +testSetChatItemTTL :: IO () +testSetChatItemTTL = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + alice #> "@bob 1" + bob <# "alice> 1" + bob #> "@alice 2" + alice <# "bob> 2" + threadDelay 1000000 + alice #> "@bob 3" + bob <# "alice> 3" + bob #> "@alice 4" + alice <# "bob> 4" + alice #$> ("/_ttl 1", 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)") + alice #$> ("/ttl week", id, "ok") + alice #$> ("/ttl", id, "old messages are set to be deleted after: one week") + alice #$> ("/ttl none", id, "ok") + alice #$> ("/ttl", id, "old messages are not being deleted") + withTestChatContactConnected :: String -> (TestCC -> IO a) -> IO a withTestChatContactConnected dbPrefix action = withTestChat dbPrefix $ \cc -> do