diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 704097c705..2156159aaa 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 (diffInMicros) +import Simplex.Chat.Util (diffInMicros, diffInSeconds) import Simplex.Messaging.Agent as Agent import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), AgentDatabase (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig) import Simplex.Messaging.Agent.Lock @@ -307,7 +307,7 @@ processChatCommand = \case then pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText CFVoice) else do (fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct - timed_ <- msgTimed ct + timed_ <- sndContactCITimed live ct (msgContainer, quotedItem_) <- prepareMsg fileInvitation_ timed_ (msg@SndMessage {sharedMsgId}, _) <- sendDirectContactMessage ct (XMsgNew msgContainer) case ft_ of @@ -315,10 +315,8 @@ processChatCommand = \case sendDirectFileInline ct ft sharedMsgId _ -> pure () ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live - case timed_ of - Just CITimed {ttl, deleteAt = Just deleteAt} -> - when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) deleteAt - _ -> pure () + forM_ (timed_ >>= deleteAt) $ + startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) setActive $ ActiveC c pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci where @@ -338,16 +336,9 @@ processChatCommand = \case _ -> pure CIFSSndStored let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus} pure (fileInvitation, ciFile, ft) - msgTimed :: Contact -> m (Maybe CITimed) - msgTimed ct = case contactCITimedTTL ct of - Just ttl -> do - ts <- liftIO getCurrentTime - let deleteAt = addUTCTime (realToFrac ttl) ts - pure . Just $ CITimed ttl (Just deleteAt) - Nothing -> pure Nothing prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect)) prepareMsg fileInvitation_ timed_ = case quotedItemId_ of - Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_ (ciTimedToTTL timed_) (justTrue live)), Nothing) + Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Nothing) Just quotedItemId -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- withStore $ \db -> getDirectChatItem db userId chatId quotedItemId @@ -355,7 +346,7 @@ processChatCommand = \case let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} qmc = quoteContent origQmc file quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ciTimedToTTL timed_) (justTrue live)), Just quotedItem) + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) where quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool) quoteData ChatItem {meta = CIMeta {itemDeleted = True}} = throwChatError CEInvalidQuote @@ -369,15 +360,13 @@ processChatCommand = \case then pure $ chatCmdError $ "feature not allowed " <> T.unpack (groupFeatureToText GFVoice) else do (fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length $ filter memberCurrent ms) - timed_ <- msgTimed gInfo + timed_ <- sndGroupCITimed live gInfo (msgContainer, quotedItem_) <- prepareMsg fileInvitation_ timed_ membership msg@SndMessage {sharedMsgId} <- sendGroupMessage gInfo ms (XMsgNew msgContainer) mapM_ (sendGroupFileInline ms sharedMsgId) ft_ ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live - case timed_ of - Just CITimed {ttl, deleteAt = Just deleteAt} -> - when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) deleteAt - _ -> pure () + forM_ (timed_ >>= deleteAt) $ + startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) setActive $ ActiveG gName pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci where @@ -391,13 +380,6 @@ processChatCommand = \case ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus} pure (fileInvitation, ciFile, ft) - msgTimed :: GroupInfo -> m (Maybe CITimed) - msgTimed gInfo = case groupCITimedTTL gInfo of - Just ttl -> do - ts <- liftIO getCurrentTime - let deleteAt = addUTCTime (realToFrac ttl) ts - pure . Just $ CITimed ttl (Just deleteAt) - Nothing -> pure Nothing sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m () sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} = when (fileInline == Just IFMSent) . forM_ ms $ \case @@ -408,7 +390,7 @@ processChatCommand = \case _ -> pure () prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) prepareMsg fileInvitation_ timed_ membership = case quotedItemId_ of - Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_ (ciTimedToTTL timed_) (justTrue live)), Nothing) + Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Nothing) Just quotedItemId -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- withStore $ \db -> getGroupChatItem db user chatId quotedItemId @@ -416,7 +398,7 @@ processChatCommand = \case let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} qmc = quoteContent origQmc file quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ciTimedToTTL timed_) (justTrue live)), Just quotedItem) + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) where quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) quoteData ChatItem {meta = CIMeta {itemDeleted = True}} _ = throwChatError CEInvalidQuote @@ -453,30 +435,32 @@ processChatCommand = \case unzipMaybe3 _ = (Nothing, Nothing, Nothing) APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user@User {userId} -> withChatLock "updateChatItem" $ case cType of CTDirect -> do - (ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId + (ct@Contact {contactId, localDisplayName = c}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId assertDirectAllowed user MDSnd ct XMsgUpdate_ - case ci of - CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive}, content = ciContent} -> do + case cci of + CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive}, content = ciContent} -> do case (ciContent, itemSharedMsgId) of (CISndMsgContent _, Just itemSharedMId) -> do - (SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc (ciTimedToTTL itemTimed) (justTrue . (live &&) =<< itemLive)) - updCi <- withStore $ \db -> updateDirectChatItem db userId contactId itemId (CISndMsgContent mc) live $ Just msgId + (SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) + ci' <- withStore $ \db -> updateDirectChatItem db userId contactId itemId (CISndMsgContent mc) live $ Just msgId + startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' setActive $ ActiveC c - pure . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) updCi + pure . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci' _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTGroup -> do Group gInfo@GroupInfo {groupId, localDisplayName = gName, membership} ms <- withStore $ \db -> getGroup db user chatId unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved - ci <- withStore $ \db -> getGroupChatItem db user chatId itemId - case ci of - CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive}, content = ciContent} -> do + cci <- withStore $ \db -> getGroupChatItem db user chatId itemId + case cci of + CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive}, content = ciContent} -> do case (ciContent, itemSharedMsgId) of (CISndMsgContent _, Just itemSharedMId) -> do - SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgUpdate itemSharedMId mc (ciTimedToTTL itemTimed) (justTrue . (live &&) =<< itemLive)) - updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId (CISndMsgContent mc) live $ Just msgId + SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) + ci' <- withStore $ \db -> updateGroupChatItem db user groupId itemId (CISndMsgContent mc) live $ Just msgId + startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' setActive $ ActiveG gName - pure . CRChatItemUpdated $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) updCi + pure . CRChatItemUpdated $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci' _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTContactRequest -> pure $ chatCmdError "not supported" @@ -516,7 +500,7 @@ processChatCommand = \case forM_ timedItems $ \(itemId, ttl) -> do let deleteAt = addUTCTime (realToFrac ttl) ts withStore' $ \db -> setDirectChatItemDeleteAt db user chatId itemId deleteAt - when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTDirect chatId, itemId) deleteAt + startProximateTimedItemThread user (ChatRef CTDirect chatId, itemId) deleteAt withStore' $ \db -> updateDirectChatItemsRead db userId chatId fromToIds pure CRCmdOk CTGroup -> do @@ -525,7 +509,7 @@ processChatCommand = \case forM_ timedItems $ \(itemId, ttl) -> do let deleteAt = addUTCTime (realToFrac ttl) ts withStore' $ \db -> setGroupChatItemDeleteAt db user chatId itemId deleteAt - when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTGroup chatId, itemId) deleteAt + startProximateTimedItemThread user (ChatRef CTGroup chatId, itemId) deleteAt withStore' $ \db -> updateGroupChatItemsRead db userId chatId fromToIds pure CRCmdOk CTContactRequest -> pure $ chatCmdError "not supported" @@ -1399,6 +1383,16 @@ processChatCommand = \case chatRef <- getChatRef user chatName let mc = MCText $ safeDecodeUtf8 msg processChatCommand . APISendMessage chatRef live $ ComposedMessage Nothing Nothing mc + sndContactCITimed :: Bool -> Contact -> m (Maybe CITimed) + sndContactCITimed live = mapM (sndCITimed_ live) . contactTimedTTL + sndGroupCITimed :: Bool -> GroupInfo -> m (Maybe CITimed) + sndGroupCITimed live = mapM (sndCITimed_ live) . groupTimedTTL + sndCITimed_ :: Bool -> Int -> m CITimed + sndCITimed_ live ttl = + CITimed ttl + <$> if live + then pure Nothing + else Just . addUTCTime (realToFrac ttl) <$> liftIO getCurrentTime assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m () assertDirectAllowed user dir ct event = @@ -1449,8 +1443,8 @@ updateCallItemStatus userId ct Call {chatItemId} receivedStatus msgId_ = do updateDirectChatItemView :: ChatMonad m => UserId -> Contact -> ChatItemId -> ACIContent -> Bool -> Maybe MessageId -> m () updateDirectChatItemView userId ct@Contact {contactId} chatItemId (ACIContent msgDir ciContent) live msgId_ = do - updCi <- withStore $ \db -> updateDirectChatItem db userId contactId chatItemId ciContent live msgId_ - toView . CRChatItemUpdated $ AChatItem SCTDirect msgDir (DirectChat ct) updCi + ci' <- withStore $ \db -> updateDirectChatItem db userId contactId chatItemId ciContent live msgId_ + toView . CRChatItemUpdated $ AChatItem SCTDirect msgDir (DirectChat ct) ci' callStatusItemContent :: ChatMonad m => UserId -> Contact -> ChatItemId -> WebRTCCallStatus -> m (Maybe ACIContent) callStatusItemContent userId Contact {contactId} chatItemId receivedStatus = do @@ -1748,6 +1742,12 @@ cleanupManager user = do timedItems <- withStore' $ \db -> getTimedItems db user startTimedThreadCutoff forM_ timedItems $ uncurry (startTimedItemThread user) +startProximateTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m () +startProximateTimedItemThread user itemRef deleteAt = do + ts <- liftIO getCurrentTime + when (diffInSeconds deleteAt ts <= cleanupManagerInterval) $ + startTimedItemThread user itemRef deleteAt + startTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m () startTimedItemThread user itemRef deleteAt = do itemThreads <- asks timedItemThreads @@ -1776,6 +1776,13 @@ deleteTimedItem user@User {userId} (ChatRef cType chatId, itemId) deleteAt = do deleteGroupCI user gInfo ci True True >>= toView _ -> toView . CRChatError . ChatError $ CEInternalError "bad deleteTimedItem cType" +startUpdatedTimedItemThread :: ChatMonad m => User -> ChatRef -> ChatItem c d -> ChatItem c d -> m () +startUpdatedTimedItemThread user chatRef ci ci' = + case (chatItemTimed ci >>= deleteAt, chatItemTimed ci' >>= deleteAt) of + (Nothing, Just deleteAt') -> + startProximateTimedItemThread user (chatRef, chatItemId' ci') deleteAt' + _ -> pure () + expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m () expireChatItems user ttl sync = do currentTs <- liftIO getCurrentTime @@ -2440,7 +2447,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = setActive $ ActiveC c else do let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc - timed_ = rcvMsgCITimed (contactCITimedTTL ct) itemTTL + timed_ = rcvContactCITimed ct itemTTL live = fromMaybe False live_ ciFile_ <- processFileInvitation fileInvitation_ content $ \db -> createRcvFileTransfer db userId ct ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_ timed_ live @@ -2475,7 +2482,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = -- This patches initial sharedMsgId into chat item when locally deleted chat item -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). -- Chat item and update message which created it will have different sharedMsgId in this case... - let timed_ = rcvMsgCITimed (contactCITimedTTL ct) ttl + let timed_ = rcvContactCITimed ct ttl ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta content Nothing timed_ live ci' <- withStore $ \db -> updateDirectChatItem db userId contactId (chatItemId' ci) content live Nothing toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci' @@ -2485,9 +2492,12 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = content = CIRcvMsgContent mc live = fromMaybe False live_ updateRcvChatItem = do - CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId + CChatItem msgDir ci@ChatItem {meta = CIMeta {itemId}} <- withStore $ \db -> getDirectChatItemBySharedMsgId db userId contactId sharedMsgId case msgDir of - SMDRcv -> updateDirectChatItemView userId ct itemId (ACIContent SMDRcv content) live $ Just msgId + SMDRcv -> do + ci' <- withStore $ \db -> updateDirectChatItem db userId contactId itemId content live $ Just msgId + toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci' + startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci' SMDSnd -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m () @@ -2514,7 +2524,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = then void $ newChatItem (CIRcvGroupFeatureRejected GFVoice) Nothing Nothing False else do let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc - timed_ = rcvMsgCITimed (groupCITimedTTL gInfo) itemTTL + timed_ = rcvGroupCITimed gInfo itemTTL live = fromMaybe False live_ ciFile_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) ciFile_ timed_ live @@ -2536,7 +2546,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = -- This patches initial sharedMsgId into chat item when locally deleted chat item -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). -- Chat item and update message which created it will have different sharedMsgId in this case... - let timed_ = rcvMsgCITimed (groupCITimedTTL gInfo) ttl_ + let timed_ = rcvGroupCITimed gInfo ttl_ ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live ci' <- withStore $ \db -> updateGroupChatItem db user groupId (chatItemId' ci) content live Nothing toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci' @@ -2546,14 +2556,15 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = content = CIRcvMsgContent mc live = fromMaybe False live_ updateRcvChatItem = do - CChatItem msgDir ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId + CChatItem msgDir ci@ChatItem {chatDir, meta = CIMeta {itemId}} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId case (msgDir, chatDir) of (SMDRcv, CIGroupRcv m') -> if sameMemberId memberId m' then do - updCi <- withStore $ \db -> updateGroupChatItem db user groupId itemId content live $ Just msgId - toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) updCi + ci' <- withStore $ \db -> updateGroupChatItem db user groupId itemId content live $ Just msgId + toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci' setActive $ ActiveG g + startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' else messageError "x.msg.update: group member attempted to update a message of another member" -- shouldn't happen now that query includes group member id (SMDSnd, _) -> messageError "x.msg.update: group member attempted invalid message update" diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index db9ebefcb5..c0a9a92cad 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -174,6 +174,9 @@ chatItemTs (CChatItem _ ci) = chatItemTs' ci chatItemTs' :: ChatItem c d -> UTCTime chatItemTs' ChatItem {meta = CIMeta {itemTs}} = itemTs +chatItemTimed :: ChatItem c d -> Maybe CITimed +chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed + data ChatDirection (c :: ChatType) (d :: MsgDirection) where CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv @@ -303,25 +306,29 @@ data CITimed = CITimed instance ToJSON CITimed where toEncoding = J.genericToEncoding J.defaultOptions -ciTimedToTTL :: Maybe CITimed -> Maybe Int -ciTimedToTTL timed_ = timed_ >>= \CITimed {ttl} -> Just ttl +ttl' :: CITimed -> Int +ttl' CITimed {ttl} = ttl -contactCITimedTTL :: Contact -> Maybe Int -contactCITimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessages = ContactUserPreference {enabled, userPreference}}} +contactTimedTTL :: Contact -> Maybe Int +contactTimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessages = ContactUserPreference {enabled, userPreference}}} | forUser enabled && forContact enabled = ttl | otherwise = Nothing where TimedMessagesPreference {ttl} = preference (userPreference :: ContactUserPref TimedMessagesPreference) -groupCITimedTTL :: GroupInfo -> Maybe Int -groupCITimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} +groupTimedTTL :: GroupInfo -> Maybe Int +groupTimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}} | enable == FEOn = Just ttl | otherwise = Nothing -rcvMsgCITimed :: Maybe Int -> Maybe Int -> Maybe CITimed -rcvMsgCITimed chatTTL itemTTL = case (chatTTL, itemTTL) of - (Just _, Just ttl) -> Just $ CITimed ttl Nothing - _ -> Nothing +rcvContactCITimed :: Contact -> Maybe Int -> Maybe CITimed +rcvContactCITimed = rcvCITimed_ . contactTimedTTL + +rcvGroupCITimed :: GroupInfo -> Maybe Int -> Maybe CITimed +rcvGroupCITimed = rcvCITimed_ . groupTimedTTL + +rcvCITimed_ :: Maybe Int -> Maybe Int -> Maybe CITimed +rcvCITimed_ chatTTL itemTTL = (`CITimed` Nothing) <$> (chatTTL >> itemTTL) data CIQuote (c :: ChatType) = CIQuote { chatDir :: CIQDirection c, diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 46dc2b0274..324326ff23 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -261,11 +261,12 @@ import Data.Functor (($>)) import Data.Int (Int64) import Data.List (sortBy, sortOn) import Data.List.NonEmpty (NonEmpty) -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe) +import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) import Data.Ord (Down (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Time.LocalTime (TimeZone, getCurrentTimeZone) import Data.Type.Equality @@ -3846,24 +3847,33 @@ updateDirectChatItem db userId contactId itemId newContent live msgId_ = do updateDirectChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> Bool -> UTCTime -> ExceptT StoreError IO (ChatItem 'CTDirect d) updateDirectChatItem_ db userId contactId itemId newContent live currentTs = do - ci@ChatItem {meta = CIMeta {itemEdited, itemLive}} <- liftEither . correctDir =<< getDirectChatItem db userId contactId itemId + ci@ChatItem {meta = meta@CIMeta {itemEdited, itemTimed, itemLive}} <- liftEither . correctDir =<< getDirectChatItem db userId contactId itemId let newText = ciContentToText newContent edited' = itemEdited || (itemLive /= Just True) live' = (live &&) <$> itemLive + delAt' = ciLiveDeleteAt meta live currentTs + timed' = (\timed -> timed {deleteAt = delAt'}) <$> itemTimed liftIO $ do DB.execute db [sql| UPDATE chat_items - SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = ?, item_live = ?, updated_at = ? + SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = ?, timed_delete_at = ?, item_live = ?, updated_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? |] - (newContent, newText, edited', live', currentTs, userId, contactId, itemId) - pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = edited', itemLive = live'}, formattedText = parseMaybeMarkdownList newText} + (newContent, newText, edited', delAt', live', currentTs, userId, contactId, itemId) + pure ci {content = newContent, meta = meta {itemText = newText, itemEdited = edited', itemTimed = timed', itemLive = live'}, formattedText = parseMaybeMarkdownList newText} where correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci +-- the condition to enable the timed deletion when the item that was live is updated +ciLiveDeleteAt :: CIMeta d -> Bool -> UTCTime -> Maybe UTCTime +ciLiveDeleteAt CIMeta {itemTimed, itemStatus = CISRcvNew} _live _ = itemTimed >>= deleteAt +ciLiveDeleteAt CIMeta {itemTimed = Just CITimed {ttl, deleteAt = Nothing}, itemLive = Just True} False currentTs = + Just $ addUTCTime (realToFrac ttl) currentTs +ciLiveDeleteAt CIMeta {itemTimed} _ _ = itemTimed >>= deleteAt + deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () deleteDirectChatItem db User {userId} Contact {contactId} (CChatItem _ ci) = do let itemId = chatItemId' ci @@ -3969,22 +3979,24 @@ getDirectChatItemIdByText db userId contactId msgDir quotedMsg = updateGroupChatItem :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItemId -> CIContent d -> Bool -> Maybe MessageId -> ExceptT StoreError IO (ChatItem 'CTGroup d) updateGroupChatItem db user@User {userId} groupId itemId newContent live msgId_ = do - ci@ChatItem {meta = CIMeta {itemEdited, itemLive}} <- liftEither . correctDir =<< getGroupChatItem db user groupId itemId + ci@ChatItem {meta = meta@CIMeta {itemEdited, itemTimed, itemLive}} <- liftEither . correctDir =<< getGroupChatItem db user groupId itemId currentTs <- liftIO getCurrentTime let newText = ciContentToText newContent edited' = itemEdited || (itemLive /= Just True) live' = (live &&) <$> itemLive + delAt' = ciLiveDeleteAt meta live currentTs + timed' = (\timed -> timed {deleteAt = delAt'}) <$> itemTimed liftIO $ do DB.execute db [sql| UPDATE chat_items - SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = ?, item_live = ?, updated_at = ? + SET item_content = ?, item_text = ?, item_deleted = 0, item_edited = ?, timed_delete_at = ?, item_live = ?, updated_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] - (newContent, newText, edited', live', currentTs, userId, groupId, itemId) + (newContent, newText, edited', delAt', live', currentTs, userId, groupId, itemId) forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId currentTs - pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = edited', itemLive = live'}, formattedText = parseMaybeMarkdownList newText} + pure ci {content = newContent, meta = meta {itemText = newText, itemEdited = edited', itemTimed = timed', itemLive = live'}, formattedText = parseMaybeMarkdownList newText} where correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci @@ -4212,9 +4224,13 @@ getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRan [sql| SELECT chat_item_id, timed_ttl FROM chat_items - WHERE user_id = ? AND contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + WHERE user_id = ? AND contact_id = ? + AND chat_item_id >= ? AND chat_item_id <= ? + AND item_status = ? + AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + AND (item_live IS NULL OR item_live = ?) |] - (userId, contactId, fromItemId, toItemId, CISRcvNew) + (userId, contactId, fromItemId, toItemId, CISRcvNew, False) _ -> DB.query db @@ -4261,9 +4277,13 @@ getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_ [sql| SELECT chat_item_id, timed_ttl FROM chat_items - WHERE user_id = ? AND group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + WHERE user_id = ? AND group_id = ? + AND chat_item_id >= ? AND chat_item_id <= ? + AND item_status = ? + AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL + AND (item_live IS NULL OR item_live = ?) |] - (userId, groupId, fromItemId, toItemId, CISRcvNew) + (userId, groupId, fromItemId, toItemId, CISRcvNew, False) _ -> DB.query db @@ -4330,10 +4350,7 @@ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStat ciMeta :: CIContent d -> CIStatus d -> CIMeta d ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt ciTimed :: Maybe CITimed - ciTimed = - case (timedTTL, timedDeleteAt) of - (Just ttl, deleteAt) -> Just CITimed {ttl, deleteAt} - _ -> Nothing + ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] toDirectChatItemList tz currentTs (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) = @@ -4379,10 +4396,7 @@ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemT ciMeta :: CIContent d -> CIStatus d -> CIMeta d ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt ciTimed :: Maybe CITimed - ciTimed = - case (timedTTL, timedDeleteAt) of - (Just ttl, deleteAt) -> Just CITimed {ttl, deleteAt} - _ -> Nothing + ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) = @@ -4585,7 +4599,7 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] getTimedItems db User {userId} startTimedThreadCutoff = - catMaybes . map toCIRefDeleteAt + mapMaybe toCIRefDeleteAt <$> DB.query db [sql| diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs index cc68c32ce4..1354bd8d50 100644 --- a/src/Simplex/Chat/Util.hs +++ b/src/Simplex/Chat/Util.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE NumericUnderscores #-} + module Simplex.Chat.Util ( diffInMicros, + diffInSeconds, ) where @@ -7,6 +10,9 @@ import Data.Fixed (Fixed (MkFixed), Pico) import Data.Time (nominalDiffTimeToSeconds) import Data.Time.Clock (UTCTime, diffUTCTime) +diffInSeconds :: UTCTime -> UTCTime -> Int +diffInSeconds a b = (`div` 1000000_000000) $ diffInPicos a b + diffInMicros :: UTCTime -> UTCTime -> Int diffInMicros a b = (`div` 1000000) $ diffInPicos a b diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 06078f6295..0354a9e652 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -3432,8 +3432,8 @@ testUpdateGroupPrefs = \alice bob -> do createGroup2 "team" alice bob alice #$> ("/_get chat #1 count=100", chat, [(0, "connected")]) + threadDelay 500000 bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected")]) - threadDelay 1000000 alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}}}" alice <## "updated group preferences:" alice <## "Full deletion enabled: on" @@ -3441,8 +3441,8 @@ testUpdateGroupPrefs = bob <## "alice updated group #team:" bob <## "updated group preferences:" bob <## "Full deletion enabled: on" + threadDelay 500000 bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on")]) - threadDelay 1000000 alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"off\"}, \"directMessages\": {\"enable\": \"on\"}}}" alice <## "updated group preferences:" alice <## "Full deletion enabled: off" @@ -3452,8 +3452,8 @@ testUpdateGroupPrefs = bob <## "updated group preferences:" bob <## "Full deletion enabled: off" bob <## "Voice messages enabled: off" + threadDelay 500000 bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off")]) - threadDelay 1000000 -- alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}}}" alice ##> "/set voice #team on" alice <## "updated group preferences:" @@ -3462,17 +3462,19 @@ testUpdateGroupPrefs = bob <## "alice updated group #team:" bob <## "updated group preferences:" bob <## "Voice messages enabled: on" + threadDelay 500000 bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on")]) - threadDelay 1000000 + threadDelay 500000 alice ##> "/_group_profile #1 {\"displayName\": \"team\", \"fullName\": \"team\", \"groupPreferences\": {\"fullDelete\": {\"enable\": \"off\"}, \"voice\": {\"enable\": \"on\"}, \"directMessages\": {\"enable\": \"on\"}}}" -- no update + threadDelay 500000 alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on"), (1, "Full deletion: off"), (1, "Voice messages: off"), (1, "Voice messages: on")]) - threadDelay 1000000 alice #> "#team hey" bob <# "#team alice> hey" - threadDelay 1000000 + threadDelay 500000 bob #> "#team hi" alice <# "#team bob> hi" + threadDelay 500000 alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Full deletion: on"), (1, "Full deletion: off"), (1, "Voice messages: off"), (1, "Voice messages: on"), (1, "hey"), (0, "hi")]) bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Full deletion: on"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Voice messages: on"), (0, "hey"), (1, "hi")])