mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-30 20:45:49 +00:00
core: do not start disappearing timer for live messages until they stop being live, and start it on item update instead, provided they are read (#1609)
* core: do not start disappearing timer for live messages until they stop being live, and start it on item update instead, provided they are read * change delays in tests * diffInSeconds
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
84e43c57f6
commit
64fb1f0b85
@@ -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"
|
||||
|
||||
|
||||
@@ -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,
|
||||
|
||||
@@ -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|
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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")])
|
||||
|
||||
|
||||
Reference in New Issue
Block a user