mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-06-28 12:19:54 +00:00
core: timed messages (#1561)
* docs: disappearing messages rfc * change schema * word * wip * wip * todos * todos * remove cancel, refactor * revert prefs * CITimed * schema * time on send direct * time on send group * add ttl to msg container, refactor * timed on receive * time on read * getTimedItems, fix tests * mark read in terminal - view, input, output, fix tests * refactor * comment * util * insert atomically * refactor * use guards * refactor startTimedItemThread Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
parent
68525b4131
commit
0e837ae392
15 changed files with 560 additions and 144 deletions
106
docs/rfcs/2022-12-12-disappearing-messages.md
Normal file
106
docs/rfcs/2022-12-12-disappearing-messages.md
Normal file
|
@ -0,0 +1,106 @@
|
|||
# Disappearing messages
|
||||
|
||||
- ability to turn on/off disappearing messages feature per conversation, specify ttl
|
||||
|
||||
- use preferences framework, preference affects local deletion of both sent and received messages
|
||||
|
||||
- special chat item on change
|
||||
|
||||
- in direct chat - chat item can be interacted with to agree or disagree with preference change, updates preference accordingly
|
||||
|
||||
- how does party that offered preference change learn about disagreement? (maybe just no preference update from contact is ok, since it's still not on if it's not mutual)
|
||||
|
||||
- how does it learn about disagreement on ttl? (it's on already - so it works for both but differently if there's no agreement)
|
||||
|
||||
- single updating chat item or per event? (probably per event is better since they can be spaced in time)
|
||||
|
||||
- in group - set by owner
|
||||
|
||||
- should it be allowed to be configured globally?
|
||||
|
||||
- change of setting shouldn't prevent previous disappearing messages from being deleted
|
||||
|
||||
## Design
|
||||
|
||||
- add `delete_at` field to `chat_items` table, index `idx_chat_items_delete_at`
|
||||
|
||||
- add `disappearingItems :: TMap ChatItemId (Async ())` to ChatController (use `Weak ThreadId`?)
|
||||
|
||||
- new background process that periodically scans for disappearing messages bound to be deleted during next 30 minutes:
|
||||
|
||||
- add `cleanupManager :: TVar (Async ())` to ChatController
|
||||
|
||||
- periodically gets items to schedule for deletion based on delete_at field
|
||||
|
||||
- for items to be deleted in next 30 minutes - add thread to disappearingItems - thread delays until deleteAt date, then deletes and sends CRChatItemDeleted to view
|
||||
|
||||
- for items past current time - delete in bulk
|
||||
|
||||
- race condition between bulk deletion of expired items on start and opening a chat with them - they should be removed from chat view once deleted - don't optimize for bulk deletion and create threads? create multiple CRs after bulk deletion? create single chat response with all ids?
|
||||
|
||||
- when chat item is deleted locally, either by user or via "delete for everyone" feature, kill thread and remove from map
|
||||
|
||||
- when MsgContent chat item is sent or marked read, add thread to disappearingItems based on chat preference
|
||||
|
||||
- UI shows timer based on chat item's createdAt date and deleteAt date
|
||||
|
||||
\***
|
||||
|
||||
Preference agreement:
|
||||
|
||||
- new preference types?
|
||||
|
||||
``` haskell
|
||||
data DisappearingMessagesPreference = DisappearingMessagesPreference
|
||||
{
|
||||
allow :: FeatureAllowed,
|
||||
ttl :: Int
|
||||
}
|
||||
|
||||
data DisappearingMessagesGroupPreference = DisappearingMessagesGroupPreference
|
||||
{
|
||||
enable :: GroupFeatureEnabled,
|
||||
ttl :: Int
|
||||
}
|
||||
|
||||
-- requires changing functions and types using Preference and GroupPreference
|
||||
```
|
||||
- chat items to contain old and new preference value
|
||||
|
||||
\***
|
||||
|
||||
Maybe agreement shouldn't be via preferences framework, but ad-hoc? For example:
|
||||
|
||||
- new protocol messages `XMsgTtlOffer ttl`, `XMsgTtlAgree ttl`, `XMsgTtlOff`
|
||||
|
||||
- for direct chats on XMsgTtlOffer contact `disappearingMessages` fields is updated to
|
||||
|
||||
- for direct chats on XMsgTtlAgree check ttl equals offered, then turn on
|
||||
|
||||
- for group chats only XMsgTtlAgree has to be sent, should only be accepted from owner
|
||||
|
||||
- XMsgTtlOff turns off unconditionally, for group chats should only be accepted from owner
|
||||
|
||||
- types:
|
||||
|
||||
``` haskell
|
||||
data DisappearingMessagesState
|
||||
= DMSOff
|
||||
| DMSOffered ttl
|
||||
| DMSAgreed ttl
|
||||
|
||||
data Contact = Contact
|
||||
{ ...
|
||||
disappearingMessagesState :: DisappearingMessagesState,
|
||||
...
|
||||
}
|
||||
|
||||
data GroupInfo = GroupInfo
|
||||
{ ...
|
||||
disappearingMessagesState :: DisappearingMessagesState,
|
||||
...
|
||||
}
|
||||
|
||||
-- make part of ChatSettings?
|
||||
```
|
||||
|
|
@ -68,6 +68,7 @@ library
|
|||
Simplex.Chat.Migrations.M20221209_verified_connection
|
||||
Simplex.Chat.Migrations.M20221210_idxs
|
||||
Simplex.Chat.Migrations.M20221211_group_description
|
||||
Simplex.Chat.Migrations.M20221212_chat_items_timed
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Options
|
||||
Simplex.Chat.ProfileGenerator
|
||||
|
@ -79,6 +80,7 @@ library
|
|||
Simplex.Chat.Terminal.Notification
|
||||
Simplex.Chat.Terminal.Output
|
||||
Simplex.Chat.Types
|
||||
Simplex.Chat.Util
|
||||
Simplex.Chat.View
|
||||
other-modules:
|
||||
Paths_simplex_chat
|
||||
|
|
|
@ -55,6 +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.Messaging.Agent as Agent
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), AgentDatabase (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
|
||||
import Simplex.Messaging.Agent.Lock
|
||||
|
@ -75,7 +76,7 @@ import System.FilePath (combine, splitExtensions, takeFileName)
|
|||
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
import UnliftIO.Async
|
||||
import UnliftIO.Concurrent (forkIO, threadDelay)
|
||||
import UnliftIO.Concurrent (forkFinally, forkIO, mkWeakThreadId, threadDelay)
|
||||
import UnliftIO.Directory
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.IO (hClose, hSeek, hTell)
|
||||
|
@ -155,7 +156,9 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
|||
chatStoreChanged <- newTVarIO False
|
||||
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}
|
||||
cleanupManagerAsync <- newTVarIO Nothing
|
||||
timedItemThreads <- atomically TM.empty
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIsAsync, expireCIs, cleanupManagerAsync, timedItemThreads}
|
||||
where
|
||||
configServers :: InitialAgentServers
|
||||
configServers =
|
||||
|
@ -189,8 +192,16 @@ startChatController user subConns enableExpireCIs = do
|
|||
then Just <$> async (void . runExceptT $ subscribeUserConnections Agent.subscribeConnections user)
|
||||
else pure Nothing
|
||||
atomically . writeTVar s $ Just (a1, a2)
|
||||
startCleanupManager
|
||||
when enableExpireCIs startExpireCIs
|
||||
pure a1
|
||||
startCleanupManager = do
|
||||
cleanupAsync <- asks cleanupManagerAsync
|
||||
readTVarIO cleanupAsync >>= \case
|
||||
Nothing -> do
|
||||
a <- Just <$> async (void . runExceptT $ cleanupManager user)
|
||||
atomically $ writeTVar cleanupAsync a
|
||||
_ -> pure ()
|
||||
startExpireCIs = do
|
||||
expireAsync <- asks expireCIsAsync
|
||||
readTVarIO expireAsync >>= \case
|
||||
|
@ -288,20 +299,25 @@ processChatCommand = \case
|
|||
APIGetChatItems _pagination -> pure $ chatCmdError "not implemented"
|
||||
APISendMessage (ChatRef cType chatId) (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
assertDirectAllowed user MDSnd ct XMsgNew_
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
if isVoice mc && not (featureAllowed SCFVoice forUser ct)
|
||||
then pure $ chatCmdError $ "feature not allowed " <> T.unpack (chatFeatureToText CFVoice)
|
||||
else do
|
||||
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
|
||||
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_
|
||||
timed_ <- msgTimed ct
|
||||
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_ timed_
|
||||
(msg@SndMessage {sharedMsgId}, _) <- sendDirectContactMessage ct (XMsgNew msgContainer)
|
||||
case ft_ of
|
||||
Just ft@FileTransferMeta {fileInline = Just IFMSent} ->
|
||||
sendDirectFileInline ct ft sharedMsgId
|
||||
_ -> pure ()
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_
|
||||
ci <- saveSndChatItemTimed user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_
|
||||
case timed_ of
|
||||
Just CITimed {ttl, deleteAt = Just deleteAt} ->
|
||||
when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) deleteAt
|
||||
_ -> pure ()
|
||||
setActive $ ActiveC c
|
||||
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
|
||||
where
|
||||
|
@ -321,9 +337,16 @@ processChatCommand = \case
|
|||
_ -> pure CIFSSndStored
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus}
|
||||
pure (fileInvitation, ciFile, ft)
|
||||
prepareMsg :: Maybe FileInvitation -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
||||
prepareMsg fileInvitation_ = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (extMsgContent mc fileInvitation_), Nothing)
|
||||
msgTimed :: Contact -> m (Maybe CITimed)
|
||||
msgTimed ct = case contactCITimedTTL ct of
|
||||
Just ttl -> do
|
||||
ts <- liftIO getCurrentTime
|
||||
let deleteAt = addUTCTime (toEnum 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_ $ ttl_ timed_), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getDirectChatItem db userId chatId quotedItemId
|
||||
|
@ -331,7 +354,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_), Just quotedItem)
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (extMsgContent mc fileInvitation_ $ ttl_ timed_), Just quotedItem)
|
||||
where
|
||||
quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = True}} = throwChatError CEInvalidQuote
|
||||
|
@ -339,16 +362,21 @@ processChatCommand = \case
|
|||
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
|
||||
quoteData _ = throwChatError CEInvalidQuote
|
||||
CTGroup -> do
|
||||
Group gInfo@GroupInfo {membership, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
|
||||
Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
if isVoice mc && not (groupFeatureAllowed SGFVoice gInfo)
|
||||
then pure $ chatCmdError $ "feature not allowed " <> T.unpack (groupFeatureToText GFVoice)
|
||||
else do
|
||||
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length $ filter memberCurrent ms)
|
||||
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_ membership
|
||||
timed_ <- msgTimed 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_
|
||||
ci <- saveSndChatItemTimed user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_
|
||||
case timed_ of
|
||||
Just CITimed {ttl, deleteAt = Just deleteAt} ->
|
||||
when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) deleteAt
|
||||
_ -> pure ()
|
||||
setActive $ ActiveG gName
|
||||
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
|
||||
where
|
||||
|
@ -362,6 +390,13 @@ 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 (toEnum 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
|
||||
|
@ -370,9 +405,9 @@ processChatCommand = \case
|
|||
void . withStore' $ \db -> createSndGroupInlineFT db m conn ft
|
||||
sendMemberFileInline m conn ft sharedMsgId
|
||||
_ -> pure ()
|
||||
prepareMsg :: Maybe FileInvitation -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
|
||||
prepareMsg fileInvitation_ membership = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (extMsgContent mc fileInvitation_), Nothing)
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
|
||||
prepareMsg fileInvitation_ timed_ membership = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (extMsgContent mc fileInvitation_ $ ttl_ timed_), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getGroupChatItem db user chatId quotedItemId
|
||||
|
@ -380,7 +415,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_), Just quotedItem)
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (extMsgContent mc fileInvitation_ $ ttl_ timed_), Just quotedItem)
|
||||
where
|
||||
quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = True}} _ = throwChatError CEInvalidQuote
|
||||
|
@ -390,6 +425,8 @@ processChatCommand = \case
|
|||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError "not supported"
|
||||
where
|
||||
ttl_ :: Maybe CITimed -> Maybe Int
|
||||
ttl_ timed_ = timed_ >>= \CITimed {ttl} -> Just ttl
|
||||
quoteContent :: forall d. MsgContent -> Maybe (CIFile d) -> MsgContent
|
||||
quoteContent qmc ciFile_
|
||||
| replaceContent = MCText qTextOrFile
|
||||
|
@ -448,14 +485,14 @@ processChatCommand = \case
|
|||
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user@User {userId} -> withChatLock "deleteChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {localDisplayName = c}, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
|
||||
assertDirectAllowed user MDSnd ct XMsgDel_
|
||||
case (mode, msgDir, itemSharedMsgId) of
|
||||
(CIDMInternal, _, _) -> deleteDirectCI user ct ci True
|
||||
(CIDMInternal, _, _) -> deleteDirectCI user ct ci True False
|
||||
(CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
|
||||
assertDirectAllowed user MDSnd ct XMsgDel_
|
||||
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId)
|
||||
setActive $ ActiveC c
|
||||
if featureAllowed SCFFullDelete forUser ct
|
||||
then deleteDirectCI user ct ci True
|
||||
then deleteDirectCI user ct ci True False
|
||||
else markDirectCIDeleted user ct ci msgId True
|
||||
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
CTGroup -> do
|
||||
|
@ -463,19 +500,35 @@ processChatCommand = \case
|
|||
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId
|
||||
case (mode, msgDir, itemSharedMsgId) of
|
||||
(CIDMInternal, _, _) -> deleteGroupCI user gInfo ci True
|
||||
(CIDMInternal, _, _) -> deleteGroupCI user gInfo ci True False
|
||||
(CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
|
||||
SndMessage {msgId} <- sendGroupMessage gInfo ms (XMsgDel itemSharedMId)
|
||||
setActive $ ActiveG gName
|
||||
if groupFeatureAllowed SGFFullDelete gInfo
|
||||
then deleteGroupCI user gInfo ci True
|
||||
then deleteGroupCI user gInfo ci True False
|
||||
else markGroupCIDeleted user gInfo ci msgId True
|
||||
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError "not supported"
|
||||
APIChatRead (ChatRef cType chatId) fromToIds -> case cType of
|
||||
CTDirect -> withStore' (\db -> updateDirectChatItemsRead db chatId fromToIds) $> CRCmdOk
|
||||
CTGroup -> withStore' (\db -> updateGroupChatItemsRead db chatId fromToIds) $> CRCmdOk
|
||||
APIChatRead (ChatRef cType chatId) fromToIds -> withUser $ \user@User {userId} -> case cType of
|
||||
CTDirect -> do
|
||||
timedItems <- withStore' $ \db -> getDirectUnreadTimedItems db user chatId fromToIds
|
||||
ts <- liftIO getCurrentTime
|
||||
forM_ timedItems $ \(itemId, ttl) -> do
|
||||
let deleteAt = addUTCTime (toEnum ttl) ts
|
||||
withStore' $ \db -> setDirectChatItemDeleteAt db user chatId itemId deleteAt
|
||||
when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTDirect chatId, itemId) deleteAt
|
||||
withStore' $ \db -> updateDirectChatItemsRead db userId chatId fromToIds
|
||||
pure CRChatRead
|
||||
CTGroup -> do
|
||||
timedItems <- withStore' $ \db -> getGroupUnreadTimedItems db user chatId fromToIds
|
||||
ts <- liftIO getCurrentTime
|
||||
forM_ timedItems $ \(itemId, ttl) -> do
|
||||
let deleteAt = addUTCTime (toEnum ttl) ts
|
||||
withStore' $ \db -> setGroupChatItemDeleteAt db user chatId itemId deleteAt
|
||||
when (ttl <= cleanupManagerInterval) $ startTimedItemThread user (ChatRef CTGroup chatId, itemId) deleteAt
|
||||
withStore' $ \db -> updateGroupChatItemsRead db userId chatId fromToIds
|
||||
pure CRChatRead
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError "not supported"
|
||||
APIChatUnread (ChatRef cType chatId) unreadChat -> withUser $ \user -> case cType of
|
||||
|
@ -606,7 +659,7 @@ processChatCommand = \case
|
|||
withCurrentCall contactId $ \userId ct Call {chatItemId, callState} -> case callState of
|
||||
CallInvitationReceived {} -> do
|
||||
let aciContent = ACIContent SMDRcv $ CIRcvCall CISCallRejected 0
|
||||
withStore' $ \db -> updateDirectChatItemsRead db contactId $ Just (chatItemId, chatItemId)
|
||||
withStore' $ \db -> updateDirectChatItemsRead db userId contactId $ Just (chatItemId, chatItemId)
|
||||
updateDirectChatItemView userId ct chatItemId aciContent Nothing $> Nothing
|
||||
_ -> throwChatError . CECallState $ callStateTag callState
|
||||
APISendCallOffer contactId WebRTCCallOffer {callType, rtcSession} ->
|
||||
|
@ -618,7 +671,7 @@ processChatCommand = \case
|
|||
callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey}
|
||||
aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0
|
||||
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XCallOffer callId offer)
|
||||
withStore' $ \db -> updateDirectChatItemsRead db contactId $ Just (chatItemId, chatItemId)
|
||||
withStore' $ \db -> updateDirectChatItemsRead db userId contactId $ Just (chatItemId, chatItemId)
|
||||
updateDirectChatItemView userId ct chatItemId aciContent $ Just msgId
|
||||
pure $ Just call {callState = callState'}
|
||||
_ -> throwChatError . CECallState $ callStateTag callState
|
||||
|
@ -866,7 +919,7 @@ processChatCommand = \case
|
|||
forM_ cts $ \ct ->
|
||||
void
|
||||
( do
|
||||
(sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
|
||||
(sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing Nothing))
|
||||
saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing
|
||||
)
|
||||
`catchError` (toView . CRChatError)
|
||||
|
@ -1645,6 +1698,52 @@ subscribeUserConnections agentBatchSubscribe user = do
|
|||
Just _ -> Nothing
|
||||
_ -> Just . ChatError . CEAgentNoSubResult $ AgentConnId connId
|
||||
|
||||
cleanupManagerInterval :: Int
|
||||
cleanupManagerInterval = 1800 -- 30 minutes
|
||||
|
||||
cleanupManager :: forall m. ChatMonad m => User -> m ()
|
||||
cleanupManager user = do
|
||||
forever $ do
|
||||
flip catchError (toView . CRChatError) $ do
|
||||
agentStarted <- asks agentAsync
|
||||
atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry
|
||||
cleanupTimedItems
|
||||
threadDelay $ cleanupManagerInterval * 1000000
|
||||
where
|
||||
cleanupTimedItems = do
|
||||
ts <- liftIO getCurrentTime
|
||||
let startTimedThreadCutoff = addUTCTime (toEnum cleanupManagerInterval) ts
|
||||
timedItems <- withStore' $ \db -> getTimedItems db user startTimedThreadCutoff
|
||||
forM_ timedItems $ uncurry (startTimedItemThread user)
|
||||
|
||||
startTimedItemThread :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m ()
|
||||
startTimedItemThread user itemRef deleteAt = do
|
||||
itemThreads <- asks timedItemThreads
|
||||
threadTVar_ <- atomically $ do
|
||||
exists <- TM.member itemRef itemThreads
|
||||
if exists
|
||||
then do
|
||||
threadTVar <- newTVar Nothing
|
||||
TM.insert itemRef threadTVar itemThreads
|
||||
pure $ Just threadTVar
|
||||
else pure Nothing
|
||||
forM_ threadTVar_ $ \threadTVar -> do
|
||||
tId <- mkWeakThreadId =<< deleteTimedItem user itemRef deleteAt `forkFinally` const (atomically $ TM.delete itemRef itemThreads)
|
||||
atomically $ writeTVar threadTVar (Just tId)
|
||||
|
||||
deleteTimedItem :: ChatMonad m => User -> (ChatRef, ChatItemId) -> UTCTime -> m ()
|
||||
deleteTimedItem user@User {userId} (ChatRef cType chatId, itemId) deleteAt = do
|
||||
ts <- liftIO getCurrentTime
|
||||
threadDelay $ diffInMicros deleteAt ts
|
||||
case cType of
|
||||
CTDirect -> do
|
||||
(ct, ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db userId chatId itemId
|
||||
deleteDirectCI user ct ci True True >>= toView
|
||||
CTGroup -> do
|
||||
(gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
|
||||
deleteGroupCI user gInfo ci True True >>= toView
|
||||
_ -> toView . CRChatError . ChatError $ CEInternalError "bad deleteTimedItem cType"
|
||||
|
||||
expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m ()
|
||||
expireChatItems user ttl sync = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
|
@ -1846,7 +1945,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
|
||||
Just (UserContactLink {autoAccept = Just AutoAccept {autoReply = mc_}}, groupId_) -> do
|
||||
forM_ mc_ $ \mc -> do
|
||||
(msg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
|
||||
(msg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing Nothing))
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
|
||||
forM_ groupId_ $ \groupId -> do
|
||||
|
@ -2315,9 +2414,12 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
setActive $ ActiveC c
|
||||
where
|
||||
newChatItem ciContent ciFile_ = do
|
||||
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta ciContent ciFile_
|
||||
ci <- saveRcvChatItemTimed user (CDDirectRcv ct) msg msgMeta ciContent ciFile_ timed
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
|
||||
pure ci
|
||||
timed = case (contactCITimedTTL ct, mcExtMsgContent mc) of
|
||||
(Just _, ExtMsgContent _ _ (Just ttl) _) -> Just $ CITimed ttl Nothing
|
||||
_ -> Nothing
|
||||
|
||||
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
|
||||
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv@FileInvitation {fileName, fileSize} -> do
|
||||
|
@ -2341,9 +2443,11 @@ 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...
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing timed
|
||||
toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
|
||||
setActive $ ActiveC c
|
||||
where
|
||||
timed = contactCITimedTTL ct >>= \ttl -> Just $ CITimed ttl Nothing
|
||||
_ -> throwError e
|
||||
where
|
||||
updateRcvChatItem = do
|
||||
|
@ -2365,7 +2469,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
case msgDir of
|
||||
SMDRcv ->
|
||||
if featureAllowed SCFFullDelete forContact ct
|
||||
then deleteDirectCI user ct ci False >>= toView
|
||||
then deleteDirectCI user ct ci False False >>= toView
|
||||
else markDirectCIDeleted user ct ci msgId False >>= toView
|
||||
SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete"
|
||||
|
||||
|
@ -2383,9 +2487,12 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
setActive $ ActiveG g
|
||||
where
|
||||
newChatItem ciContent ciFile_ = do
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta ciContent ciFile_
|
||||
ci <- saveRcvChatItemTimed user (CDGroupRcv gInfo m) msg msgMeta ciContent ciFile_ timed
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
pure ci
|
||||
timed = case (groupCITimedTTL gInfo, mcExtMsgContent mc) of
|
||||
(Just _, ExtMsgContent _ _ (Just ttl) _) -> Just $ CITimed ttl Nothing
|
||||
_ -> Nothing
|
||||
|
||||
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m ()
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta =
|
||||
|
@ -2395,9 +2502,11 @@ 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...
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta (CIRcvMsgContent mc) Nothing timed
|
||||
toView . CRChatItemUpdated $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
|
||||
setActive $ ActiveG g
|
||||
where
|
||||
timed = groupCITimedTTL gInfo >>= \ttl -> Just $ CITimed ttl Nothing
|
||||
_ -> throwError e
|
||||
where
|
||||
updateRcvChatItem = do
|
||||
|
@ -2420,7 +2529,7 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage =
|
|||
if sameMemberId memberId m
|
||||
then
|
||||
if groupFeatureAllowed SGFFullDelete gInfo
|
||||
then deleteGroupCI user gInfo ci False >>= toView
|
||||
then deleteGroupCI user gInfo ci False False >>= toView
|
||||
else markGroupCIDeleted user gInfo ci msgId False >>= toView
|
||||
else messageError "x.msg.del: group member attempted to delete a message of another member" -- shouldn't happen now that query includes group member id
|
||||
(SMDSnd, _) -> messageError "x.msg.del: group member attempted invalid message delete"
|
||||
|
@ -3151,41 +3260,49 @@ saveRcvMSG Connection {connId} connOrGroupId agentMsgMeta msgBody agentAckCmdId
|
|||
withStore' $ \db -> createNewMessageAndRcvMsgDelivery db connOrGroupId newMsg sharedMsgId_ rcvMsgDelivery
|
||||
|
||||
saveSndChatItem :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> m (ChatItem c 'MDSnd)
|
||||
saveSndChatItem user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem = do
|
||||
saveSndChatItem user cd msg content ciFile quotedItem =
|
||||
saveSndChatItemTimed user cd msg content ciFile quotedItem Nothing
|
||||
|
||||
saveSndChatItemTimed :: ChatMonad m => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CITimed -> m (ChatItem c 'MDSnd)
|
||||
saveSndChatItemTimed user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem timed = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
ciId <- withStore' $ \db -> createNewSndChatItem db user cd msg content quotedItem createdAt
|
||||
ciId <- withStore' $ \db -> createNewSndChatItem db user cd msg content quotedItem createdAt timed
|
||||
forM_ ciFile $ \CIFile {fileId} -> withStore' $ \db -> updateFileTransferChatItemId db fileId ciId
|
||||
liftIO $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) createdAt createdAt
|
||||
liftIO $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) createdAt createdAt timed
|
||||
|
||||
saveRcvChatItem :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} = saveRcvChatItem' user cd msg sharedMsgId_
|
||||
saveRcvChatItem user cd msg msgMeta content ciFile =
|
||||
saveRcvChatItemTimed user cd msg msgMeta content ciFile Nothing
|
||||
|
||||
saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem' user cd msg sharedMsgId_ MsgMeta {broker = (_, brokerTs)} content ciFile = do
|
||||
saveRcvChatItemTimed :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItemTimed user cd msg@RcvMessage {sharedMsgId_} = saveRcvChatItem' user cd msg sharedMsgId_
|
||||
|
||||
saveRcvChatItem' :: ChatMonad m => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> MsgMeta -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> m (ChatItem c 'MDRcv)
|
||||
saveRcvChatItem' user cd msg sharedMsgId_ MsgMeta {broker = (_, brokerTs)} content ciFile timed = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
(ciId, quotedItem) <- withStore' $ \db -> createNewRcvChatItem db user cd msg sharedMsgId_ content brokerTs createdAt
|
||||
(ciId, quotedItem) <- withStore' $ \db -> createNewRcvChatItem db user cd msg sharedMsgId_ content brokerTs createdAt timed
|
||||
forM_ ciFile $ \CIFile {fileId} -> withStore' $ \db -> updateFileTransferChatItemId db fileId ciId
|
||||
liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ brokerTs createdAt
|
||||
liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ brokerTs createdAt timed
|
||||
|
||||
mkChatItem :: ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> ChatItemTs -> UTCTime -> IO (ChatItem c d)
|
||||
mkChatItem cd ciId content file quotedItem sharedMsgId itemTs currentTs = do
|
||||
mkChatItem :: ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> ChatItemTs -> UTCTime -> Maybe CITimed -> IO (ChatItem c d)
|
||||
mkChatItem cd ciId content file quotedItem sharedMsgId itemTs currentTs timed = do
|
||||
tz <- getCurrentTimeZone
|
||||
let itemText = ciContentToText content
|
||||
itemStatus = ciCreateStatus content
|
||||
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId False False tz currentTs itemTs currentTs currentTs
|
||||
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId False False tz currentTs itemTs currentTs currentTs timed
|
||||
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, file}
|
||||
|
||||
deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> m ChatResponse
|
||||
deleteDirectCI user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser = do
|
||||
deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> Bool -> m ChatResponse
|
||||
deleteDirectCI user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do
|
||||
deleteCIFile user file
|
||||
withStore' $ \db -> deleteDirectChatItem db user ct ci
|
||||
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser
|
||||
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser timed
|
||||
|
||||
deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> m ChatResponse
|
||||
deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser = do
|
||||
deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> m ChatResponse
|
||||
deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do
|
||||
deleteCIFile user file
|
||||
withStore' $ \db -> deleteGroupChatItem db user gInfo ci
|
||||
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) Nothing byUser
|
||||
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) Nothing byUser timed
|
||||
|
||||
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
deleteCIFile user file =
|
||||
|
@ -3196,12 +3313,12 @@ deleteCIFile user file =
|
|||
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> m ChatResponse
|
||||
markDirectCIDeleted user ct ci@(CChatItem msgDir deletedItem) msgId byUser = do
|
||||
toCi <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId
|
||||
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) (Just toCi) byUser
|
||||
pure $ CRChatItemDeleted (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) (Just toCi) byUser False
|
||||
|
||||
markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> m ChatResponse
|
||||
markGroupCIDeleted user gInfo ci@(CChatItem msgDir deletedItem) msgId byUser = do
|
||||
toCi <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId
|
||||
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) (Just toCi) byUser
|
||||
pure $ CRChatItemDeleted (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) (Just toCi) byUser False
|
||||
|
||||
createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId)
|
||||
createAgentConnectionAsync user cmdFunction enableNtfs cMode = do
|
||||
|
@ -3266,7 +3383,7 @@ createInternalChatItem user cd content itemTs_ = do
|
|||
createdAt <- liftIO getCurrentTime
|
||||
let itemTs = fromMaybe createdAt itemTs_
|
||||
ciId <- withStore' $ \db -> createNewChatItemNoMsg db user cd content itemTs createdAt
|
||||
ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing itemTs createdAt
|
||||
ci <- liftIO $ mkChatItem cd ciId content Nothing Nothing Nothing itemTs createdAt Nothing
|
||||
toView $ CRNewChatItem $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci
|
||||
|
||||
getCreateActiveUser :: SQLiteStore -> IO User
|
||||
|
|
|
@ -10,6 +10,7 @@
|
|||
|
||||
module Simplex.Chat.Controller where
|
||||
|
||||
import Control.Concurrent (ThreadId)
|
||||
import Control.Concurrent.Async (Async)
|
||||
import Control.Exception
|
||||
import Control.Monad.Except
|
||||
|
@ -53,6 +54,7 @@ import Simplex.Messaging.Protocol (AProtocolType, CorrId, MsgFlags)
|
|||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost)
|
||||
import System.IO (Handle)
|
||||
import System.Mem.Weak (Weak)
|
||||
import UnliftIO.STM
|
||||
|
||||
versionNumber :: String
|
||||
|
@ -121,7 +123,9 @@ data ChatController = ChatController
|
|||
filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps,
|
||||
incognitoMode :: TVar Bool,
|
||||
expireCIsAsync :: TVar (Maybe (Async ())),
|
||||
expireCIs :: TVar Bool
|
||||
expireCIs :: TVar Bool,
|
||||
cleanupManagerAsync :: TVar (Maybe (Async ())),
|
||||
timedItemThreads :: TMap (ChatRef, ChatItemId) (TVar (Maybe (Weak ThreadId)))
|
||||
}
|
||||
|
||||
data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSMessages | HSSettings
|
||||
|
@ -292,8 +296,9 @@ data ChatResponse
|
|||
| CRNewChatItem {chatItem :: AChatItem}
|
||||
| CRChatItemStatusUpdated {chatItem :: AChatItem}
|
||||
| CRChatItemUpdated {chatItem :: AChatItem}
|
||||
| CRChatItemDeleted {deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool}
|
||||
| CRChatItemDeleted {deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool, timed :: Bool}
|
||||
| CRChatItemDeletedNotFound {contact :: Contact, sharedMsgId :: SharedMsgId}
|
||||
| CRChatRead
|
||||
| CRBroadcastSent MsgContent Int ZonedTime
|
||||
| CRMsgIntegrityError {msgError :: MsgErrorType}
|
||||
| CRCmdAccepted {corr :: CorrId}
|
||||
|
@ -566,6 +571,7 @@ data ChatErrorType
|
|||
| CEAgentNoSubResult {agentConnId :: AgentConnId}
|
||||
| CECommandError {message :: String}
|
||||
| CEAgentCommandError {message :: String}
|
||||
| CEInternalError {message :: String}
|
||||
deriving (Show, Exception, Generic)
|
||||
|
||||
instance ToJSON ChatErrorType where
|
||||
|
|
|
@ -39,13 +39,23 @@ import Simplex.Messaging.Protocol (MsgBody)
|
|||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
|
||||
data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
|
||||
deriving (Show, Generic)
|
||||
deriving (Eq, Show, Ord, Generic)
|
||||
|
||||
serializeChatType :: ChatType -> String
|
||||
serializeChatType = \case
|
||||
CTDirect -> "@"
|
||||
CTGroup -> "#"
|
||||
CTContactRequest -> "?" -- this isn't being parsed
|
||||
CTContactConnection -> ":"
|
||||
|
||||
data ChatName = ChatName ChatType Text
|
||||
deriving (Show)
|
||||
|
||||
data ChatRef = ChatRef ChatType Int64
|
||||
deriving (Show)
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
serializeChatRef :: ChatRef -> String
|
||||
serializeChatRef (ChatRef cType chatId) = serializeChatType cType <> show chatId
|
||||
|
||||
instance ToJSON ChatType where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CT"
|
||||
|
@ -66,6 +76,13 @@ chatInfoUpdatedAt = \case
|
|||
ContactRequest UserContactRequest {updatedAt} -> updatedAt
|
||||
ContactConnection PendingContactConnection {updatedAt} -> updatedAt
|
||||
|
||||
chatInfoToRef :: ChatInfo c -> ChatRef
|
||||
chatInfoToRef = \case
|
||||
DirectChat Contact {contactId} -> ChatRef CTDirect contactId
|
||||
GroupChat GroupInfo {groupId} -> ChatRef CTGroup groupId
|
||||
ContactRequest UserContactRequest {contactRequestId} -> ChatRef CTContactRequest contactRequestId
|
||||
ContactConnection PendingContactConnection {pccConnId} -> ChatRef CTContactConnection pccConnId
|
||||
|
||||
data JSONChatInfo
|
||||
= JCInfoDirect {contact :: Contact}
|
||||
| JCInfoGroup {groupInfo :: GroupInfo}
|
||||
|
@ -259,20 +276,41 @@ data CIMeta (d :: MsgDirection) = CIMeta
|
|||
editable :: Bool,
|
||||
localItemTs :: ZonedTime,
|
||||
createdAt :: UTCTime,
|
||||
updatedAt :: UTCTime
|
||||
updatedAt :: UTCTime,
|
||||
timed :: Maybe CITimed
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta d
|
||||
mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited tz currentTs itemTs createdAt updatedAt =
|
||||
mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> Maybe CITimed -> CIMeta d
|
||||
mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited tz currentTs itemTs createdAt updatedAt timed =
|
||||
let localItemTs = utcToZonedTime tz itemTs
|
||||
editable = case itemContent of
|
||||
CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && not itemDeleted
|
||||
_ -> False
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, editable, localItemTs, createdAt, updatedAt}
|
||||
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, editable, localItemTs, createdAt, updatedAt, timed}
|
||||
|
||||
instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data CITimed = CITimed
|
||||
{ ttl :: Int, -- seconds
|
||||
deleteAt :: Maybe UTCTime
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON CITimed where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
contactCITimedTTL :: Contact -> Maybe Int
|
||||
contactCITimedTTL Contact {mergedPreferences = ContactUserPreferences {timedMessages = ContactUserPreference {enabled, userPreference}}}
|
||||
| forUser enabled && forContact enabled = case userPreference of
|
||||
CUPContact TimedMessagesPreference {ttl = t} -> Just t
|
||||
CUPUser TimedMessagesPreference {ttl = t} -> Just t
|
||||
| otherwise = Nothing
|
||||
|
||||
groupCITimedTTL :: GroupInfo -> Maybe Int
|
||||
groupCITimedTTL GroupInfo {fullGroupPreferences = FullGroupPreferences {timedMessages = TimedMessagesGroupPreference {enable, ttl}}}
|
||||
| enable == FEOn = Just ttl
|
||||
| otherwise = Nothing
|
||||
|
||||
data CIQuote (c :: ChatType) = CIQuote
|
||||
{ chatDir :: CIQDirection c,
|
||||
itemId :: Maybe ChatItemId, -- Nothing in case MsgRef references the item the user did not receive yet
|
||||
|
|
16
src/Simplex/Chat/Migrations/M20221212_chat_items_timed.hs
Normal file
16
src/Simplex/Chat/Migrations/M20221212_chat_items_timed.hs
Normal file
|
@ -0,0 +1,16 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20221212_chat_items_timed where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20221212_chat_items_timed :: Query
|
||||
m20221212_chat_items_timed =
|
||||
[sql|
|
||||
ALTER TABLE chat_items ADD COLUMN timed_ttl INTEGER;
|
||||
|
||||
ALTER TABLE chat_items ADD COLUMN timed_delete_at TEXT;
|
||||
|
||||
CREATE INDEX idx_chat_items_timed_delete_at ON chat_items(timed_delete_at);
|
||||
|]
|
|
@ -365,7 +365,9 @@ CREATE TABLE chat_items(
|
|||
quoted_content TEXT,
|
||||
quoted_sent INTEGER,
|
||||
quoted_member_id BLOB,
|
||||
item_edited INTEGER
|
||||
item_edited INTEGER,
|
||||
timed_ttl INTEGER,
|
||||
timed_delete_at TEXT
|
||||
);
|
||||
CREATE TABLE chat_item_messages(
|
||||
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
|
||||
|
@ -456,3 +458,4 @@ CREATE UNIQUE INDEX idx_snd_files_last_inline_msg_delivery_id ON snd_files(
|
|||
CREATE INDEX idx_messages_connection_id ON messages(connection_id);
|
||||
CREATE INDEX idx_chat_items_group_member_id ON chat_items(group_member_id);
|
||||
CREATE INDEX idx_chat_items_contact_id ON chat_items(contact_id);
|
||||
CREATE INDEX idx_chat_items_timed_delete_at ON chat_items(timed_delete_at);
|
||||
|
|
|
@ -367,8 +367,8 @@ parseMsgContainer v =
|
|||
where
|
||||
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live"
|
||||
|
||||
extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent
|
||||
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing
|
||||
extMsgContent :: MsgContent -> Maybe FileInvitation -> Maybe Int -> ExtMsgContent
|
||||
extMsgContent mc file ttl = ExtMsgContent mc file ttl Nothing
|
||||
|
||||
instance FromJSON MsgContent where
|
||||
parseJSON (J.Object v) =
|
||||
|
|
|
@ -208,7 +208,11 @@ module Simplex.Chat.Store
|
|||
deleteGroupChatItem,
|
||||
markGroupChatItemDeleted,
|
||||
updateDirectChatItemsRead,
|
||||
getDirectUnreadTimedItems,
|
||||
setDirectChatItemDeleteAt,
|
||||
updateGroupChatItemsRead,
|
||||
getGroupUnreadTimedItems,
|
||||
setGroupChatItemDeleteAt,
|
||||
getSMPServers,
|
||||
overwriteSMPServers,
|
||||
createCall,
|
||||
|
@ -222,6 +226,7 @@ module Simplex.Chat.Store
|
|||
setConnConnReqInv,
|
||||
getXGrpMemIntroContDirect,
|
||||
getXGrpMemIntroContGroup,
|
||||
getTimedItems,
|
||||
getChatItemTTL,
|
||||
setChatItemTTL,
|
||||
getContactExpiredFileInfo,
|
||||
|
@ -255,7 +260,7 @@ import Data.Functor (($>))
|
|||
import Data.Int (Int64)
|
||||
import Data.List (sortBy, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
@ -310,6 +315,7 @@ import Simplex.Chat.Migrations.M20221130_delete_item_deleted
|
|||
import Simplex.Chat.Migrations.M20221209_verified_connection
|
||||
import Simplex.Chat.Migrations.M20221210_idxs
|
||||
import Simplex.Chat.Migrations.M20221211_group_description
|
||||
import Simplex.Chat.Migrations.M20221212_chat_items_timed
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
|
||||
|
@ -363,7 +369,8 @@ schemaMigrations =
|
|||
("20221130_delete_item_deleted", m20221130_delete_item_deleted),
|
||||
("20221209_verified_connection", m20221209_verified_connection),
|
||||
("20221210_idxs", m20221210_idxs),
|
||||
("20221211_group_description", m20221211_group_description)
|
||||
("20221211_group_description", m20221211_group_description),
|
||||
("20221212_chat_items_timed", m20221212_chat_items_timed)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
@ -3130,7 +3137,7 @@ deletePendingGroupMessage db groupMemberId messageId =
|
|||
|
||||
type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId)
|
||||
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> UTCTime -> IO ChatItemId
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> UTCTime -> Maybe CITimed -> IO ChatItemId
|
||||
createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem createdAt =
|
||||
createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow createdAt createdAt
|
||||
where
|
||||
|
@ -3146,9 +3153,9 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
|
|||
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
|
||||
CIQGroupRcv Nothing -> (Just False, Nothing)
|
||||
|
||||
createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c))
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent itemTs createdAt = do
|
||||
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemTs createdAt
|
||||
createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> UTCTime -> UTCTime -> Maybe CITimed -> IO (ChatItemId, Maybe (CIQuote c))
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent itemTs createdAt timed = do
|
||||
ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemTs createdAt timed
|
||||
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
||||
pure (ciId, quotedItem)
|
||||
where
|
||||
|
@ -3163,14 +3170,14 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} shar
|
|||
(Just $ Just userMemberId == memberId, memberId)
|
||||
|
||||
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItemNoMsg db user chatDirection ciContent =
|
||||
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow
|
||||
createNewChatItemNoMsg db user chatDirection ciContent itemTs createdAt =
|
||||
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow itemTs createdAt Nothing
|
||||
where
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemTs createdAt = do
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> UTCTime -> UTCTime -> Maybe CITimed -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemTs createdAt timed = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
|
@ -3178,18 +3185,22 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
|
|||
-- user and IDs
|
||||
user_id, created_by_msg_id, contact_id, group_id, group_member_id,
|
||||
-- meta
|
||||
item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at,
|
||||
item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, timed_ttl, timed_delete_at,
|
||||
-- quote
|
||||
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((userId, msgId_) :. idsRow :. itemRow :. quoteRow)
|
||||
ciId <- insertedRowId db
|
||||
forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt
|
||||
pure ciId
|
||||
where
|
||||
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId, UTCTime, UTCTime)
|
||||
itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId, createdAt, createdAt)
|
||||
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId, UTCTime, UTCTime, Maybe Int, Maybe UTCTime)
|
||||
itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId, createdAt, createdAt, timedTTL, timedDeleteAt)
|
||||
where
|
||||
(timedTTL, timedDeleteAt) = case timed of
|
||||
Just CITimed {ttl, deleteAt} -> (Just ttl, deleteAt)
|
||||
Nothing -> (Nothing, Nothing)
|
||||
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
idsRow = case chatDirection of
|
||||
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
|
@ -3292,7 +3303,7 @@ getDirectChatPreviews_ db user@User {userId} = do
|
|||
-- ChatStats
|
||||
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), ct.unread_chat,
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
||||
-- DirectQuote
|
||||
|
@ -3357,7 +3368,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
|||
-- ChatStats
|
||||
COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), g.unread_chat,
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
||||
-- Maybe GroupMember - sender
|
||||
|
@ -3516,7 +3527,7 @@ getDirectChatLast_ db user@User {userId} contactId count search = do
|
|||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
||||
-- DirectQuote
|
||||
|
@ -3547,7 +3558,7 @@ getDirectChatAfter_ db user@User {userId} contactId afterChatItemId count search
|
|||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
||||
-- DirectQuote
|
||||
|
@ -3579,7 +3590,7 @@ getDirectChatBefore_ db user@User {userId} contactId beforeChatItemId count sear
|
|||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
||||
-- DirectQuote
|
||||
|
@ -3925,7 +3936,7 @@ getDirectChatItem db userId contactId itemId = ExceptT $ do
|
|||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
||||
-- DirectQuote
|
||||
|
@ -4026,7 +4037,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
|||
[sql|
|
||||
SELECT
|
||||
-- ChatItem
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at,
|
||||
i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at,
|
||||
-- CIFile
|
||||
f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status,
|
||||
-- GroupMember
|
||||
|
@ -4153,8 +4164,8 @@ toChatItemRef = \case
|
|||
(itemId, Nothing, Just groupId) -> Right (itemId, ChatRef CTGroup groupId)
|
||||
(itemId, _, _) -> Left $ SEBadChatItem itemId
|
||||
|
||||
updateDirectChatItemsRead :: DB.Connection -> Int64 -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateDirectChatItemsRead db contactId itemsRange_ = do
|
||||
updateDirectChatItemsRead :: DB.Connection -> UserId -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateDirectChatItemsRead db userId contactId itemsRange_ = do
|
||||
currentTs <- getCurrentTime
|
||||
case itemsRange_ of
|
||||
Just (fromItemId, toItemId) ->
|
||||
|
@ -4162,20 +4173,48 @@ updateDirectChatItemsRead db contactId itemsRange_ = do
|
|||
db
|
||||
[sql|
|
||||
UPDATE chat_items SET item_status = ?, updated_at = ?
|
||||
WHERE contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
|
||||
WHERE user_id = ? AND contact_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
|
||||
|]
|
||||
(CISRcvRead, currentTs, contactId, fromItemId, toItemId, CISRcvNew)
|
||||
(userId, CISRcvRead, currentTs, contactId, fromItemId, toItemId, CISRcvNew)
|
||||
_ ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items SET item_status = ?, updated_at = ?
|
||||
WHERE contact_id = ? AND item_status = ?
|
||||
WHERE user_id = ? AND contact_id = ? AND item_status = ?
|
||||
|]
|
||||
(CISRcvRead, currentTs, contactId, CISRcvNew)
|
||||
(userId, CISRcvRead, currentTs, contactId, CISRcvNew)
|
||||
|
||||
updateGroupChatItemsRead :: DB.Connection -> Int64 -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateGroupChatItemsRead db groupId itemsRange_ = do
|
||||
getDirectUnreadTimedItems :: DB.Connection -> User -> ContactId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)]
|
||||
getDirectUnreadTimedItems db User {userId} contactId itemsRange_ = case itemsRange_ of
|
||||
Just (fromItemId, toItemId) ->
|
||||
DB.query
|
||||
db
|
||||
[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
|
||||
|]
|
||||
(userId, contactId, fromItemId, toItemId, CISRcvNew)
|
||||
_ ->
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id, timed_ttl
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND contact_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL
|
||||
|]
|
||||
(userId, contactId, CISRcvNew)
|
||||
|
||||
setDirectChatItemDeleteAt :: DB.Connection -> User -> ContactId -> ChatItemId -> UTCTime -> IO ()
|
||||
setDirectChatItemDeleteAt db User {userId} contactId chatItemId deleteAt =
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?"
|
||||
(deleteAt, userId, contactId, chatItemId)
|
||||
|
||||
updateGroupChatItemsRead :: DB.Connection -> UserId -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO ()
|
||||
updateGroupChatItemsRead db userId groupId itemsRange_ = do
|
||||
currentTs <- getCurrentTime
|
||||
case itemsRange_ of
|
||||
Just (fromItemId, toItemId) ->
|
||||
|
@ -4183,17 +4222,45 @@ updateGroupChatItemsRead db groupId itemsRange_ = do
|
|||
db
|
||||
[sql|
|
||||
UPDATE chat_items SET item_status = ?, updated_at = ?
|
||||
WHERE group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
|
||||
WHERE user_id = ? AND group_id = ? AND chat_item_id >= ? AND chat_item_id <= ? AND item_status = ?
|
||||
|]
|
||||
(CISRcvRead, currentTs, groupId, fromItemId, toItemId, CISRcvNew)
|
||||
(userId, CISRcvRead, currentTs, groupId, fromItemId, toItemId, CISRcvNew)
|
||||
_ ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items SET item_status = ?, updated_at = ?
|
||||
WHERE group_id = ? AND item_status = ?
|
||||
WHERE user_id = ? AND group_id = ? AND item_status = ?
|
||||
|]
|
||||
(CISRcvRead, currentTs, groupId, CISRcvNew)
|
||||
(userId, CISRcvRead, currentTs, groupId, CISRcvNew)
|
||||
|
||||
getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe (ChatItemId, ChatItemId) -> IO [(ChatItemId, Int)]
|
||||
getGroupUnreadTimedItems db User {userId} groupId itemsRange_ = case itemsRange_ of
|
||||
Just (fromItemId, toItemId) ->
|
||||
DB.query
|
||||
db
|
||||
[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
|
||||
|]
|
||||
(userId, groupId, fromItemId, toItemId, CISRcvNew)
|
||||
_ ->
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id, timed_ttl
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND group_id = ? AND item_status = ? AND timed_ttl IS NOT NULL AND timed_delete_at IS NULL
|
||||
|]
|
||||
(userId, groupId, CISRcvNew)
|
||||
|
||||
setGroupChatItemDeleteAt :: DB.Connection -> User -> GroupId -> ChatItemId -> UTCTime -> IO ()
|
||||
setGroupChatItemDeleteAt db User {userId} groupId chatItemId deleteAt =
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE chat_items SET timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?"
|
||||
(deleteAt, userId, groupId, chatItemId)
|
||||
|
||||
type ChatStatsRow = (Int, ChatItemId, Bool)
|
||||
|
||||
|
@ -4202,9 +4269,9 @@ toChatStats (unreadCount, minUnreadItemId, unreadChat) = ChatStats {unreadCount,
|
|||
|
||||
type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus)
|
||||
|
||||
type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime, UTCTime) :. MaybeCIFIleRow
|
||||
type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime, UTCTime, Maybe Int, Maybe UTCTime) :. MaybeCIFIleRow
|
||||
|
||||
type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. MaybeCIFIleRow
|
||||
type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime, Maybe UTCTime, Maybe Int, Maybe UTCTime) :. MaybeCIFIleRow
|
||||
|
||||
type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool)
|
||||
|
||||
|
@ -4218,7 +4285,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir
|
|||
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
|
||||
|
||||
toDirectChatItem :: TimeZone -> UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect)
|
||||
toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. quoteRow) =
|
||||
toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt, timedTTL, timedDeleteAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. quoteRow) =
|
||||
case (itemContent, itemStatus, fileStatus_) of
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) ->
|
||||
Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (maybeCIFile fileStatus)
|
||||
|
@ -4240,11 +4307,16 @@ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStat
|
|||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, file}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
|
||||
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt updatedAt
|
||||
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt updatedAt ciTimed
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed =
|
||||
case (timedTTL, timedDeleteAt) of
|
||||
(Just ttl, deleteAt) -> Just CITimed {ttl, deleteAt}
|
||||
_ -> Nothing
|
||||
|
||||
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) :. fileRow) :. quoteRow) =
|
||||
either (const []) (: []) $ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. fileRow) :. quoteRow)
|
||||
toDirectChatItemList tz currentTs (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt, timedTTL, timedDeleteAt) :. fileRow) :. quoteRow) =
|
||||
either (const []) (: []) $ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt, timedTTL, timedDeleteAt) :. fileRow) :. quoteRow)
|
||||
toDirectChatItemList _ _ _ = []
|
||||
|
||||
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
|
||||
|
@ -4260,7 +4332,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction
|
|||
direction _ _ = Nothing
|
||||
|
||||
toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup)
|
||||
toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do
|
||||
toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt, timedTTL, timedDeleteAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do
|
||||
let member_ = toMaybeGroupMember userContactId memberRow_
|
||||
let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
|
||||
case (itemContent, itemStatus, member_, fileStatus_) of
|
||||
|
@ -4284,11 +4356,16 @@ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemT
|
|||
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file}
|
||||
badItem = Left $ SEBadChatItem itemId
|
||||
ciMeta :: CIContent d -> CIStatus d -> CIMeta d
|
||||
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt updatedAt
|
||||
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt updatedAt ciTimed
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed =
|
||||
case (timedTTL, timedDeleteAt) of
|
||||
(Just ttl, deleteAt) -> Just CITimed {ttl, deleteAt}
|
||||
_ -> Nothing
|
||||
|
||||
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) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_)
|
||||
toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt, timedTTL, timedDeleteAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt, timedTTL, timedDeleteAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_)
|
||||
toGroupChatItemList _ _ _ _ = []
|
||||
|
||||
getSMPServers :: DB.Connection -> User -> IO [ServerCfg]
|
||||
|
@ -4485,6 +4562,24 @@ getXGrpMemIntroContGroup db User {userId} GroupMember {groupMemberId} = do
|
|||
Just connReq -> Just (hostConnId, connReq)
|
||||
_ -> Nothing
|
||||
|
||||
getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)]
|
||||
getTimedItems db User {userId} startTimedThreadCutoff =
|
||||
catMaybes . map toCIRefDeleteAt
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chat_item_id, contact_id, group_id, timed_delete_at
|
||||
FROM chat_items
|
||||
WHERE user_id = ? AND timed_delete_at IS NOT NULL AND timed_delete_at <= ?
|
||||
|]
|
||||
(userId, startTimedThreadCutoff)
|
||||
where
|
||||
toCIRefDeleteAt :: (ChatItemId, Maybe ContactId, Maybe GroupId, UTCTime) -> Maybe ((ChatRef, ChatItemId), UTCTime)
|
||||
toCIRefDeleteAt = \case
|
||||
(itemId, Just contactId, Nothing, deleteAt) -> Just ((ChatRef CTDirect contactId, itemId), deleteAt)
|
||||
(itemId, Nothing, Just groupId, deleteAt) -> Just ((ChatRef CTGroup groupId, itemId), deleteAt)
|
||||
_ -> 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)
|
||||
|
|
|
@ -35,7 +35,7 @@ runInputLoop ct cc = forever $ do
|
|||
s <- atomically . readTBQueue $ inputQ cc
|
||||
let bs = encodeUtf8 $ T.pack s
|
||||
cmd = parseChatCommand bs
|
||||
unless (isMessage cmd) $ echo s
|
||||
when (doEcho cmd) $ echo s
|
||||
r <- runReaderT (execChatCommand bs) cc
|
||||
case r of
|
||||
CRChatCmdError _ -> when (isMessage cmd) $ echo s
|
||||
|
@ -46,6 +46,9 @@ runInputLoop ct cc = forever $ do
|
|||
printToTerminal ct $ responseToView user testV ts r
|
||||
where
|
||||
echo s = printToTerminal ct [plain s]
|
||||
doEcho cmd = case cmd of
|
||||
Right APIChatRead {} -> False
|
||||
_ -> not $ isMessage cmd
|
||||
isMessage = \case
|
||||
Right SendMessage {} -> True
|
||||
Right SendFile {} -> True
|
||||
|
|
|
@ -12,6 +12,7 @@ import Control.Monad.IO.Unlift
|
|||
import Control.Monad.Reader
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.View
|
||||
import System.Console.ANSI.Types
|
||||
|
@ -74,13 +75,26 @@ withTermLock ChatTerminal {termLock} action = do
|
|||
atomically $ putTMVar termLock ()
|
||||
|
||||
runTerminalOutput :: ChatTerminal -> ChatController -> IO ()
|
||||
runTerminalOutput ct cc = do
|
||||
let testV = testView $ config cc
|
||||
runTerminalOutput ct ChatController {currentUser, inputQ, outputQ, config = ChatConfig {testView}} = do
|
||||
forever $ do
|
||||
(_, r) <- atomically . readTBQueue $ outputQ cc
|
||||
user <- readTVarIO $ currentUser cc
|
||||
(_, r) <- atomically $ readTBQueue outputQ
|
||||
case r of
|
||||
CRNewChatItem ci -> markChatItemRead ci
|
||||
CRChatItemUpdated ci -> markChatItemRead ci
|
||||
_ -> pure ()
|
||||
user <- readTVarIO currentUser
|
||||
ts <- getCurrentTime
|
||||
printToTerminal ct $ responseToView user testV ts r
|
||||
printToTerminal ct $ responseToView user testView ts r
|
||||
where
|
||||
markChatItemRead :: AChatItem -> IO ()
|
||||
markChatItemRead (AChatItem _ _ chat item@ChatItem {meta = CIMeta {itemStatus}}) =
|
||||
case (muted chat item, itemStatus) of
|
||||
(False, CISRcvNew) -> do
|
||||
let itemId = chatItemId' item
|
||||
chatRef = serializeChatRef $ chatInfoToRef chat
|
||||
cmd = "/_read chat " <> chatRef <> " from=" <> show itemId <> " to=" <> show itemId
|
||||
atomically $ writeTBQueue inputQ cmd
|
||||
_ -> pure ()
|
||||
|
||||
printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
|
||||
printToTerminal ct s =
|
||||
|
|
17
src/Simplex/Chat/Util.hs
Normal file
17
src/Simplex/Chat/Util.hs
Normal file
|
@ -0,0 +1,17 @@
|
|||
module Simplex.Chat.Util
|
||||
( diffInMicros,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Fixed (Fixed (MkFixed), Pico)
|
||||
import Data.Time (nominalDiffTimeToSeconds)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime)
|
||||
|
||||
diffInMicros :: UTCTime -> UTCTime -> Int
|
||||
diffInMicros a b = (`div` 1000000) $ diffInPicos a b
|
||||
|
||||
diffInPicos :: UTCTime -> UTCTime -> Int
|
||||
diffInPicos a b = fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b
|
||||
|
||||
fromPico :: Pico -> Integer
|
||||
fromPico (MkFixed i) = i
|
|
@ -82,8 +82,9 @@ responseToView user_ testView ts = \case
|
|||
CRLastMessages chatItems -> concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts) chatItems
|
||||
CRChatItemStatusUpdated _ -> []
|
||||
CRChatItemUpdated (AChatItem _ _ chat item) -> unmuted chat item $ viewItemUpdate chat item ts
|
||||
CRChatItemDeleted (AChatItem _ _ chat deletedItem) toItem byUser -> unmuted chat deletedItem $ viewItemDelete chat deletedItem (isJust toItem) byUser ts
|
||||
CRChatItemDeleted (AChatItem _ _ chat deletedItem) toItem byUser timed -> unmuted chat deletedItem $ viewItemDelete chat deletedItem (isJust toItem) byUser timed ts
|
||||
CRChatItemDeletedNotFound Contact {localDisplayName = c} _ -> [ttyFrom $ c <> "> [deleted - original message not found]"]
|
||||
CRChatRead -> []
|
||||
CRBroadcastSent mc n t -> viewSentBroadcast mc n ts t
|
||||
CRMsgIntegrityError mErr -> viewMsgIntegrityError mErr
|
||||
CRCmdAccepted _ -> []
|
||||
|
@ -251,10 +252,16 @@ responseToView user_ testView ts = \case
|
|||
contactList :: [ContactRef] -> String
|
||||
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
|
||||
unmuted :: ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
|
||||
unmuted chat ChatItem {chatDir} s = case (chat, chatDir) of
|
||||
(DirectChat Contact {chatSettings = DisableNtfs}, CIDirectRcv) -> []
|
||||
(GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _) -> []
|
||||
_ -> s
|
||||
unmuted chat chatItem s =
|
||||
if muted chat chatItem
|
||||
then []
|
||||
else s
|
||||
|
||||
muted :: ChatInfo c -> ChatItem c d -> Bool
|
||||
muted chat ChatItem {chatDir} = case (chat, chatDir) of
|
||||
(DirectChat Contact {chatSettings = DisableNtfs}, CIDirectRcv) -> True
|
||||
(GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _) -> True
|
||||
_ -> False
|
||||
|
||||
viewGroupSubscribed :: GroupInfo -> [StyledString]
|
||||
viewGroupSubscribed g@GroupInfo {membership} =
|
||||
|
@ -343,8 +350,9 @@ viewItemUpdate chat ChatItem {chatDir, meta, content, quotedItem} ts = case chat
|
|||
CIGroupSnd -> ["message updated"]
|
||||
_ -> []
|
||||
|
||||
viewItemDelete :: ChatInfo c -> ChatItem c d -> Bool -> Bool -> CurrentTime -> [StyledString]
|
||||
viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} markedDeleted byUser ts
|
||||
viewItemDelete :: ChatInfo c -> ChatItem c d -> Bool -> Bool -> Bool -> CurrentTime -> [StyledString]
|
||||
viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} markedDeleted byUser timed ts
|
||||
| timed = []
|
||||
| byUser = if markedDeleted then ["message marked deleted"] else ["message deleted"]
|
||||
| otherwise = case chat of
|
||||
DirectChat Contact {localDisplayName = c} -> case (chatDir, deletedContent) of
|
||||
|
@ -421,9 +429,9 @@ viewContactsList :: [Contact] -> [StyledString]
|
|||
viewContactsList =
|
||||
let ldn = T.toLower . (localDisplayName :: Contact -> ContactName)
|
||||
incognito ct = if contactConnIncognito ct then incognitoPrefix else ""
|
||||
in map (\ct -> incognito ct <> ttyFullContact ct <> muted ct <> alias ct) . sortOn ldn
|
||||
in map (\ct -> incognito ct <> ttyFullContact ct <> muted' ct <> alias ct) . sortOn ldn
|
||||
where
|
||||
muted Contact {chatSettings, localDisplayName = ldn}
|
||||
muted' Contact {chatSettings, localDisplayName = ldn}
|
||||
| enableNtfs chatSettings = ""
|
||||
| otherwise = " (muted, you can " <> highlight ("/unmute @" <> ldn) <> ")"
|
||||
alias Contact {profile = LocalProfile {localAlias}}
|
||||
|
@ -1142,6 +1150,7 @@ viewChatError = \case
|
|||
CEAgentNoSubResult connId -> ["no subscription result for connection: " <> sShow connId]
|
||||
CECommandError e -> ["bad chat command: " <> plain e]
|
||||
CEAgentCommandError e -> ["agent command error: " <> plain e]
|
||||
CEInternalError e -> ["internal chat error: " <> plain e]
|
||||
-- e -> ["chat error: " <> sShow e]
|
||||
ChatErrorStore err -> case err of
|
||||
SEDuplicateName -> ["this display name is already used by user, contact or group"]
|
||||
|
|
|
@ -305,11 +305,6 @@ testAddContact = versionTestMatrix2 runTestAddContact
|
|||
alice #$> ("/_get chat @2 before=" <> itemId 2 <> " count=100", chat, chatFeatures <> [(1, "hello there 🙂")])
|
||||
-- search
|
||||
alice #$> ("/_get chat @2 count=100 search=ello ther", chat, [(1, "hello there 🙂"), (0, "hello there")])
|
||||
-- read messages
|
||||
alice #$> ("/_read chat @2 from=1 to=100", id, "ok")
|
||||
bob #$> ("/_read chat @2 from=1 to=100", id, "ok")
|
||||
alice #$> ("/_read chat @2", id, "ok")
|
||||
bob #$> ("/_read chat @2", id, "ok")
|
||||
|
||||
testDeleteContactDeletesProfile :: IO ()
|
||||
testDeleteContactDeletesProfile =
|
||||
|
@ -615,12 +610,6 @@ testGroupShared alice bob cath checkMessages = do
|
|||
bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "added cath (Catherine)"), (0, "connected"), (0, "hello"), (1, "hi there"), (0, "hey team")])
|
||||
cath @@@ [("@bob", "hey"), ("#team", "hey team"), ("@alice", "received invitation to join group team as admin")]
|
||||
cath #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "connected"), (0, "hello"), (0, "hi there"), (1, "hey team")])
|
||||
alice #$> ("/_read chat #1 from=1 to=100", id, "ok")
|
||||
bob #$> ("/_read chat #1 from=1 to=100", id, "ok")
|
||||
cath #$> ("/_read chat #1 from=1 to=100", id, "ok")
|
||||
alice #$> ("/_read chat #1", id, "ok")
|
||||
bob #$> ("/_read chat #1", id, "ok")
|
||||
cath #$> ("/_read chat #1", id, "ok")
|
||||
alice #$> ("/_unread chat #1 on", id, "ok")
|
||||
alice #$> ("/_unread chat #1 off", id, "ok")
|
||||
|
||||
|
|
|
@ -101,7 +101,7 @@ decodeChatMessageTest :: Spec
|
|||
decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
it "x.msg.new simple text" $
|
||||
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing Nothing))
|
||||
it "x.msg.new simple text - timed message TTL" $
|
||||
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}"
|
||||
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing))
|
||||
|
@ -110,21 +110,21 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
|||
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True)))
|
||||
it "x.msg.new simple link" $
|
||||
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA"}) Nothing))
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA"}) Nothing Nothing))
|
||||
it "x.msg.new simple image" $
|
||||
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCImage "" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing))
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCImage "" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing Nothing))
|
||||
it "x.msg.new simple image with text" $
|
||||
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"here's an image\",\"type\":\"image\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\"}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCImage "here's an image" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing))
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCImage "here's an image" $ ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=") Nothing Nothing))
|
||||
it "x.msg.new chat message " $
|
||||
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
|
||||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)))
|
||||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing Nothing)))
|
||||
it "x.msg.new quote" $
|
||||
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}}}}"
|
||||
##==## ChatMessage
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
(XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing)))
|
||||
(XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing Nothing)))
|
||||
it "x.msg.new quote - timed message TTL" $
|
||||
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"ttl\":3600}}"
|
||||
##==## ChatMessage
|
||||
|
@ -137,7 +137,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
|||
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True))))
|
||||
it "x.msg.new forward" $
|
||||
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}"
|
||||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing))
|
||||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing Nothing))
|
||||
it "x.msg.new forward - timed message TTL" $
|
||||
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}"
|
||||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing))
|
||||
|
@ -146,10 +146,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
|||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True)))
|
||||
it "x.msg.new simple text with file" $
|
||||
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})))
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing}) Nothing))
|
||||
it "x.msg.new simple file with file" $
|
||||
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"\",\"type\":\"file\"},\"file\":{\"fileSize\":12345,\"fileName\":\"file.txt\"}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCFile "") (Just FileInvitation {fileName = "file.txt", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})))
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCFile "") (Just FileInvitation {fileName = "file.txt", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing}) Nothing))
|
||||
it "x.msg.new quote with file" $
|
||||
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
|
||||
##==## ChatMessage
|
||||
|
@ -160,12 +160,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
|||
( extMsgContent
|
||||
(MCText "hello to you too")
|
||||
(Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})
|
||||
Nothing
|
||||
)
|
||||
)
|
||||
)
|
||||
it "x.msg.new forward with file" $
|
||||
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
|
||||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})))
|
||||
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing}) Nothing))
|
||||
it "x.msg.update" $
|
||||
"{\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
|
||||
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue