From 13ac437aa30f5c25d1d8c2098857c6f8dc58f0e5 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 3 Apr 2024 18:02:27 +0400 Subject: [PATCH] wip --- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 273 ++++++++++-------- src/Simplex/Chat/Controller.hs | 3 + src/Simplex/Chat/Messages.hs | 22 +- .../Migrations/M20240402_item_forwarded.hs | 32 ++ src/Simplex/Chat/Migrations/chat_schema.sql | 15 +- src/Simplex/Chat/Store/Messages.hs | 81 ++++-- src/Simplex/Chat/Store/Migrations.hs | 4 +- 8 files changed, 285 insertions(+), 146 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20240402_item_forwarded.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 3ab530e2d9..54d277d26d 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -140,6 +140,7 @@ library Simplex.Chat.Migrations.M20240228_pq Simplex.Chat.Migrations.M20240313_drop_agent_ack_cmd_id Simplex.Chat.Migrations.M20240324_custom_data + Simplex.Chat.Migrations.M20240402_item_forwarded Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 2367294489..9799a59eae 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -310,6 +310,9 @@ newChatController userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p)) userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user') +withChatLock :: String -> CM a -> CM a +withChatLock name action = asks chatLock >>= \l -> withLock l name action + activeAgentServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ProtoServerWithAuth p) activeAgentServers ChatConfig {defaultServers} p = fromMaybe (cfgServers p defaultServers) @@ -669,104 +672,14 @@ processChatCommand' vr = \case memStatuses -> pure $ Just $ map (uncurry MemberDeliveryStatus) memStatuses _ -> pure Nothing pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses} - APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user -> withChatLock "sendMessage" $ case cType of - CTDirect -> do - ct@Contact {contactId, contactUsed} <- withStore $ \db -> getContact db vr 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 (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) - else do - (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer ct - timed_ <- sndContactCITimed live ct itemTTL - (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ - (msg, _) <- sendDirectContactMessage user ct (XMsgNew msgContainer) - ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) - pure $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) - where - setupSndFileTransfer :: Contact -> CM (Maybe (FileInvitation, CIFile 'MDSnd)) - setupSndFileTransfer ct = forM file_ $ \file -> do - fileSize <- checkSndFile file - xftpSndFileTransfer user file fileSize 1 $ CGContact ct - prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> CM (MsgContainer, Maybe (CIQuote 'CTDirect)) - prepareMsg fInv_ timed_ = case quotedItemId_ of - Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - Just quotedItemId -> do - CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- - withStore $ \db -> getDirectChatItem db user chatId quotedItemId - (origQmc, qd, sent) <- quoteData qci - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} - qmc = quoteContent mc origQmc file - quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) - where - quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool) - quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote - quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) - quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) - quoteData _ = throwChatError CEInvalidQuote - CTGroup -> do - g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user chatId - assertUserGroupRole gInfo GRAuthor - send g - where - send g@(Group gInfo@GroupInfo {groupId} ms) - | isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice - | not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles - | otherwise = do - (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer g (length $ filter memberCurrent ms) - timed_ <- sndGroupCITimed live gInfo itemTTL - (msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ timed_ live - (msg, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) - ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live - withStore' $ \db -> - forM_ sentToMembers $ \GroupMember {groupMemberId} -> - createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew - forM_ (timed_ >>= timedDeleteAt') $ - startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) - pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) - notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f)) - setupSndFileTransfer :: Group -> Int -> CM (Maybe (FileInvitation, CIFile 'MDSnd)) - setupSndFileTransfer g n = forM file_ $ \file -> do - fileSize <- checkSndFile file - xftpSndFileTransfer user file fileSize n $ CGGroup g + APISendMessage (ChatRef cType chatId) live itemTTL cm -> withUser $ \user -> withChatLock "sendMessage" $ case cType of + CTDirect -> sendContactContentMessage user chatId live itemTTL cm Nothing + CTGroup -> sendGroupContentMessage user chatId live itemTTL cm Nothing CTLocal -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - where - xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd) - xftpSndFileTransfer user file fileSize n contactOrGroup = do - (fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup - case contactOrGroup of - CGContact Contact {activeConn} -> forM_ activeConn $ \conn -> - withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr - CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) - where - -- we are not sending files to pending members, same as with inline files - saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = - when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ - withStore' $ - \db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr - saveMemberFD _ = pure () - pure (fInv, ciFile) - APICreateChatItem folderId (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user -> do - forM_ quotedItemId_ $ \_ -> throwError $ ChatError $ CECommandError "not supported" - nf <- withStore $ \db -> getNoteFolder db user folderId - createdAt <- liftIO getCurrentTime - let content = CISndMsgContent mc - let cd = CDLocalSnd nf - ciId <- createLocalChatItem user cd content createdAt - ciFile_ <- forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do - fsFilePath <- lift $ toFSFilePath filePath - fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs - chunkSize <- asks $ fileChunkSize . config - withStore' $ \db -> do - fileId <- createLocalFile CIFSSndStored db user nf ciId createdAt cf fileSize chunkSize - pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} - let ci = mkChatItem cd ciId content ciFile_ Nothing Nothing Nothing False createdAt Nothing createdAt - pure . CRNewChatItem user $ AChatItem SCTLocal SMDSnd (LocalChat nf) ci + APICreateChatItem folderId cm -> withUser $ \user -> + createNoteFolderContentItem user folderId cm Nothing APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> withChatLock "updateChatItem" $ case cType of CTDirect -> do ct@Contact {contactId} <- withStore $ \db -> getContact db vr user chatId @@ -909,6 +822,15 @@ processChatCommand' vr = \case throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ throwChatError (CECommandError "too many reactions") + APIForwardChatItem _fromChatRef toChatRef@(ChatRef toCType _) _chatItemId -> withUser $ \user -> withChatLock "forwardChatItem" $ case toCType of + CTDirect -> do + pure $ chatCmdError (Just user) "not implemented" + CTGroup -> do + pure $ chatCmdError (Just user) "not implemented" + CTLocal -> do + pure $ chatCmdError (Just user) "not implemented" + CTContactRequest -> pure $ chatCmdError (Just user) "not supported" + CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIUserRead userId -> withUserId userId $ \user -> withStore' (`setUserChatsRead` user) >> ok user UserRead -> withUser $ \User {userId} -> processChatCommand $ APIUserRead userId APIChatRead (ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of @@ -1599,12 +1521,17 @@ processChatCommand' vr = \case combineResults _ _ (Left e) = Left e createCI :: DB.Connection -> User -> UTCTime -> (Contact, SndMessage) -> IO () createCI db user createdAt (ct, sndMsg) = - void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing False createdAt + void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False createdAt SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do contactId <- withStore $ \db -> getContactIdByName db user cName quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg let mc = MCText msg processChatCommand . APISendMessage (ChatRef CTDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + ForwardMessage cName (AMsgDirection msgDir) toChatName forwardedMsg -> withUser $ \user@User {userId} -> do + contactId <- withStore $ \db -> getContactIdByName db user cName + forwardedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItem (ChatRef CTDirect contactId) toChatRef forwardedItemId DeleteMessage chatName deletedMsg -> withUser $ \user -> do chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg @@ -1879,6 +1806,11 @@ processChatCommand' vr = \case quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg let mc = MCText msg processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + ForwardGroupMessage gName cName toChatName forwardedMsg -> withUser $ \user -> do + groupId <- withStore $ \db -> getGroupIdByName db user gName + forwardedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName forwardedMsg + toChatRef <- getChatRef user toChatName + processChatCommand $ APIForwardChatItem (ChatRef CTGroup groupId) toChatRef forwardedItemId ClearNoteFolder -> withUser $ \user -> do folderId <- withStore (`getUserNoteFolderId` user) processChatCommand $ APIClearChat (ChatRef CTLocal folderId) @@ -2101,7 +2033,6 @@ processChatCommand' vr = \case -- in a modified CLI app or core - the hook should return Either ChatResponse ChatCommand CustomChatCommand _cmd -> withUser $ \user -> pure $ chatCmdError (Just user) "not supported" where - withChatLock name action = asks chatLock >>= \l -> withLock l name action -- below code would make command responses asynchronous where they can be slow -- in View.hs `r'` should be defined as `id` in this case -- procCmd :: m ChatResponse -> m ChatResponse @@ -2535,6 +2466,104 @@ processChatCommand' vr = \case let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = newStatus} memRole updateDirectChatItemView user ct itemId aciContent False Nothing _ -> pure () -- prohibited + sendContactContentMessage :: User -> ContactId -> Bool -> Maybe Int -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse + sendContactContentMessage user contactId live itemTTL (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do + ct@Contact {contactUsed} <- withStore $ \db -> getContact db vr user contactId + assertDirectAllowed user MDSnd ct XMsgNew_ + unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct + if isVoice mc && not (featureAllowed SCFVoice forUser ct) + then pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFVoice)) + else do + (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer ct + timed_ <- sndContactCITimed live ct itemTTL + (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ + (msg, _) <- sendDirectContactMessage user ct (XMsgNew msgContainer) + ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ itemForwarded timed_ live + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci) + pure $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) + where + setupSndFileTransfer :: Contact -> CM (Maybe (FileInvitation, CIFile 'MDSnd)) + setupSndFileTransfer ct = forM file_ $ \file -> do + fileSize <- checkSndFile file + xftpSndFileTransfer user file fileSize 1 $ CGContact ct + prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> CM (MsgContainer, Maybe (CIQuote 'CTDirect)) + prepareMsg fInv_ timed_ = case (quotedItemId_, itemForwarded) of + (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Just quotedItemId, Nothing) -> do + CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- + withStore $ \db -> getDirectChatItem db user contactId quotedItemId + (origQmc, qd, sent) <- quoteData qci + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} + qmc = quoteContent mc origQmc file + quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + (Just _, Just _) -> throwChatError CEInvalidQuote + where + quoteData :: ChatItem c d -> CM (MsgContent, CIQDirection 'CTDirect, Bool) + quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote + quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) + quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) + quoteData _ = throwChatError CEInvalidQuote + sendGroupContentMessage :: User -> GroupId -> Bool -> Maybe Int -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse + sendGroupContentMessage user groupId live itemTTL (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do + g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user groupId + assertUserGroupRole gInfo GRAuthor + send g + where + send g@(Group gInfo ms) + | isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice + | not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles + | otherwise = do + (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer g (length $ filter memberCurrent ms) + timed_ <- sndGroupCITimed live gInfo itemTTL + (msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ itemForwarded fInv_ timed_ live + (msg, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) + ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ itemForwarded timed_ live + withStore' $ \db -> + forM_ sentToMembers $ \GroupMember {groupMemberId} -> + createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew + forM_ (timed_ >>= timedDeleteAt') $ + startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci) + pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f)) + setupSndFileTransfer :: Group -> Int -> CM (Maybe (FileInvitation, CIFile 'MDSnd)) + setupSndFileTransfer g n = forM file_ $ \file -> do + fileSize <- checkSndFile file + xftpSndFileTransfer user file fileSize n $ CGGroup g + xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd) + xftpSndFileTransfer user file fileSize n contactOrGroup = do + (fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup + case contactOrGroup of + CGContact Contact {activeConn} -> forM_ activeConn $ \conn -> + withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr + CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) + where + -- we are not sending files to pending members, same as with inline files + saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = + when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ + withStore' $ + \db -> createSndFTDescrXFTP db user (Just m) conn ft dummyFileDescr + saveMemberFD _ = pure () + pure (fInv, ciFile) + createNoteFolderContentItem :: User -> NoteFolderId -> ComposedMessage -> Maybe CIForwardedFrom -> CM ChatResponse + createNoteFolderContentItem user folderId (ComposedMessage file_ quotedItemId_ mc) itemForwarded = do + forM_ quotedItemId_ $ \_ -> throwError $ ChatError $ CECommandError "not supported" + nf <- withStore $ \db -> getNoteFolder db user folderId + createdAt <- liftIO getCurrentTime + let content = CISndMsgContent mc + let cd = CDLocalSnd nf + ciId <- createLocalChatItem user cd content itemForwarded createdAt + ciFile_ <- forM file_ $ \cf@CryptoFile {filePath, cryptoArgs} -> do + fsFilePath <- lift $ toFSFilePath filePath + fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cryptoArgs + chunkSize <- asks $ fileChunkSize . config + withStore' $ \db -> do + fileId <- createLocalFile CIFSSndStored db user nf ciId createdAt cf fileSize chunkSize + pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal} + let ci = mkChatItem cd ciId content ciFile_ Nothing Nothing itemForwarded Nothing False createdAt Nothing createdAt + pure . CRNewChatItem user $ AChatItem SCTLocal SMDSnd (LocalChat nf) ci toggleNtf :: User -> GroupMember -> Bool -> CM () toggleNtf user m ntfOn = @@ -2549,10 +2578,11 @@ data ChangedProfileContact = ChangedProfileContact conn :: Connection } -prepareGroupMsg :: User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe FileInvitation -> Maybe CITimed -> Bool -> CM (MsgContainer, Maybe (CIQuote 'CTGroup)) -prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ fInv_ timed_ live = case quotedItemId_ of - Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) - Just quotedItemId -> do +prepareGroupMsg :: User -> GroupInfo -> MsgContent -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> CM (MsgContainer, Maybe (CIQuote 'CTGroup)) +prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of + (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + (Just quotedItemId, Nothing) -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- withStore $ \db -> getGroupChatItem db user groupId quotedItemId (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership @@ -2560,6 +2590,7 @@ prepareGroupMsg user GroupInfo {groupId, membership} mc quotedItemId_ fInv_ time qmc = quoteContent mc origQmc file quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + (Just _, Just _) -> throwChatError CEInvalidQuote where quoteData :: ChatItem c d -> GroupMember -> CM (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote @@ -3994,7 +4025,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta quotedItemId_ = quoteItemId =<< quotedItem fInv_ = fst <$> fInvDescr_ - (msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ fInv_ itemTimed False + (msgContainer, _) <- prepareGroupMsg user gInfo mc quotedItemId_ Nothing fInv_ itemTimed False let senderVRange = memberChatVRange' sender xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer} fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of @@ -6394,17 +6425,17 @@ saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {me _ -> throwError e saveSndChatItem :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> CM (ChatItem c 'MDSnd) -saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing False +saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothing Nothing Nothing Nothing False -saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) -saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem itemTimed live = do +saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) +saveSndChatItem' user cd msg@SndMessage {sharedMsgId} content ciFile quotedItem itemForwarded itemTimed live = do createdAt <- liftIO getCurrentTime ciId <- withStore' $ \db -> do when (ciRequiresAttention content) $ updateChatTs db user cd createdAt - ciId <- createNewSndChatItem db user cd msg content quotedItem itemTimed live createdAt + ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt pure ciId - pure $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemTimed live createdAt Nothing createdAt + pure $ mkChatItem cd ciId content ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live createdAt Nothing createdAt saveRcvChatItem :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> UTCTime -> CIContent 'MDRcv -> CM (ChatItem c 'MDRcv) saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = @@ -6413,18 +6444,18 @@ saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} brokerTs content = saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> CIContent 'MDRcv -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDRcv) saveRcvChatItem' user cd msg@RcvMessage {forwardedByMember} sharedMsgId_ brokerTs content ciFile itemTimed live = do createdAt <- liftIO getCurrentTime - (ciId, quotedItem) <- withStore' $ \db -> do + (ciId, quotedItem, itemForwarded) <- withStore' $ \db -> do when (ciRequiresAttention content) $ updateChatTs db user cd createdAt - (ciId, quotedItem) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt + r@(ciId, _, _) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live brokerTs createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - pure (ciId, quotedItem) - pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemTimed live brokerTs forwardedByMember createdAt + pure r + pure $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live brokerTs forwardedByMember createdAt -mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d -mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs forwardedByMember currentTs = +mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d +mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed live itemTs forwardedByMember currentTs = let itemText = ciContentToText content itemStatus = ciCreateStatus content - meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs + meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing itemForwarded False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file} deleteDirectCI :: MsgDirectionI d => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> CM ChatResponse @@ -6685,17 +6716,17 @@ createInternalItemsForChats user itemTs_ dirsCIContents = do createACIs :: DB.Connection -> UTCTime -> UTCTime -> ChatDirection c d -> [CIContent d] -> [IO AChatItem] createACIs db itemTs createdAt cd = map $ \content -> do ciId <- createNewChatItemNoMsg db user cd content itemTs createdAt - let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing False itemTs Nothing createdAt + let ci = mkChatItem cd ciId content Nothing Nothing Nothing Nothing Nothing False itemTs Nothing createdAt pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci -createLocalChatItem :: MsgDirectionI d => User -> ChatDirection 'CTLocal d -> CIContent d -> UTCTime -> CM ChatItemId -createLocalChatItem user cd content createdAt = do +createLocalChatItem :: MsgDirectionI d => User -> ChatDirection 'CTLocal d -> CIContent d -> Maybe CIForwardedFrom -> UTCTime -> CM ChatItemId +createLocalChatItem user cd content itemForwarded createdAt = do gVar <- asks random withStore $ \db -> do liftIO $ updateChatTs db user cd createdAt createWithRandomId gVar $ \sharedMsgId -> let smi_ = Just (SharedMsgId sharedMsgId) - in createNewChatItem_ db user cd Nothing smi_ content (Nothing, Nothing, Nothing, Nothing, Nothing) Nothing False createdAt Nothing createdAt + in createNewChatItem_ db user cd Nothing smi_ content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False createdAt Nothing createdAt withUser' :: (User -> CM ChatResponse) -> CM ChatResponse withUser' action = @@ -6822,6 +6853,7 @@ chatCommandP = "/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode), "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal), "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), + "/_forward " *> (APIForwardChatItem <$> chatRefP <* A.space <*> chatRefP <* A.space <*> A.decimal), "/_read user " *> (APIUserRead <$> A.decimal), "/read user" $> UserRead, "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))), @@ -6953,6 +6985,8 @@ chatCommandP = "/show link #" *> (ShowGroupLink <$> displayName), "/_create member contact #" *> (APICreateMemberContact <$> A.decimal <* A.space <*> A.decimal), "/_invite member contact @" *> (APISendMemberContactInvitation <$> A.decimal <*> optional (A.space *> msgContentP)), + (">#" <|> "> #") *> (ForwardGroupMessage <$> displayName <* A.char '@' <*> (Just <$> displayName) <* " -> " <*> chatNameP <*> msgTextP), + (">#" <|> "> #") *> (ForwardGroupMessage <$> displayName <*> pure Nothing <* " -> " <*> chatNameP <*> msgTextP), (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> msgTextP), (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP), "/_contacts " *> (APIListContacts <$> A.decimal), @@ -6967,6 +7001,8 @@ chatCommandP = "/* " *> (SendMessage (ChatName CTLocal "") <$> msgTextP), "@#" *> (SendMemberContactMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> msgTextP), "/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")), + (">@" <|> "> @") *> forwardMsgP (AMsgDirection SMDRcv), + (">>@" <|> ">> @") *> forwardMsgP (AMsgDirection SMDSnd), (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> textP), @@ -7081,6 +7117,7 @@ chatCommandP = quoted cs = A.choice [A.char c *> takeNameTill (== c) <* A.char c | c <- cs] refChar c = c > ' ' && c /= '#' && c /= '@' sendMsgQuote msgDir = SendMessageQuote <$> displayName <* A.space <*> pure msgDir <*> quotedMsg <*> msgTextP + forwardMsgP msgDir = ForwardMessage <$> displayName <*> pure msgDir <* " -> " <*> chatNameP <*> msgTextP quotedMsg = safeDecodeUtf8 <$> (A.char '(' *> A.takeTill (== ')') <* A.char ')') <* optional A.space reactionP = MREmoji <$> (mrEmojiChar <$?> (toEmoji <$> A.anyChar)) toEmoji = \case diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 0291793843..5ce877ef80 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -290,6 +290,7 @@ data ChatCommand | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} + | APIForwardChatItem {chatRef :: ChatRef, toChatRef :: ChatRef, chatItemId :: ChatItemId} | APIUserRead UserId | UserRead | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) @@ -410,6 +411,7 @@ data ChatCommand | SendMemberContactMessage GroupName ContactName Text | SendLiveMessage ChatName Text | SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: Text, message :: Text} + | ForwardMessage {contactName :: ContactName, msgDir :: AMsgDirection, toChatName :: ChatName, forwardedMsg :: Text} | SendMessageBroadcast Text -- UserId (not used in UI) | DeleteMessage ChatName Text | DeleteMemberMessage GroupName ContactName Text @@ -438,6 +440,7 @@ data ChatCommand | DeleteGroupLink GroupName | ShowGroupLink GroupName | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: Text, message :: Text} + | ForwardGroupMessage {groupName :: GroupName, contactName_ :: Maybe ContactName, toChatName :: ChatName, forwardedMsg :: Text} | ClearNoteFolder | LastChats (Maybe Int) -- UserId (not used in UI) | LastMessages (Maybe ChatName) Int (Maybe String) -- UserId (not used in UI) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index c24de3b2e1..6c5282e084 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -340,6 +340,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta itemStatus :: CIStatus d, itemSharedMsgId :: Maybe SharedMsgId, itemDeleted :: Maybe (CIDeleted c), + itemForwarded :: Maybe CIForwardedFrom, itemEdited :: Bool, itemTimed :: Maybe CITimed, itemLive :: Maybe Bool, @@ -350,15 +351,15 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta } deriving (Show) -mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d -mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt = +mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Maybe CIForwardedFrom -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d +mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemForwarded itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt = let editable = case itemContent of CISndMsgContent _ -> case chatTypeI @c of SCTLocal -> isNothing itemDeleted _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted _ -> False - in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, forwardedByMember, createdAt, updatedAt} + in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemForwarded, itemEdited, itemTimed, itemLive, editable, forwardedByMember, createdAt, updatedAt} dummyMeta :: ChatItemId -> UTCTime -> Text -> CIMeta c 'MDSnd dummyMeta itemId ts itemText = @@ -369,6 +370,7 @@ dummyMeta itemId ts itemText = itemStatus = CISSndNew, itemSharedMsgId = Nothing, itemDeleted = Nothing, + itemForwarded = Nothing, itemEdited = False, itemTimed = Nothing, itemLive = Nothing, @@ -981,6 +983,18 @@ itemDeletedTs = \case CIBlockedByAdmin ts -> ts CIModerated ts _ -> ts +data CIForwardedFrom + = CIFFUnknown + | CIFFContact {name :: String, contactId :: ContactId} + | CIFFGroup {name :: String, groupId :: GroupId} + | CIFFNoteFolder {name :: String, folderId :: NoteFolderId} + deriving (Show) + +cmForwardedFrom :: AChatMsgEvent -> Maybe CIForwardedFrom +cmForwardedFrom = \case + ACME _ (XMsgNew (MCForward _)) -> Just CIFFUnknown + _ -> Nothing + data ChatItemInfo = ChatItemInfo { itemVersions :: [ChatItemVersion], memberDeliveryStatuses :: Maybe [MemberDeliveryStatus] @@ -1043,6 +1057,8 @@ instance ChatTypeI c => ToJSON (CIDeleted c) where toJSON = J.toJSON . jsonCIDeleted toEncoding = J.toEncoding . jsonCIDeleted +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CIFF") ''CIForwardedFrom) + $(JQ.deriveJSON defaultJSON ''CITimed) $(JQ.deriveJSON (enumJSON $ dropPrefix "SSP") ''SndCIStatusProgress) diff --git a/src/Simplex/Chat/Migrations/M20240402_item_forwarded.hs b/src/Simplex/Chat/Migrations/M20240402_item_forwarded.hs new file mode 100644 index 0000000000..372fe4cec9 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20240402_item_forwarded.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20240402_item_forwarded where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20240402_item_forwarded :: Query +m20240402_item_forwarded = + [sql| +ALTER TABLE chat_items ADD COLUMN forwarded_from_str TEXT; +ALTER TABLE chat_items ADD COLUMN forwarded_from_contact_id INTEGER REFERENCES contacts ON DELETE SET NULL; +ALTER TABLE chat_items ADD COLUMN forwarded_from_group_id INTEGER REFERENCES groups ON DELETE SET NULL; +ALTER TABLE chat_items ADD COLUMN forwarded_from_note_folder_id INTEGER REFERENCES note_folders ON DELETE SET NULL; + +CREATE INDEX idx_chat_items_forwarded_from_contact_id ON chat_items(forwarded_from_contact_id); +CREATE INDEX idx_chat_items_forwarded_from_group_id ON chat_items(forwarded_from_group_id); +CREATE INDEX idx_chat_items_forwarded_from_note_folder_id ON chat_items(forwarded_from_note_folder_id); +|] + +down_m20240402_item_forwarded :: Query +down_m20240402_item_forwarded = + [sql| +DROP INDEX idx_chat_items_forwarded_from_contact_id; +DROP INDEX idx_chat_items_forwarded_from_group_id; +DROP INDEX idx_chat_items_forwarded_from_note_folder_id; + +ALTER TABLE chat_items DROP COLUMN forwarded_from_str; +ALTER TABLE chat_items DROP COLUMN forwarded_from_contact_id; +ALTER TABLE chat_items DROP COLUMN forwarded_from_group_id; +ALTER TABLE chat_items DROP COLUMN forwarded_from_note_folder_id; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 11cbd8ae89..74c9ca97d2 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -382,7 +382,11 @@ CREATE TABLE chat_items( item_deleted_ts TEXT, forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, item_content_tag TEXT, - note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE + note_folder_id INTEGER DEFAULT NULL REFERENCES note_folders ON DELETE CASCADE, + forwarded_from_str TEXT, + forwarded_from_contact_id INTEGER REFERENCES contacts ON DELETE SET NULL, + forwarded_from_group_id INTEGER REFERENCES groups ON DELETE SET NULL, + forwarded_from_note_folder_id INTEGER REFERENCES note_folders ON DELETE SET NULL ); CREATE TABLE chat_item_messages( chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE, @@ -860,3 +864,12 @@ CREATE INDEX idx_chat_items_notes_item_status on chat_items( item_status ); CREATE INDEX idx_files_redirect_file_id on files(redirect_file_id); +CREATE INDEX idx_chat_items_forwarded_from_contact_id ON chat_items( + forwarded_from_contact_id +); +CREATE INDEX idx_chat_items_forwarded_from_group_id ON chat_items( + forwarded_from_group_id +); +CREATE INDEX idx_chat_items_forwarded_from_note_folder_id ON chat_items( + forwarded_from_note_folder_id +); diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index fe89d7f506..c676422e41 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -145,8 +145,8 @@ import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, MsgMeta (..), UserI import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C -import Simplex.Messaging.Crypto.Ratchet (PQSupport) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) +import Simplex.Messaging.Crypto.Ratchet (PQSupport) import Simplex.Messaging.Util (eitherToMaybe) import UnliftIO.STM @@ -330,9 +330,9 @@ updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirecti (chatTs, userId, noteFolderId) _ -> pure () -createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId -createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem timed live createdAt = - createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow timed live createdAt Nothing createdAt +createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId +createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live createdAt = + createNewChatItem_ db user chatDirection createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live createdAt Nothing createdAt where createdByMsgId = if msgId == 0 then Nothing else Just msgId quoteRow :: NewQuoteRow @@ -346,12 +346,13 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) CIQGroupRcv Nothing -> (Just False, Nothing) -createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) +createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom) createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live itemTs createdAt = do - ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow timed live itemTs forwardedByMember createdAt + ciId <- createNewChatItem_ db user chatDirection (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live itemTs forwardedByMember createdAt quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg - pure (ciId, quotedItem) + pure (ciId, quotedItem, itemForwarded) where + itemForwarded = cmForwardedFrom chatMsgEvent quotedMsg = cmToQuotedMsg chatMsgEvent quoteRow :: NewQuoteRow quoteRow = case quotedMsg of @@ -364,13 +365,13 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItemNoMsg db user chatDirection ciContent itemTs = - createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False itemTs Nothing + createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing Nothing False itemTs 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 -> Maybe CITimed -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId -createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs forwardedByMember createdAt = do +createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId +createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live itemTs forwardedByMember createdAt = do DB.execute db [sql| @@ -381,10 +382,12 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q item_sent, item_ts, item_content, item_content_tag, item_text, item_status, shared_msg_id, forwarded_by_group_member_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at, -- quote - quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, + -- forwarded from + forwarded_from_str, forwarded_from_contact_id, forwarded_from_group_id, forwarded_from_note_folder_id + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) + ((userId, msgId_) :. idsRow :. itemRow :. quoteRow :. forwardedFromRow) ciId <- insertedRowId db forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt pure ciId @@ -399,6 +402,13 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing, Nothing) CDLocalRcv NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId) CDLocalSnd NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId) + forwardedFromRow :: (Maybe String, Maybe Int64, Maybe Int64, Maybe Int64) + forwardedFromRow = case itemForwarded of + Nothing -> (Nothing, Nothing, Nothing, Nothing) + Just CIFFUnknown -> (Just "", Nothing, Nothing, Nothing) + Just (CIFFContact name contactId) -> (Just name, Just contactId, Nothing, Nothing) + Just (CIFFGroup name groupId) -> (Just name, Nothing, Just groupId, Nothing) + Just (CIFFNoteFolder name folderId) -> (Just name, Nothing, Nothing, Just folderId) ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime) ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt) @@ -794,7 +804,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do -- this function can be changed so it never fails, not only avoid failure on invalid json toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal) -toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) = +toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) = chatItem $ fromRight invalid $ dbParseACIContent itemContentText where invalid = ACIContent msgDir $ CIInvalidJSON itemContentText @@ -826,7 +836,8 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex DBCINotDeleted -> Nothing _ -> Just (CIDeleted @CTLocal deletedTs) itemEdited' = fromMaybe False itemEdited - in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt + itemForwarded = toCIForwardedFrom forwardedFromRow + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemForwarded itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -1391,7 +1402,14 @@ type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe Bool) -type ChatItemRow = (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) :. (Int, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) :. ChatItemModeRow :. MaybeCIFIleRow +type ChatItemForwardedFromRow = (Maybe String, Maybe Int64, Maybe Int64, Maybe Int64) + +type ChatItemRow = + (Int64, ChatItemTs, AMsgDirection, Text, Text, ACIStatus, Maybe SharedMsgId) + :. (Int, Maybe UTCTime, Maybe Bool, UTCTime, UTCTime) + :. ChatItemForwardedFromRow + :. ChatItemModeRow + :. MaybeCIFIleRow type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) @@ -1406,7 +1424,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir -- this function can be changed so it never fails, not only avoid failure on invalid json toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) -toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) = +toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) = chatItem $ fromRight invalid $ dbParseACIContent itemContentText where invalid = ACIContent msgDir $ CIInvalidJSON itemContentText @@ -1438,10 +1456,20 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT DBCINotDeleted -> Nothing _ -> Just (CIDeleted @CTDirect deletedTs) itemEdited' = fromMaybe False itemEdited - in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt + itemForwarded = toCIForwardedFrom forwardedFromRow + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemForwarded itemEdited' ciTimed itemLive currentTs itemTs Nothing createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} +toCIForwardedFrom :: ChatItemForwardedFromRow -> Maybe CIForwardedFrom +toCIForwardedFrom (forwardedFromStr, forwardedFromContactId, forwardedFromGroupId, forwardedFromFolderId) = + case (forwardedFromStr, forwardedFromContactId, forwardedFromGroupId, forwardedFromFolderId) of + (Just "", Nothing, Nothing, Nothing) -> Just CIFFUnknown + (Just str, Just contactId, Nothing, Nothing) -> Just $ CIFFContact str contactId + (Just str, Nothing, Just groupId, Nothing) -> Just $ CIFFGroup str groupId + (Just str, Nothing, Nothing, Just folderId) -> Just $ CIFFNoteFolder str folderId + _ -> Nothing + type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) @@ -1454,7 +1482,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction -- this function can be changed so it never fails, not only avoid failure on invalid json toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. Only (Maybe GroupMemberId) :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do +toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. Only forwardedByMember :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do chatItem $ fromRight invalid $ dbParseACIContent itemContentText where member_ = toMaybeGroupMember userContactId memberRow_ @@ -1491,7 +1519,8 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, DBCIBlockedByAdmin -> Just (CIBlockedByAdmin deletedTs) _ -> Just (maybe (CIDeleted @CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) itemEdited' = fromMaybe False itemEdited - in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt + itemForwarded = toCIForwardedFrom forwardedFromRow + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemForwarded itemEdited' ciTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -1726,7 +1755,9 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, + i.forwarded_from_str, i.forwarded_from_contact_id, i.forwarded_from_group_id, i.forwarded_from_note_folder_id, + i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- DirectQuote @@ -1966,7 +1997,9 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, + i.forwarded_from_str, i.forwarded_from_contact_id, i.forwarded_from_group_id, i.forwarded_from_note_folder_id, + i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- CIMeta forwardedByMember @@ -2067,7 +2100,9 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.timed_ttl, i.timed_delete_at, i.item_live, + i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, + i.forwarded_from_str, i.forwarded_from_contact_id, i.forwarded_from_group_id, i.forwarded_from_note_folder_id, + i.timed_ttl, i.timed_delete_at, i.item_live, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol FROM chat_items i diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index e351f0f27a..7a3fb75da3 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -104,6 +104,7 @@ import Simplex.Chat.Migrations.M20240226_users_restrict import Simplex.Chat.Migrations.M20240228_pq import Simplex.Chat.Migrations.M20240313_drop_agent_ack_cmd_id import Simplex.Chat.Migrations.M20240324_custom_data +import Simplex.Chat.Migrations.M20240402_item_forwarded import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -207,7 +208,8 @@ schemaMigrations = ("20240226_users_restrict", m20240226_users_restrict, Just down_m20240226_users_restrict), ("20240228_pq", m20240228_pq, Just down_m20240228_pq), ("20240313_drop_agent_ack_cmd_id", m20240313_drop_agent_ack_cmd_id, Just down_m20240313_drop_agent_ack_cmd_id), - ("20240324_custom_data", m20240324_custom_data, Just down_m20240324_custom_data) + ("20240324_custom_data", m20240324_custom_data, Just down_m20240324_custom_data), + ("20240402_item_forwarded", m20240402_item_forwarded, Just down_m20240402_item_forwarded) ] -- | The list of migrations in ascending order by date