diff --git a/docs/rfcs/2022-12-12-disappearing-messages.md b/docs/rfcs/2022-12-12-disappearing-messages.md new file mode 100644 index 0000000000..51dcd61e16 --- /dev/null +++ b/docs/rfcs/2022-12-12-disappearing-messages.md @@ -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? + ``` + diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 46944b5f9c..1d96aba2db 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c4b6ec162e..0c4e536daf 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 4b19103a3b..61078a31c4 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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 diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 240906b096..cc96d70a4c 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -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 diff --git a/src/Simplex/Chat/Migrations/M20221212_chat_items_timed.hs b/src/Simplex/Chat/Migrations/M20221212_chat_items_timed.hs new file mode 100644 index 0000000000..b82b66f3d4 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20221212_chat_items_timed.hs @@ -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); +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 3de5440c63..6315776c8c 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -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); diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 0b7a31a662..fc2b9d6227 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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) = diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 2f41a8dc05..c6a1981cf6 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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) diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 6c7ea54cdb..018e7d8153 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -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 diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index 3f04357da7..55c57cb62d 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -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 = diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs new file mode 100644 index 0000000000..cc68c32ce4 --- /dev/null +++ b/src/Simplex/Chat/Util.hs @@ -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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 101d90113b..ab7be7bc02 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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"] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 3770f618dc..c7e12854d9 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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") diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 829c4b3880..d9b3df2749 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -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