core: scheduled deletion (#1075)

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

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

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":

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

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 :: (MonadUnliftIO m, MonadReader ChatController m) => User -> Bool -> Bool -> m (Async ())
-startChatController user subConns = do
+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
+    withAgent activateAgent
-  APISuspendChat t -> withAgent (`suspendAgent` t) $> CRCmdOk
+    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_ ciIdsAndFileInfo $ \(itemId, _, fileInfo_) -> deleteDirectChatItem user ct (itemId, fileInfo_)
-        forM_ fileInfo_ $ \fileInfo -> do
-          cancelFile user fileInfo `catchError` \_ -> pure ()
-          withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo
-        void $ withStore $ \db -> deleteDirectChatItemLocal db userId ct itemId CIDMInternal
       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
+        unless itemDeleted $ deleteGroupChatItem user gInfo (itemId, fileInfo_)
-          forM_ fileInfo_ $ \fileInfo -> do
-            cancelFile user fileInfo `catchError` \_ -> pure ()
-            withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo
-          void $ withStore $ \db -> deleteGroupChatItemInternal db user gInfo itemId
       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 subscribe=" *> (StartChat <$> onOffP <* " expire=" <*> onOffP),
-      "/_start" $> StartChat True,
+      "/_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

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}

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
 

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

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'))
+);
+|]

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'))
+);

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)

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,

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